(ns ^:typed.clojure com.tailrecursion.blacktide.compiler.passes.graph
"Check initialization on reachable paths; retain all blocks for native Clojure
validation. Liveness carries values through edges without evaluating dead code."
(:require [clojure.set :as set]
[com.tailrecursion.nanopass :as np]
[com.tailrecursion.blacktide.compiler.languages :as l]
[com.tailrecursion.blacktide.compiler.passes.native :as native]
[typed.clojure :as-alias t]))
(np/defpass atom-reads {:from [l/CFG Atom] :to (t/Set t/Sym)}
[node]
:literal #{}
:local #{(:id node)})
(np/defpass rhs-reads {:from [l/Numeric Rhs] :to (t/Set t/Sym)}
[node]
:value (atom-reads (:value node))
:global #{}
:external #{}
:var #{}
:native (native/reads (:value node))
:dispatch (atom-reads (:value (:value node)))
:construct (into #{} (mapcat atom-reads) (:items node))
:metadata (set/union (atom-reads (:value node)) (atom-reads (:metadata node)))
:convert (atom-reads (:value (:value node)))
:numeric (into #{} (mapcat #(atom-reads (:value %))) (:args node))
:host (into #{} (mapcat #(atom-reads (:value %))) (:args node))
:invoke (into (atom-reads (:function node)) (mapcat atom-reads) (:args node)))
(np/defpass term-reads {:from [l/CFG Term] :to (t/Set t/Sym)}
[term]
:jump #{}
:branch (atom-reads (:test term))
:switch (atom-reads (:test term))
:return (atom-reads (:value term))
:throw (atom-reads (:value term)))
(np/defpass successors {:from [l/CFG Term] :to (t/Vec l/CFG-Label)}
[term]
:jump [(:target term)]
:branch [(:yes term) (:no term)]
:switch (if (seq (:targets term)) (:targets term)
(throw (ex-info "Ordinal dispatch requires a destination" {:kind :invalid-graph})))
:return []
:throw [])
(np/defpass block-facts {:from [l/Numeric Block] :to [l/CFG BlockFacts] :body true}
[block]
(let [[reads defs]
(reduce (fn [^{::t/- (t/HVec [(t/Set t/Sym) (t/Set t/Sym)])} acc
^{::t/- l/Numeric-Operation} op]
(let [[reads defs] acc]
[(set/union reads (set/difference (rhs-reads (:value op)) defs))
(conj defs (:target op))])) [#{} #{}] (:ops block))]
{:reads (set/union reads (set/difference (term-reads (:term block)) defs))
:defs defs :successors (successors (:term block))}))
(np/defpass collect-facts {:from [l/Numeric Blocks] :to [l/CFG Facts] :body true}
[blocks]
(update-vals blocks block-facts))
(np/defpass fact-at {:from [l/CFG Label] :to [l/CFG BlockFacts] :args [l/CFG-Facts] :body true}
[facts id]
(or (get facts id) (throw (ex-info "Missing control-flow block" {:kind :invalid-graph :block id}))))
(np/defpass validate-edges {:from [l/CFG Program] :to [l/CFG Program] :args [l/CFG-Facts] :body true}
[facts program]
(do
(fact-at facts (:entry program))
(doseq [[id fact] facts target (:successors fact)]
(when-not (contains? facts target)
(throw (ex-info "Dangling control-flow edge" {:kind :invalid-graph :block id :target target}))))
program))
(np/defpass reachable {:from [l/CFG Label] :to [l/CFG Labels] :args [l/CFG-Facts] :body true}
[facts entry]
((fn ^{::t/- [(t/Vec l/CFG-Label) l/CFG-Labels :-> l/CFG-Labels]} visit [pending seen]
(if-let [id (peek pending)]
(if (contains? seen id)
(recur (pop pending) seen)
(recur (into (pop pending) (:successors (fact-at facts id))) (conj seen id)))
seen)) [entry] #{}))
(np/defpass predecessors {:from [l/CFG Facts] :to [l/CFG Predecessors] :body true}
[facts]
(reduce-kv (fn [^{::t/- l/CFG-Predecessors} out ^{::t/- l/CFG-Label} id ^{::t/- l/CFG-BlockFacts} fact]
(reduce (fn [^{::t/- l/CFG-Predecessors} out ^{::t/- l/CFG-Label} target]
(assoc out target (conj (get out target #{}) id))) out (:successors fact)))
{} facts))
(np/defpass initialized
{:from [l/CFG Label] :to [l/CFG Flow] :args [l/CFG-Facts l/CFG-Predecessors] :body true}
[facts predecessors entry]
(let [universe (reduce set/union #{} (map :defs (vals facts)))
initial (reduce (fn [^{::t/- l/CFG-Flow} out ^{::t/- l/CFG-Label} id]
(assoc out id (if (= entry id) #{} universe))) {} (keys facts))]
;; Greatest fixed point: a backedge does not erase initialization on entry.
((fn ^{::t/- [l/CFG-Flow :-> l/CFG-Flow]} solve [known]
(let [next (reduce-kv
(fn [^{::t/- l/CFG-Flow} out ^{::t/- l/CFG-Label} id ^{::t/- l/CFG-BlockFacts} _]
(assoc out id
(if (= entry id) #{}
(reduce (fn [^{::t/- (t/Set t/Sym)} acc ^{::t/- l/CFG-Label} pred]
(set/intersection acc
(set/union (get known pred #{}) (:defs (fact-at facts pred)))))
universe (get predecessors id #{}))))) {} facts)]
(if (= known next) known (recur next)))) initial)))
(np/defpass validate-initialization
{:from [l/CFG Facts] :to [l/CFG Facts] :args [l/CFG-Flow] :body true}
[known facts]
(do
(doseq [[id fact] facts]
(let [missing (set/difference (:reads fact) (get known id #{}))]
(when (seq missing)
(throw (ex-info "Control flow reads uninitialized locals"
{:kind :uninitialized-slot :block id :slots missing})))))
facts))
(np/defpass liveness {:from [l/CFG Facts] :to [l/CFG Flow] :body true}
[facts]
((fn ^{::t/- [l/CFG-Flow :-> l/CFG-Flow]} solve [live]
(let [next (reduce-kv
(fn [^{::t/- l/CFG-Flow} out ^{::t/- l/CFG-Label} id ^{::t/- l/CFG-BlockFacts} fact]
(let [after (reduce set/union #{} (map #(get live % #{}) (:successors fact)))]
(assoc out id (set/union (:reads fact) (set/difference after (:defs fact)))))) {} facts)]
(if (= live next) live (recur next)))) {}))
(np/defpass allocate
{:from [l/CFG Program] :to [l/Machine Program] :body true}
[program]
(let [live (liveness (collect-facts (:blocks program)))]
(assoc program :live live :slots (vec (sort (reduce set/union #{} (vals live)))))))
(np/defpass validate {:from [l/CFG Program] :to [l/CFG Program] :body true}
[program]
(let [facts (collect-facts (:blocks program))
program (validate-edges facts program)
seen (reachable facts (:entry program))
reachable-facts (select-keys facts seen)]
(validate-initialization (initialized reachable-facts (predecessors reachable-facts) (:entry program)) reachable-facts)
;; Validate before feasibility removes edges. Retain dead native bodies for
;; Clojure's compiler even though only reachable reads need initialization.
program))