| author | Alan Dipert
<alan@dipert.org> 2026-11-11 06:59:26 UTC |
| committer | Alan Dipert
<alan@dipert.org> 2026-11-11 06:59:26 UTC |
| parent | aab4b49644a7b644502a4f3c97565fd3b288ced4 |
| src/com/tailrecursion/blacktide/compiler/languages.clj | +20 | -13 |
| src/com/tailrecursion/blacktide/compiler/passes/box_origins.clj | +3 | -2 |
| src/com/tailrecursion/blacktide/compiler/passes/compact.clj | +10 | -9 |
| src/com/tailrecursion/blacktide/compiler/passes/invariants.clj | +1 | -1 |
| src/com/tailrecursion/blacktide/compiler/passes/joins.clj | +58 | -27 |
| src/com/tailrecursion/blacktide/compiler/passes/loops.clj | +69 | -0 |
| src/com/tailrecursion/blacktide/compiler/passes/numeric.clj | +17 | -1 |
| src/com/tailrecursion/blacktide/compiler/passes/numeric_lower.clj | +8 | -7 |
| src/com/tailrecursion/blacktide/compiler/passes/numeric_rules.clj | +12 | -5 |
| src/com/tailrecursion/blacktide/compiler/passes/storage.clj | +10 | -6 |
| src/com/tailrecursion/blacktide/compiler/passes/structure.clj | +71 | -54 |
| src/com/tailrecursion/blacktide/compiler/passes/structured_emit.clj | +16 | -6 |
| test/com/tailrecursion/blacktide/backend_test.clj | +62 | -6 |
| test/com/tailrecursion/blacktide/check.clj | +1 | -1 |
| test/com/tailrecursion/blacktide/generated_test.clj | +9 | -5 |
| test/com/tailrecursion/blacktide/numeric_test.clj | +31 | -0 |
diff --git a/src/com/tailrecursion/blacktide/compiler/languages.clj b/src/com/tailrecursion/blacktide/compiler/languages.clj index 5113cf1..9e46358 100644 --- a/src/com/tailrecursion/blacktide/compiler/languages.clj +++ b/src/com/tailrecursion/blacktide/compiler/languages.clj @@ -149,7 +149,7 @@ :blocks (t/Map Label Block) :live (t/Map Label (t/Set t/Sym))} :complete? true) Label t/Int Name t/Sym - Code (t/U t/Sym (t/Seq t/Any))}) + Code (t/U t/Sym (t/Seq t/Any) (t/Vec t/Any))}) (np/derive-language CFG Machine {:replace @@ -172,6 +172,7 @@ ;; Recognized numeric calls retain the original host operation and operands. ;; Value facts precede representation selection; neither changes source JVM facts. +;; A plan's origins index the operands whose references it may return unchanged. (np/derive-language Numeric Machine {:add {Rhs [(t/HMap :mandatory {:op ':numeric :args (t/Vec Operand) :parameters (t/Vec java.lang.Class) :return java.lang.Class @@ -182,7 +183,8 @@ ArgumentTypes (t/Vec ValueType) Plan (t/HMap :mandatory {:recipe (t/U ':call ':negate-add ':promoting-negate-add ':divide ':zero-guard ':select ':compare ':narrow-int ':narrow-char ':narrow-checked ':widen-char) - :parameters (t/Vec java.lang.Class) :result java.lang.Class :fresh? t/Bool} :complete? true) + :parameters (t/Vec java.lang.Class) :result java.lang.Class + :origins (t/Vec t/Int)} :complete? true) Graph (t/HMap :mandatory {:entry Label :blocks (t/Map Label Block)} :optional {:slots (t/Vec t/Sym) :live (t/Map Label (t/Set t/Sym))} :complete? true)}}) @@ -196,36 +198,41 @@ (np/deflanguage Planned {Postdominators (t/Map l/Machine-Label (t/Set l/Machine-Label)) - Region (t/HMap :mandatory {:definite (t/Set t/Sym) :changed (t/Set t/Sym)} :complete? true) + LoopBodies (t/Map l/Machine-Label (t/Set l/Machine-Label)) + Region (t/HMap :mandatory {:blocks (t/Set l/Machine-Label) :changed (t/Set t/Sym)} :complete? true) Regions (t/Map l/Machine-Label Region) - Join (t/HMap :mandatory {:target l/Machine-Label :result t/Sym} :complete? true) + Join (t/HMap :mandatory {:target l/Machine-Label :results (t/Vec t/Sym) + :blocks (t/Set l/Machine-Label)} :complete? true) Joins (t/Map l/Machine-Label Join) - Program (t/HMap :mandatory {:machine l/Numeric-Program :joins Joins} :complete? true)}) + Program (t/HMap :mandatory {:machine l/Numeric-Program :joins Joins + :loops (t/Option LoopBodies) :exits Joins} :complete? true)}) ;; Structured recovery produces Joined expressions. Representation selection ;; produces Represented; lexical and numeric lowering follow it. +;; Returns carry one public result or the zero/many values of a lexical join. (np/deflanguage Structured {Expr (t/U (t/HMap :mandatory {:op ':bind :binding l/Numeric-Operation :body Expr} :complete? true) (t/HMap :mandatory {:op ':branch :test l/Machine-Atom :yes Expr :no Expr} :complete? true) (t/HMap :mandatory {:op ':switch :test l/Machine-Atom :arms (t/Vec Expr)} :complete? true) (t/HMap :mandatory {:op ':loop :slots (t/Vec t/Sym) :body Expr} :complete? true) (t/HMap :mandatory {:op ':recur :slots (t/Vec t/Sym)} :complete? true) - (t/HMap :mandatory {:op ':return :value l/Machine-Atom} :complete? true) + (t/HMap :mandatory {:op ':return :values (t/Vec l/Machine-Atom)} :complete? true) (t/HMap :mandatory {:op ':throw :value l/Machine-Atom} :complete? true)) Build (t/U (t/HMap :mandatory {:op ':built :budget t/Int :blocks (t/Vec l/Machine-Label) :expr Expr} :complete? true) - (t/HMap :mandatory {:op ':exhausted} :complete? true)) + (t/HMap :mandatory {:op ':exhausted :reason Fallback} :complete? true)) Arms (t/U (t/HMap :mandatory {:op ':built :budget t/Int :blocks (t/Vec l/Machine-Label) :arms (t/Vec Expr)} :complete? true) - (t/HMap :mandatory {:op ':exhausted} :complete? true)) - Scan (t/HVec [(t/Set l/Machine-Label) (t/Set l/Machine-Label)]) + (t/HMap :mandatory {:op ':exhausted :reason Fallback} :complete? true)) Fallback (t/U ':cycles ':validation ':budget ':native-sites) Decision (t/U (t/HMap :mandatory {:op ':structured :body Expr} :complete? true) (t/HMap :mandatory {:op ':fallback :reason Fallback} :complete? true))}) (np/derive-language Joined Structured - {:add {Expr [(t/HMap :mandatory {:op ':join :target t/Sym :value Expr :body Expr} :complete? true)]} + {:add {Expr [(t/HMap :mandatory {:op ':join :targets (t/Vec t/Sym) :value Expr :body Expr} :complete? true)]} :replace {Context (t/HMap :mandatory {:machine l/Numeric-Program :header (t/Option l/Machine-Label) :slots (t/Vec t/Sym) :joins l/Planned-Joins - :stop (t/Option (t/HVec [l/Machine-Label t/Sym]))} :complete? true)}}) + :loops l/Planned-LoopBodies :exits l/Planned-Joins + :active (t/Set l/Machine-Label) + :stop (t/Option (t/HVec [l/Machine-Label (t/Vec t/Sym)]))} :complete? true)}}) (np/derive-language Represented Joined {:replace {Types (t/Map t/Sym java.lang.Class) @@ -237,12 +244,12 @@ {:replace {Binding (t/HMap :mandatory {:target t/Sym :value Atom} :complete? true) Expr (t/U (t/HMap :mandatory {:op ':bind :binding Operation :body Expr} :complete? true) - (t/HMap :mandatory {:op ':join :target t/Sym :value Expr :body Expr} :complete? true) + (t/HMap :mandatory {:op ':join :targets (t/Vec t/Sym) :value Expr :body Expr} :complete? true) (t/HMap :mandatory {:op ':branch :test Atom :yes Expr :no Expr} :complete? true) (t/HMap :mandatory {:op ':switch :test Atom :arms (t/Vec Expr)} :complete? true) (t/HMap :mandatory {:op ':loop :bindings (t/Vec Binding) :body Expr} :complete? true) (t/HMap :mandatory {:op ':recur :args (t/Vec Atom)} :complete? true) - (t/HMap :mandatory {:op ':return :value Atom} :complete? true) + (t/HMap :mandatory {:op ':return :values (t/Vec Atom)} :complete? true) (t/HMap :mandatory {:op ':throw :value Atom} :complete? true)) Types (t/Map t/Sym java.lang.Class) Program (t/HMap :mandatory {:body Expr :types Types} :complete? true)}}) diff --git a/src/com/tailrecursion/blacktide/compiler/passes/box_origins.clj b/src/com/tailrecursion/blacktide/compiler/passes/box_origins.clj index 88ebc44..c7a8233 100644 --- a/src/com/tailrecursion/blacktide/compiler/passes/box_origins.clj +++ b/src/com/tailrecursion/blacktide/compiler/passes/box_origins.clj @@ -19,7 +19,7 @@ (case (:op rhs) :value [(:value rhs)] :numeric (if-let [plan (numeric/plan types rhs)] - (if (:fresh? plan) [] (mapv :value (:args rhs))) []) + (numeric/origin-values plan rhs) []) [])) (np/defpass reboxable? {:from [l/Numeric Rhs] :to t/Bool :args [l/Analysis-Types] :body true} @@ -33,7 +33,8 @@ (and (= :literal (:op value)) (instance? Long (:value value)) (<= -128 (:value value) 127)))) origins) (case (:op rhs) - :numeric (or (boolean (:fresh? (numeric/plan types rhs))) (class? (facts/rhs-type {} (numeric/source-call rhs)))) + :numeric (or (when-let [plan (numeric/plan types rhs)] (empty? (:origins plan))) + (class? (facts/rhs-type {} (numeric/source-call rhs)))) (:host :convert) (class? (facts/rhs-type {} rhs)) false)))) diff --git a/src/com/tailrecursion/blacktide/compiler/passes/compact.clj b/src/com/tailrecursion/blacktide/compiler/passes/compact.clj index a542ba5..171e7af 100644 --- a/src/com/tailrecursion/blacktide/compiler/passes/compact.clj +++ b/src/com/tailrecursion/blacktide/compiler/passes/compact.clj @@ -32,7 +32,7 @@ :bind (merge-with + (frequencies (rhs-reads (:value (:binding node)))) (dissoc (reads (:body node)) (:target (:binding node)))) :effect (merge-with + (frequencies (rhs-reads (:value (:binding node)))) (reads (:body node))) - :join (merge-with + (reads (:value node)) (dissoc (reads (:body node)) (:target node))) + :join (merge-with + (reads (:value node)) (apply dissoc (reads (:body node)) (:targets node))) :branch (merge-with + (frequencies (atom-reads (:test node))) (reads (:yes node)) (reads (:no node))) :switch (reduce (fn [^{::t/- (t/Map t/Sym t/Int)} refs ^{::t/- l/Compact-Expr} arm] (merge-with + refs (reads arm))) (frequencies (atom-reads (:test node))) (:arms node)) @@ -40,7 +40,7 @@ (merge-with + (frequencies (atom-reads (:value binding))) (dissoc refs (:target binding)))) (reads (:body node)) (rseq (:bindings node))) :recur (frequencies (into [] (mapcat atom-reads) (:args node))) - :return (frequencies (atom-reads (:value node))) :throw (frequencies (atom-reads (:value node)))) + :return (frequencies (into [] (mapcat atom-reads) (:values node))) :throw (frequencies (atom-reads (:value node)))) (np/defpass stable? {:from [l/Compact Expr] :to t/Bool :args [t/Sym (t/Set t/Sym)]} @@ -49,7 +49,7 @@ (not (contains? (reads (:body node)) id)) (stable? id dependencies (:body node))) :effect (stable? id dependencies (:body node)) :join (and (stable? id dependencies (:value node)) - (if (contains? dependencies (:target node)) + (if (some dependencies (:targets node)) (not (contains? (reads (:body node)) id)) (stable? id dependencies (:body node)))) :branch (and (stable? id dependencies (:yes node)) (stable? id dependencies (:no node))) :switch (every? #(stable? id dependencies %) (:arms node)) @@ -150,7 +150,7 @@ :body (if (= from (:target (:binding node))) (:body node) (substitute from replacement (:body node)))) :join (assoc node :value (substitute from replacement (:value node)) - :body (if (= from (:target node)) (:body node) + :body (if (some #{from} (:targets node)) (:body node) (substitute from replacement (:body node)))) ;; Loop initializers see earlier bindings, but the body sees all loop binders. :loop ((fn ^{::t/- [t/Int (t/Vec l/Compact-Binding) t/Bool :-> l/Compact-Expr]} bindings [index pairs shadowed?] @@ -191,8 +191,8 @@ (merge-with + (frequencies (rhs-reads (:value binding))) (dissoc refs id))])] (cond (and (= :native (:op (:value binding))) (not (contains? types id)) - (= body {:op :return :value {:op :local :id id}})) - [{:op :return :value {:op :inline :value (:value binding) :type nil}} + (= body {:op :return :values [{:op :local :id id}]})) + [{:op :return :values [{:op :inline :value (:value binding) :type nil}]} (frequencies (rhs-reads (:value binding)))] (zero? uses) (if (discardable? (:value binding)) [body refs] [{:op :effect :binding binding :body body} @@ -214,10 +214,11 @@ :bind (simplify-bindings types node) :effect (simplify-bindings types node) :join (let [[value value-refs] (simplify types (:value node)) - [body body-refs] (simplify types (:body node)) id (:target node)] - (if (and (not (contains? types id)) (= body {:op :return :value {:op :local :id id}})) + [body body-refs] (simplify types (:body node)) targets (:targets node)] + (if (and (= 1 (count targets)) (not (contains? types (first targets))) + (= body {:op :return :values [{:op :local :id (first targets)}]})) [value value-refs] - [(assoc node :value value :body body) (merge-with + value-refs (dissoc body-refs id))])) + [(assoc node :value value :body body) (merge-with + value-refs (apply dissoc body-refs targets))])) :branch (let [[yes yes-refs] (simplify types (:yes node)) [no no-refs] (simplify types (:no node))] [(assoc node :yes yes :no no) (merge-with + (frequencies (atom-reads (:test node))) yes-refs no-refs)]) diff --git a/src/com/tailrecursion/blacktide/compiler/passes/invariants.clj b/src/com/tailrecursion/blacktide/compiler/passes/invariants.clj index 851c8d4..da4900d 100644 --- a/src/com/tailrecursion/blacktide/compiler/passes/invariants.clj +++ b/src/com/tailrecursion/blacktide/compiler/passes/invariants.clj @@ -9,7 +9,7 @@ (np/defpass assigned {:from [l/Joined Expr] :to (t/Set t/Sym)} [node] :bind (conj (assigned (:body node)) (:target (:binding node))) - :join (conj (set/union (assigned (:value node)) (assigned (:body node))) (:target node)) + :join (into (set/union (assigned (:value node)) (assigned (:body node))) (:targets node)) :branch (set/union (assigned (:yes node)) (assigned (:no node))) :switch (into #{} (mapcat assigned) (:arms node)) :loop (into (assigned (:body node)) (:slots node)) diff --git a/src/com/tailrecursion/blacktide/compiler/passes/joins.clj b/src/com/tailrecursion/blacktide/compiler/passes/joins.clj index a864565..9f9c7d0 100644 --- a/src/com/tailrecursion/blacktide/compiler/passes/joins.clj +++ b/src/com/tailrecursion/blacktide/compiler/passes/joins.clj @@ -1,46 +1,47 @@ (ns ^:typed.clojure com.tailrecursion.blacktide.compiler.passes.joins - "Share acyclic branch continuations with at most one escaping definition. - Every incoming path must define the result. Postdominators nominate exits; - region proofs reject cycles and incomplete paths before recovery." + "Plan shared branch continuations and bounded loop exits. Postdominance + nominates follows; a least fixed point proves that every exit path reaches + its follow or throws. Joins carry only changed locals live at that follow." (:require [clojure.set :as set] [com.tailrecursion.nanopass :as np] [com.tailrecursion.blacktide.compiler.languages :as l] [com.tailrecursion.blacktide.compiler.passes.graph :as graph] + [com.tailrecursion.blacktide.compiler.passes.loops :as loops] [typed.clojure :as-alias t])) -(np/defpass postdominators {:from [l/Numeric Program] :to [l/Planned Postdominators] :body true} - [machine] - (let [labels (set (keys (:blocks machine)))] +(np/defpass postdominators {:from [l/CFG Facts] :to [l/Planned Postdominators] :body true} + [facts] + (let [labels (set (keys facts))] ((fn ^{::t/- [l/Planned-Postdominators :-> l/Planned-Postdominators]} solve [known] (let [next (reduce-kv (fn [^{::t/- l/Planned-Postdominators} out ^{::t/- l/Machine-Label} id - ^{::t/- l/Numeric-Block} block] - (let [successors (graph/successors (:term block)) + ^{::t/- l/CFG-BlockFacts} block] + (let [successors (:successors block) common (if (seq successors) (reduce set/intersection labels (map #(get known % #{}) successors)) #{})] - (assoc out id (conj common id)))) {} (:blocks machine))] + (assoc out id (conj common id)))) {} facts)] (if (= known next) known (recur next)))) (zipmap labels (repeat labels))))) -(np/defpass region - {:from [l/Machine Label] :to (t/Option l/Planned-Region) - :args [l/Numeric-Program l/Machine-Label] :body true} - [machine stop id] +(np/defpass regions + {:from [l/Numeric Program] :to [l/Planned Regions] + :args [(t/Option l/Machine-Label) (t/Set l/Machine-Label)] :body true} + [stop forbidden machine] ;; Prove blocks only after every successor is proved. Each block contributes ;; once; shared paths do not exhaust a traversal budget. Cycles never qualify. - ((fn ^{::t/- [l/Planned-Regions :-> (t/Option l/Planned-Region)]} solve [known] + ((fn ^{::t/- [l/Planned-Regions :-> l/Planned-Regions]} solve [known] (let [next (reduce-kv (fn [^{::t/- l/Planned-Regions} out ^{::t/- l/Machine-Label} label ^{::t/- l/Numeric-Block} block] (let [successors (graph/successors (:term block))] - (if (and (not (contains? out label)) (seq successors) - (every? #(contains? out %) successors)) + (if (and (not (contains? forbidden label)) (not (contains? out label)) + (or (= :throw (:op (:term block))) + (and (seq successors) (every? #(contains? out %) successors)))) (let [own (set (map :target (:ops block))) - regions (mapv #(get out % {:definite #{} :changed #{}}) successors)] + children (map #(get out % {:blocks #{} :changed #{}}) successors)] (assoc out label - {:definite (into own (reduce set/intersection (map :definite regions))) - :changed (into own (mapcat :changed) regions)})) out))) known (:blocks machine))] - (if-let [proof (get next id)] proof - (when (not= known next) (recur next))))) {stop {:definite #{} :changed #{}}})) + {:blocks (into #{label} (mapcat :blocks) children) + :changed (into own (mapcat :changed) children)})) out))) known (:blocks machine))] + (if (= known next) known (recur next)))) (if stop {stop {:blocks #{} :changed #{}}} {}))) (np/defpass candidate {:from [l/Machine Label] :to (t/Option l/Planned-Join) @@ -55,16 +56,46 @@ ;; Only the nearest postdominator can form a nested lexical join. ;; Ignore the branch's preceding definitions when proving its result. (let [branch-machine (update machine :blocks assoc id (assoc block :ops []))] - (when-let [proof (region branch-machine target id)] - (let [outputs (set/intersection (:changed proof) (get (:live machine) target #{})) - result (or (first outputs) (first (sort (:definite proof))))] - (when (and (<= (count outputs) 1) (symbol? result) (contains? (:definite proof) result)) - {:target target :result result}))))))))) + (when-let [proof (get (regions target #{} branch-machine) id)] + (let [results (vec (sort (set/intersection (:changed proof) (get (:live machine) target #{}))))] + ;; Acyclic sharing must not turn a cheap branch into a tuple + ;; allocation. Multiple values are reserved for loop exits. + (when (<= (count results) 1) {:target target :results results :blocks (:blocks proof)}))))))))) + +(np/defpass loop-exits + {:from [l/Planned LoopBodies] :to [l/Planned Joins] :args [l/Numeric-Program l/CFG-Facts] :body true} + [machine facts bodies] + (let [throws (set (keys (regions nil #{} machine))) + ;; Postdominance in normal flow only nominates candidates. The region + ;; proof below still checks every real edge, including throwing tails. + normal (postdominators (update-vals (apply dissoc facts throws) + #(update % :successors (fn [edges] (filterv (complement throws) edges)))))] + (reduce-kv + (fn [^{::t/- l/Planned-Joins} out ^{::t/- l/Machine-Label} header + ^{::t/- (t/Set l/Machine-Label)} members] + (let [exits (set/difference (into #{} (mapcat #(:successors (graph/fact-at facts %))) members) members) + ordinary (set/difference exits throws) + common (when (seq ordinary) (reduce set/intersection (map #(get normal % #{}) ordinary))) + follow (first (sort-by (fn [^{::t/- l/Machine-Label} id] (- (count (get normal id #{})))) + (set/difference (or common #{}) members)))] + (if follow + (let [proof (regions follow members machine)] + (if (every? #(contains? proof %) exits) + (let [tails (map #(get proof % {:blocks #{} :changed #{}}) exits) + changed (into (into #{} (mapcat #(:defs (graph/fact-at facts %))) members) + (mapcat :changed) tails)] + (assoc out header {:target follow :blocks (into members (mapcat :blocks) tails) + :results (vec (sort (set/intersection changed + (get (:live machine) follow #{}))))})) out)) out))) + {} bodies))) (np/defpass plan {:from [l/Numeric Program] :to [l/Planned Program] :body true} [machine] - (let [known (postdominators machine)] + (let [facts (graph/collect-facts machine) + known (postdominators facts) + bodies (loops/analyze (:entry machine) facts)] {:machine machine + :loops bodies :exits (if bodies (loop-exits machine facts bodies) {}) :joins (reduce (fn [^{::t/- l/Planned-Joins} out ^{::t/- l/Machine-Label} id] (if-let [join (candidate machine known id)] (assoc out id join) out)) {} (keys (:blocks machine)))})) diff --git a/src/com/tailrecursion/blacktide/compiler/passes/loops.clj b/src/com/tailrecursion/blacktide/compiler/passes/loops.clj new file mode 100644 index 0000000..d6f852d --- /dev/null +++ b/src/com/tailrecursion/blacktide/compiler/passes/loops.clj @@ -0,0 +1,69 @@ +(ns ^:typed.clojure com.tailrecursion.blacktide.compiler.passes.loops + "Find natural loops in the reachable CFG. Every DFS backedge must target a + dominator; otherwise recovery leaves the irreducible graph to the dispatcher. + Reverse predecessor walks merge all latches belonging to the same header." + (:require [clojure.set :as set] + [com.tailrecursion.nanopass :as np] + [com.tailrecursion.blacktide.compiler.languages :as l] + [com.tailrecursion.blacktide.compiler.passes.graph :as graph] + [typed.clojure :as-alias t])) + +(np/defpass dominators + {:from [l/CFG Facts] :to (t/Map l/CFG-Label l/CFG-Labels) + :args [l/CFG-Label l/CFG-Predecessors] :body true} + [entry predecessors facts] + (let [labels (set (keys facts))] + ((fn ^{::t/- [(t/Map l/CFG-Label l/CFG-Labels) :-> (t/Map l/CFG-Label l/CFG-Labels)]} solve [known] + (let [next (reduce + (fn [^{::t/- (t/Map l/CFG-Label l/CFG-Labels)} out ^{::t/- l/CFG-Label} id] + (assoc out id + (if (= entry id) #{id} + (conj (reduce set/intersection labels + (map #(get known % #{}) (get predecessors id #{}))) id)))) + {} labels)] + (if (= known next) known (recur next)))) (zipmap labels (repeat labels))))) + +(np/defpass backedges + {:from [l/CFG Facts] :to (t/Vec (t/HVec [l/CFG-Label l/CFG-Label])) + :args [l/CFG-Label] :body true} + [entry facts] + (second + ((fn ^{::t/- [l/CFG-Labels + (t/HVec [l/CFG-Labels (t/Vec (t/HVec [l/CFG-Label l/CFG-Label]))]) + l/CFG-Label :-> (t/HVec [l/CFG-Labels (t/Vec (t/HVec [l/CFG-Label l/CFG-Label]))])]} visit + [path state id] + (let [[seen _] state] + (if (contains? seen id) state + (let [path (conj path id)] + (reduce + (fn [^{::t/- (t/HVec [l/CFG-Labels (t/Vec (t/HVec [l/CFG-Label l/CFG-Label]))])} state + ^{::t/- l/CFG-Label} target] + (if (contains? path target) + [(first state) (conj (second state) [id target])] + (visit path state target))) + [(conj seen id) (second state)] (:successors (graph/fact-at facts id))))))) + #{} [#{} []] entry))) + +(np/defpass natural-loop + {:from [l/CFG Label] :to [l/CFG Labels] + :args [l/CFG-Predecessors l/CFG-Label] :body true} + [predecessors header latch] + ((fn ^{::t/- [(t/Vec l/CFG-Label) l/CFG-Labels :-> l/CFG-Labels]} visit [pending members] + (if-let [id (peek pending)] + (if (contains? members id) + (recur (pop pending) members) + (recur (into (pop pending) (get predecessors id #{})) (conj members id))) + members)) [latch] #{header})) + +(np/defpass analyze + {:from [l/CFG Facts] :to (t/Option l/Planned-LoopBodies) :args [l/CFG-Label] :body true} + [entry facts] + (let [facts (select-keys facts (graph/reachable facts entry)) + predecessors (graph/predecessors facts) + dominance (dominators entry predecessors facts) + edges (backedges entry facts)] + (when (every? (fn [[latch header]] (contains? (get dominance latch #{}) header)) edges) + (reduce (fn [^{::t/- l/Planned-LoopBodies} out ^{::t/- (t/HVec [l/CFG-Label l/CFG-Label])} edge] + (let [[latch header] edge] + (assoc out header (set/union (get out header #{}) (natural-loop predecessors header latch))))) + {} edges)))) diff --git a/src/com/tailrecursion/blacktide/compiler/passes/numeric.clj b/src/com/tailrecursion/blacktide/compiler/passes/numeric.clj index ed7befc..570a243 100644 --- a/src/com/tailrecursion/blacktide/compiler/passes/numeric.clj +++ b/src/com/tailrecursion/blacktide/compiler/passes/numeric.clj @@ -62,8 +62,24 @@ {:from [l/Numeric Rhs] :to (t/Option l/Numeric-Plan) :args [l/Analysis-Types] :body true} [types rhs] (when (= :numeric (:op rhs)) - (let [arguments (mapv #(facts/atom-type types (:value %)) (:args rhs))] + (let [arguments (mapv (fn [arg] + (let [type (facts/atom-type types (:value arg))] + ;; Outside value inference, an absent storage fact + ;; means boxed, not the solver's unknown bottom. + (if (= :bottom type) :boxed type))) (:args rhs))] ;; JVM numeric parameter conversion casts to Number before calling RT. ;; An unknown input (including Character) must retain that check. (when (or (nil? (:conversion rhs)) (every? rules/number-type arguments)) (rules/plan arguments (:parameters rhs) (:return rhs) (:operation rhs)))))) + +(np/defpass origin-values + {:from [l/Numeric Rhs] :to (t/Vec l/Machine-Atom) :args [l/Numeric-Plan] :body true} + [plan rhs] + (if (= :numeric (:op rhs)) (mapv #(:value (nth (:args rhs) %)) (:origins plan)) [])) + +(np/defpass applicable? + {:from [l/Numeric Rhs] :to t/Bool :args [l/Represented-Types t/Sym l/Numeric-Plan] :body true} + [types target plan rhs] + ;; A boxed result may alias an input only if that input keeps its box. + (or (contains? types target) + (every? #(not (class? (facts/atom-type types %))) (origin-values plan rhs)))) diff --git a/src/com/tailrecursion/blacktide/compiler/passes/numeric_lower.clj b/src/com/tailrecursion/blacktide/compiler/passes/numeric_lower.clj index 7c0a202..64f82d7 100644 --- a/src/com/tailrecursion/blacktide/compiler/passes/numeric_lower.clj +++ b/src/com/tailrecursion/blacktide/compiler/passes/numeric_lower.clj @@ -39,7 +39,7 @@ (call args (:result plan) {:op :static :class owner :member member :tags (:parameters plan)})) (np/defpass returned {:from [l/Compact Operand] :to [l/Compact Expr] :body true} - [value] {:op :return :value (:value value)}) + [value] {:op :return :values [(:value value)]}) (np/defpass branch {:from [l/Compact Expr] :to [l/Compact Expr] :args [l/Compact-Operand l/Compact-Expr] :body true} @@ -81,7 +81,7 @@ :compare (let [test (fn [relation] (call args (or Boolean/TYPE Boolean) {:op :static :class clojure.lang.Numbers :member relation :tags parameters})) - value (fn [n] {:op :return :value {:op :literal :value n}})] + value (fn [n] {:op :return :values [{:op :literal :value n}]})] (branch (test 'lt) (value -1) (branch (test 'gt) (value 1) (value 0)))) :widen-char (returned (call [(call args (or Integer/TYPE Integer) {:op :static :class clojure.lang.RT :member 'intCast :tags [Character/TYPE]})] @@ -126,11 +126,12 @@ :bind (let [binding (:binding node) rhs (:value binding) target (:target binding) body (expression types (:body node)) plan (numeric/plan types rhs)] - (if (and plan (or (:fresh? plan) (contains? types target))) - (let [value (recipe plan types rhs)] - (if (and (= :return (:op value)) (= :inline (:op (:value value)))) - {:op :bind :binding {:target target :value (:value (:value value))} :body body} - {:op :join :target target :value value :body body})) + (if (and plan (numeric/applicable? types target plan rhs)) + (let [value (recipe plan types rhs) + result (when (= :return (:op value)) (first (:values value)))] + (if (and result (= :inline (:op result))) + {:op :bind :binding {:target target :value (:value result)} :body body} + {:op :join :targets [target] :value value :body body})) {:op :bind :binding {:target target :value (numeric/source-call rhs)} :body body})) :join (assoc node :value (expression types (:value node)) :body (expression types (:body node))) :branch (assoc node :yes (expression types (:yes node)) :no (expression types (:no node))) diff --git a/src/com/tailrecursion/blacktide/compiler/passes/numeric_rules.clj b/src/com/tailrecursion/blacktide/compiler/passes/numeric_rules.clj index 55c3303..6bcccbc 100644 --- a/src/com/tailrecursion/blacktide/compiler/passes/numeric_rules.clj +++ b/src/com/tailrecursion/blacktide/compiler/passes/numeric_rules.clj @@ -49,7 +49,7 @@ objects? (boolean (some #(not (.isPrimitive ^Class %)) parameters)) generic? (and objects? (not (some #(= Double/TYPE %) parameters))) arithmetic-result (if (some #(= Double/TYPE %) tags) (or Double/TYPE result) (or (first tags) result)) - direct {:recipe :call :parameters tags :result arithmetic-result :fresh? true}] + direct {:recipe :call :parameters tags :result arithmetic-result :origins []}] (case family :arithmetic (when numeric? direct) :subtract (when numeric? @@ -63,16 +63,23 @@ :bit (when ints? (assoc direct :result result)) :quotient (when numeric? (cond-> direct (and objects? ints?) (assoc :recipe :zero-guard))) - :divide (when numeric? + :divide (if numeric? (cond ints? (assoc direct :result Number) - generic? (assoc direct :recipe :divide :fresh? false + generic? (assoc direct :recipe :divide + :origins (into [] (keep-indexed #(when (= Double/TYPE %2) %1)) numbers) ;; A Float NaN is returned unchanged, while ;; ordinary floating division yields Double. :result (if (some #(= Float/TYPE %) types) Number arithmetic-result)) - :else direct)) + :else direct) + ;; These overloads delegate to Object/Object division. An + ;; integer cannot be the NaN reference returned unchanged. + (when (and generic? (= 2 (count types)) (some #{Long/TYPE} types) + (every? #{:boxed Long/TYPE} types)) + (assoc direct :parameters (mapv #(if (= Long/TYPE %) (or Long/TYPE Long) Object) types) + :result Number :origins (into [] (keep-indexed #(when (= :boxed %2) %1)) types)))) :select (when (and numeric? (apply = types)) (if objects? - (assoc direct :recipe :select :result (or (first (filter class? types)) result) :fresh? false) + (assoc direct :recipe :select :result (or (first (filter class? types)) result) :origins [0 1]) direct)) :equality (when (or ints? (and numeric? (some #(= Double/TYPE %) parameters))) ;; Object/Object equality observes NaN aliasing. Mixed integer/ diff --git a/src/com/tailrecursion/blacktide/compiler/passes/storage.clj b/src/com/tailrecursion/blacktide/compiler/passes/storage.clj index a77345a..78d58c3 100644 --- a/src/com/tailrecursion/blacktide/compiler/passes/storage.clj +++ b/src/com/tailrecursion/blacktide/compiler/passes/storage.clj @@ -38,12 +38,16 @@ (if-let [source (origins/copy-source rhs)] (if (contains? types source) #{} #{(:target operation)}) #{}) (graph/atom-reads (:value rhs)))) - :numeric (let [plan (numeric/plan types rhs)] - (if (and plan (or (:fresh? plan) (contains? types (:target operation)))) #{} - (let [source (numeric/source-call rhs)] - (cond-> (into (if plan (graph/rhs-reads rhs) #{}) (mapcat #(operand-boxes types %)) (:args rhs)) - (not= (get types (:target operation)) (facts/rhs-type {} source)) - (conj (:target operation)))))) + :numeric (if-let [plan (numeric/plan types rhs)] + (into (if (contains? types (:target operation)) #{} + (into #{} (mapcat graph/atom-reads) (numeric/origin-values plan rhs))) + (mapcat (fn [arg ^Class parameter] + (if (.isPrimitive parameter) #{} (graph/atom-reads (:value arg)))) + (:args rhs) (:parameters plan))) + (let [source (numeric/source-call rhs)] + (cond-> (into #{} (mapcat #(operand-boxes types %)) (:args rhs)) + (not= (get types (:target operation)) (facts/rhs-type {} source)) + (conj (:target operation))))) :host (if (#{:adapt} (:op (:operation rhs))) (graph/rhs-reads rhs) (into #{} (mapcat #(operand-boxes types %)) (:args rhs))) :convert (let [conversion (:conversion rhs)] diff --git a/src/com/tailrecursion/blacktide/compiler/passes/structure.clj b/src/com/tailrecursion/blacktide/compiler/passes/structure.clj index dae9c77..ff5a566 100644 --- a/src/com/tailrecursion/blacktide/compiler/passes/structure.clj +++ b/src/com/tailrecursion/blacktide/compiler/passes/structure.clj @@ -1,7 +1,7 @@ (ns ^:typed.clojure com.tailrecursion.blacktide.compiler.passes.structure - "Recover acyclic control or a single-header loop with bounded duplication. - Construction records block identities to preserve native construction and - cache sites. Dead native code keeps the dispatcher for source validation." + "Recover lexical control from reducible loop regions. Nested loops yield + their live results; tail loops keep their continuation without a packet. + Bounded duplication preserves native sites and dead-code validation." (:require [com.tailrecursion.nanopass :as np] [com.tailrecursion.blacktide.compiler.languages :as l] [com.tailrecursion.blacktide.compiler.passes.graph :as graph] @@ -12,18 +12,6 @@ [machine id] (or (get (:blocks machine) id) (throw (IllegalStateException. "Missing checked block")))) -(np/defpass scan - {:from [l/Machine Label] :to [l/Joined Scan] - :args [l/Numeric-Program (t/Set l/Machine-Label) l/Joined-Scan] :body true} - [machine path state id] - (let [[seen headers] state] - (cond (contains? path id) [seen (conj headers id)] - (contains? seen id) state - :else (reduce (fn [^{::t/- l/Joined-Scan} state ^{::t/- l/Machine-Label} next] - (scan machine (conj path id) state next)) - [(conj seen id) headers] - (graph/successors (:term (block machine id))))))) - (np/defpass harmless-atom? {:from [l/Machine Atom] :to t/Bool} [atom] :local true @@ -47,70 +35,99 @@ (reduce (fn [^{::t/- l/Joined-Expr} body ^{::t/- l/Numeric-Operation} op] {:op :bind :binding op :body body}) end (reverse (:ops block)))) +(np/defpass within-stop? + {:from [l/Planned Join] :to t/Bool :args [l/Joined-Context] :body true} + [ctx join] + (or (nil? (:stop ctx)) (not (contains? (:blocks join) (first (:stop ctx)))))) + (np/defpasses (arms - {:from [l/Machine Term] :to [l/Joined Arms] :args [l/Joined-Context t/Bool t/Int] :body true} - [ctx inside? budget term] + {:from [l/Machine Term] :to [l/Joined Arms] :args [l/Joined-Context t/Int] :body true} + [ctx budget term] (if (= :switch (:op term)) ((fn ^{::t/- [t/Int t/Int (t/Vec l/Joined-Expr) (t/Vec l/Machine-Label) :-> l/Joined-Arms]} build [index budget out blocks] (if (= index (count (:targets term))) {:op :built :budget budget :arms out :blocks blocks} - (let [result (edge ctx inside? budget (nth (:targets term) index))] + (let [result (edge ctx budget (nth (:targets term) index))] (if (= :built (:op result)) (recur (inc index) (:budget result) (conj out (:expr result)) (into blocks (:blocks result))) result)))) 0 budget [] []) - {:op :exhausted})) + {:op :exhausted :reason :budget})) (terminator - {:from [l/Machine Term] :to [l/Joined Build] :args [l/Joined-Context t/Bool t/Int]} - [ctx inside? budget term] - :jump (edge ctx inside? budget (:target term)) - :return {:op :built :budget budget :blocks [] :expr term} + {:from [l/Machine Term] :to [l/Joined Build] :args [l/Joined-Context t/Int]} + [ctx budget term] + :jump (edge ctx budget (:target term)) + :return (if (:stop ctx) {:op :exhausted :reason :cycles} + {:op :built :budget budget :blocks [] :expr {:op :return :values [(:value term)]}}) :throw {:op :built :budget budget :blocks [] :expr term} - :switch (let [result (arms ctx inside? budget term)] + :switch (let [result (arms ctx budget term)] (if (= :built (:op result)) {:op :built :budget (:budget result) :blocks (:blocks result) :expr {:op :switch :test (:test term) :arms (:arms result)}} result)) - :branch (let [yes (edge ctx inside? budget (:yes term))] + :branch (let [yes (edge ctx budget (:yes term))] (if (= :exhausted (:op yes)) yes - (let [no (edge ctx inside? (:budget yes) (:no term))] + (let [no (edge ctx (:budget yes) (:no term))] (if (= :exhausted (:op no)) no {:op :built :budget (:budget no) :blocks (into (:blocks yes) (:blocks no)) :expr {:op :branch :test (:test term) :yes (:expr yes) :no (:expr no)}}))))) (joined - {:from [l/Planned Join] :to [l/Joined Build] :args [l/Joined-Context t/Bool t/Int l/Machine-Term] :body true} - [ctx inside? budget term join] - (let [inner (assoc ctx :stop [(:target join) (:result join)]) - result (terminator inner inside? budget term)] + {:from [l/Planned Join] :to [l/Joined Build] :args [l/Joined-Context t/Int l/Machine-Term] :body true} + [ctx budget term join] + (let [inner (assoc ctx :stop [(:target join) (:results join)]) + result (terminator inner budget term)] (if (= :built (:op result)) - (let [tail (edge ctx inside? (:budget result) (:target join))] + (let [tail (edge ctx (:budget result) (:target join))] (if (= :built (:op tail)) (assoc tail :blocks (into (:blocks result) (:blocks tail)) - :expr {:op :join :target (:result join) :value (:expr result) :body (:expr tail)}) tail)) - {:op :exhausted}))) + :expr {:op :join :targets (:results join) :value (:expr result) :body (:expr tail)}) tail)) + result))) (body - {:from [l/Machine Label] :to [l/Joined Build] :args [l/Joined-Context t/Bool t/Int] :body true} - [ctx inside? budget id] + {:from [l/Machine Label] :to [l/Joined Build] :args [l/Joined-Context t/Int] :body true} + [ctx budget id] (let [block (block (:machine ctx) id) budget (- budget (inc (count (:ops block))))] - (if (neg? budget) {:op :exhausted} - (let [result (if-let [join (get (:joins ctx) id)] - (joined ctx inside? budget (:term block) join) - (terminator ctx inside? budget (:term block)))] + (if (neg? budget) {:op :exhausted :reason :budget} + (let [join (get (:joins ctx) id) + result (if (and join (within-stop? ctx join)) + (joined ctx budget (:term block) join) + (terminator ctx budget (:term block)))] (if (= :built (:op result)) (assoc result :blocks (conj (:blocks result) id) :expr (wrap (:expr result) block)) result))))) + (loop-form + {:from [l/Machine Label] :to [l/Joined Build] :args [l/Joined-Context t/Int] :body true} + [ctx budget id] + (let [slots (vec (sort (get (:live (:machine ctx)) id #{}))) + inner (assoc ctx :header id :slots slots :active (conj (:active ctx) id)) + result (body inner (dec budget) id)] + (if (= :built (:op result)) + (assoc result :expr {:op :loop :slots slots :body (:expr result)}) result))) + (edge - {:from [l/Machine Label] :to [l/Joined Build] :args [l/Joined-Context t/Bool t/Int] :body true} - [ctx inside? budget id] + {:from [l/Machine Label] :to [l/Joined Build] :args [l/Joined-Context t/Int] :body true} + [ctx budget id] (let [stop (:stop ctx)] (cond (and stop (= id (first stop))) - {:op :built :budget budget :blocks [] :expr {:op :return :value {:op :local :id (second stop)}}} + {:op :built :budget budget :blocks [] + :expr {:op :return :values (mapv (fn [id] {:op :local :id id}) (second stop))}} (= id (:header ctx)) - (if inside? (if (pos? budget) {:op :built :budget (dec budget) :blocks [] :expr {:op :recur :slots (:slots ctx)}} - {:op :exhausted}) - (let [result (body ctx true (dec budget) id)] - (if (= :built (:op result)) (assoc result :expr {:op :loop :slots (:slots ctx) :body (:expr result)}) result))) - :else (body ctx inside? budget id))))) + (if (pos? budget) {:op :built :budget (dec budget) :blocks [] :expr {:op :recur :slots (:slots ctx)}} + {:op :exhausted :reason :budget}) + (contains? (:active ctx) id) {:op :exhausted :reason :cycles} + (contains? (:loops ctx) id) + (if (contains? (get (:loops ctx) (:header ctx) #{}) id) + (if-let [join (get (:exits ctx) id)] + (if (within-stop? ctx join) + (let [result (loop-form (assoc ctx :stop [(:target join) (:results join)]) budget id)] + (if (= :built (:op result)) + (let [tail (edge ctx (:budget result) (:target join))] + (if (= :built (:op tail)) + (assoc tail :blocks (into (:blocks result) (:blocks tail)) + :expr {:op :join :targets (:results join) :value (:expr result) :body (:expr tail)}) tail)) result)) + {:op :exhausted :reason :cycles}) + {:op :exhausted :reason :cycles}) + (loop-form ctx budget id)) + :else (body ctx budget id))))) (np/defpass construction-site? {:from [l/Numeric Rhs] :to t/Bool :body true} @@ -143,18 +160,18 @@ (np/defpass recover {:from [l/Planned Program] :to [l/Joined Decision] :body true} [plan] (let [machine (:machine plan) - [reachable headers] (scan machine #{} [#{} #{}] (:entry machine)) + reachable (graph/reachable (graph/collect-facts machine) (:entry machine)) dead (apply dissoc (:blocks machine) reachable) - header (first headers)] + loops (:loops plan)] (cond - (> (count headers) 1) {:op :fallback :reason :cycles} + (nil? loops) {:op :fallback :reason :cycles} (not (every? harmless-block? (vals dead))) {:op :fallback :reason :validation} :else - (let [slots (if header (vec (sort (get (:live machine) header #{}))) []) - ctx {:machine machine :header header :slots slots :joins (:joins plan) :stop nil} + (let [ctx {:machine machine :header nil :slots [] :joins (:joins plan) :stop nil + :loops loops :exits (:exits plan) :active #{}} budget (* 4 (reduce + 0 (map #(inc (count (:ops %))) (vals (select-keys (:blocks machine) reachable))))) - result (edge ctx false budget (:entry machine))] + result (edge ctx budget (:entry machine))] (if (= :built (:op result)) (if-let [reason (site-failure (:blocks result) machine)] {:op :fallback :reason reason} {:op :structured :body (:expr result)}) - {:op :fallback :reason :budget}))))) + {:op :fallback :reason (:reason result)}))))) diff --git a/src/com/tailrecursion/blacktide/compiler/passes/structured_emit.clj b/src/com/tailrecursion/blacktide/compiler/passes/structured_emit.clj index 0cc1943..e762539 100644 --- a/src/com/tailrecursion/blacktide/compiler/passes/structured_emit.clj +++ b/src/com/tailrecursion/blacktide/compiler/passes/structured_emit.clj @@ -79,8 +79,15 @@ (case (:op node) :bind (let [op (:binding node)] (recur (conj pairs (:target op) (operation-form types op)) (:body node))) - :join (recur (conj pairs (:target node) - (binding-form types (:target node) nil (expression types false (:value node)))) (:body node)) + :join (let [targets (:targets node) value (expression types false (:value node))] + (case (count targets) + 0 (list 'let* pairs (list 'do value (expression types public? (:body node)))) + 1 (recur (conj pairs (first targets) (binding-form types (first targets) nil value)) (:body node)) + (let [packet (gensym "values__")] + (recur (into (conj pairs packet value) + (mapcat (fn [index id] + [id (binding-form types id nil (list 'clojure.lang.RT/nth packet index))]) + (range) targets)) (:body node))))) (list 'let* pairs (expression types public? node)))) [] node)) (expression {:from [l/Compact Expr] :to [l/Machine Code] :args [l/Compact-Types t/Bool]} @@ -99,9 +106,12 @@ (atom-form types (:value binding)))])) (:bindings node)) (expression types public? (:body node))) :recur (list* 'recur (mapv #(atom-form types %) (:args node))) - :return (let [value (:value node) form (atom-form types value)] - ;; Tail compaction must retain the region's opaque result type. - (if (or public? (and (= :inline (:op value)) (= :native (:op (:value value))))) - (host/box-form form) form)) + :return (let [values (:values node)] + (if (= 1 (count values)) + (let [value (first values) form (atom-form types value)] + ;; Tail compaction must retain the region's opaque result type. + (if (or public? (and (= :inline (:op value)) (= :native (:op (:value value))))) + (host/box-form form) form)) + (if (seq values) (mapv #(atom-form types %) values) '(quote nil)))) :throw (let [form (list 'throw (atom-form types (:value node)))] (if public? (host/box-form form) form)))) diff --git a/test/com/tailrecursion/blacktide/backend_test.clj b/test/com/tailrecursion/blacktide/backend_test.clj index c5fdd1c..25885d5 100644 --- a/test/com/tailrecursion/blacktide/backend_test.clj +++ b/test/com/tailrecursion/blacktide/backend_test.clj @@ -19,7 +19,7 @@ (list 'quote (if (.hasJavaClass binding) (.getJavaClass binding) Object)))) (deftest compaction-carries-free-read-counts - (let [x (m/local 'x) y (m/local 'y) result {:op :return :value x} + (let [x (m/local 'x) y (m/local 'y) result {:op :return :values [x]} binding (m/call 'x 'f x)] (doseq [[tree expected] [[{:op :bind :binding binding :body result} {'f 1 'x 1}] @@ -27,11 +27,13 @@ [{:op :branch :test (m/local 'test) :yes result :no result} {'test 1 'x 2}] [{:op :switch :test (m/local 'index) :arms [result {:op :throw :value y}]} {'index 1 'x 1 'y 1}] [{:op :loop :bindings [{:target 'x :value x} {:target 'y :value x}] - :body {:op :return :value y}} {'x 1}] + :body {:op :return :values [y]}} {'x 1}] [{:op :recur :args [x y x]} {'x 2 'y 1}] - [{:op :join :target 'x :value result - :body {:op :bind :binding (m/call 'z 'f x) :body {:op :return :value (m/local 'z)}}} + [{:op :join :targets ['x] :value result + :body {:op :bind :binding (m/call 'z 'f x) :body {:op :return :values [(m/local 'z)]}}} {'x 1 'f 1}] + [{:op :join :targets ['x 'y] :value {:op :return :values [y x]} + :body {:op :return :values [x y]}} {'x 1 'y 1}] [{:op :bind :binding (m/assign 'x {:op :value :value y}) :body {:op :bind :binding binding :body result}} {'y 1 'f 1}]]] (let [[out refs] (compact/simplify {} tree)] @@ -41,7 +43,7 @@ tree (reduce (fn [body i] {:op :bind :binding (m/call (symbol (str "x" (inc i))) 'f (m/local (symbol (str "x" i)))) :body body}) - {:op :return :value (m/local (symbol (str "x" n)))} (reverse (range n))) + {:op :return :values [(m/local (symbol (str "x" n)))]} (reverse (range n))) visits (atom 0) reads compact/reads [out refs] (with-redefs [compact/reads (fn [node] (swap! visits inc) (reads node))] (compact/simplify {} tree))] @@ -190,9 +192,16 @@ (let [form '(loophole [i 0 j 0] (while (< i 2) (setq i (inc i))) (while (< j 3) (setq j (inc j))) [i j])] + (is (= :structured (:op (capture #'structure/recover form)))) + (is (= [2 3] ((compile-program form :default) nil)))) + (let [form '(loophole [n 0] + (if (seq @events) (goto left) (goto right)) + (label left) (setq n (inc n)) (when (< n 3) (goto right)) (goto done) + (label right) (setq n (inc n)) (when (< n 3) (goto left)) + (label done) n)] (is (= :cycles (:reason (capture #'structure/recover form)))) (is (nil? (capture #'facts/analyze form)) "Dispatcher fallback skips unused numeric value proofs") - (is (= [2 3] ((compile-program form :default) nil)))) + (doseq [events [[] [:left]]] (is (= 3 ((compile-program form :default) (atom events)))))) (let [step '(if (odd? i) (setq x (inc x) y (inc y)) (setq x (+ x 2) y (+ y 2))) form (list 'loophole '[i 0 x 0 y 0] (list* 'while '(< i 3) (concat (repeat 8 step) ['(setq i (inc i))])) '[x y])] @@ -239,6 +248,53 @@ (setq i (inc i))) values) mode) events))) (is (= [:false :nil :number] @events))))) +(deftest joins-return-current-values-together + (let [form '(loophole [x (Object.) y (Object.) saved-x x saved-y y] + (dotimes [i 1] + (dotimes [j 1] + (if (seq @events) + (psetq x y y x) + (setq x nil)))) + (swap! events conj :joined) + [(identical? x saved-y) (identical? y saved-x) (nil? x)]) + decision (capture #'structure/recover form)] + (is (= :structured (:op decision))) + (is (some #(and (map? %) (= :join (:op %)) (= 2 (count (:targets %)))) + (tree-seq coll? seq (:body decision)))) + (doseq [mode [:default :dispatcher] initial [[] [:swap]]] + (let [events (atom initial)] + (is (= (if (seq initial) [true true false] [false false true]) + ((compile-program form mode) events))) + (is (= (conj initial :joined) @events)))))) + +(deftest nested-loops-preserve-exits-and-reentry + (doseq [[form expected] + [['(loophole [i 0 total 0] + (while (< i 3) + (let [n (do (swap! events conj [:init i]) i)] + (loop [j 0] + (when (< j n) + (swap! events conj [i j]) (setq total (inc total)) (recur (inc j))))) + (setq i (inc i))) total) + {:value 3 :trace [[:init 0] [:init 1] [1 0] [:init 2] [2 0] [2 1]]}] + ['(loophole [i 0 scratch 0] + (while (< i 2) + (loop [j 0] + (when (< j 2) (setq scratch j) (swap! events conj [i j]) (recur (inc j)))) + (setq i (inc i))) i) + {:value 2 :trace [[0 0] [0 1] [1 0] [1 1]]}] + ['(loophole [a 0 b 0] + (dotimes [i 3] + (dotimes [j 3] + (setq a (inc a) b (+ b a)) (swap! events conj [i j a b]) + (when (= a 4) + (let [message (do (swap! events conj :construct) (str a "/" b))] + (throw (ex-info message {:a a :b b}))))))) + {:throw clojure.lang.ExceptionInfo + :trace [[0 0 1 1] [0 1 2 3] [0 2 3 6] [1 0 4 10] :construct]}]]] + (is (= :structured (:op (capture #'structure/recover form)))) + (doseq [mode [:default :generic :dispatcher]] (is (= expected (execution form mode)))))) + (defn primitive-target ^long [^long n] (+ n 1)) (defn primitive-replacement ^long [^long n] (+ n 100)) diff --git a/test/com/tailrecursion/blacktide/check.clj b/test/com/tailrecursion/blacktide/check.clj index 4aab17c..2c6cc92 100644 --- a/test/com/tailrecursion/blacktide/check.clj +++ b/test/com/tailrecursion/blacktide/check.clj @@ -75,7 +75,7 @@ (deftest numeric-representation-boundary (let [call {:op :numeric :operation {:op :static :class clojure.lang.Numbers :member 'add :tags nil} :args [] :parameters [] :return Number} expr {:op :bind :binding {:target 'x :value call} - :body {:op :return :value {:op :local :id 'x}}}] + :body {:op :return :values [{:op :local :id 'x}]}}] (probes/accepts? 'com.tailrecursion.blacktide.compiler.languages/Numeric-Rhs call true) (probes/accepts? 'com.tailrecursion.blacktide.compiler.languages/Machine-Rhs call false) (probes/accepts? 'com.tailrecursion.blacktide.compiler.languages/Represented-Expr expr true) diff --git a/test/com/tailrecursion/blacktide/generated_test.clj b/test/com/tailrecursion/blacktide/generated_test.clj index 7b4da6f..994c284 100644 --- a/test/com/tailrecursion/blacktide/generated_test.clj +++ b/test/com/tailrecursion/blacktide/generated_test.clj @@ -75,6 +75,11 @@ :linear (mapcat (fn [i] `((setq ~'i ~i) ~cut-form ~@body)) (range limit)) :goto `((label ~'again) (when (>= ~'i ~limit) (goto ~'done)) ~cut-form ~@body (setq ~'i (inc ~'i)) (goto ~'again)) + :irreducible `((if (zero? ~'x) (goto ~'left) (goto ~'right)) + (label ~'left) (when (>= ~'i ~limit) (goto ~'done)) ~cut-form + ~@body (setq ~'i (inc ~'i)) (goto ~'right) + (label ~'right) (when (>= ~'i ~limit) (goto ~'done)) ~cut-form + ~@body (setq ~'i (inc ~'i)) (goto ~'left)) :recur `((loop [~'i 0] (when (< ~'i ~limit) ~cut-form ~@body (recur (inc ~'i))))) :nested `((while (< ~'i ~limit) ~cut-form @@ -85,7 +90,7 @@ form `(loophole [~(local 'i) 0 ~(local 'x) ~(initial x) ~(local 'y) ~(initial y)] ~@forms (label ~'done) ~result)] (if renamed? - (let [renames '{i counter__17 x value__93 y value__94 again start__51 done end}] + (let [renames '{i counter__17 x value__93 y value__94 again start__51 done end left phase__1 right phase__2}] (list 'let ['unused :harmless] (walk/postwalk #(if (symbol? %) (with-meta (get renames % %) (meta %)) %) form))) form))) @@ -119,8 +124,7 @@ structure/recover (fn [analysis] (let [out (recover analysis)] (when (and (= :structured (:op out)) - (empty? (second (structure/scan (:machine analysis) #{} [#{} #{}] - (:entry (:machine analysis)))))) + (empty? (:loops analysis))) (swap! coverage update :acyclic (fnil inc 0))) (swap! coverage update (or (:reason out) (:op out)) (fnil inc 0)) out)) storage/select-storage (fn [analysis expr] @@ -128,7 +132,7 @@ (when (seq (select-keys (:types out) (storage/loop-slots (:body out)))) (swap! coverage update :primitive-loops (fnil inc 0))) (when (some #(and (map? %) (= :return (:op %)) - (contains? (:types out) (:id (:value %)))) + (some (fn [value] (contains? (:types out) (:id value))) (:values %))) (tree-seq coll? seq (:body out))) (swap! coverage update :primitive-returns (fnil inc 0))) out))] @@ -136,7 +140,7 @@ (prop/for-all [config configuration] (let [expected (model config)] (every? true? - (for [control [:linear :goto :recur :nested] + (for [control [:linear :goto :recur :nested :irreducible] renamed? [false true] mode [:default :generic :dispatcher]] (= expected (outcome config control renamed? mode)))))) :seed seed)] diff --git a/test/com/tailrecursion/blacktide/numeric_test.clj b/test/com/tailrecursion/blacktide/numeric_test.clj index 659a683..3c66f6b 100644 --- a/test/com/tailrecursion/blacktide/numeric_test.clj +++ b/test/com/tailrecursion/blacktide/numeric_test.clj @@ -234,3 +234,34 @@ (binding [*err* warnings *unchecked-math* :warn-on-boxed] (backend/compile-program '(loophole [sum 0] (dotimes [i 10] (setq sum (+ sum i))) sum) :default)) (is (not (.contains (str warnings) "Boxed math warning")) (str warnings)))) + +(deftest mixed-division-preserves-boxes-without-boxing-the-counter + (doseq [[expression parameters reference] + [['(/ x n) [Object Long/TYPE] (fn [[x limit]] (loop [n 0] (if (< n limit) (recur (inc n)) (/ x n))))] + ['(/ n x) [Long/TYPE Object] (fn [[x limit]] (loop [n 0] (if (< n limit) (recur (inc n)) (/ n x))))]]] + (let [form (list 'let '[x (first events) limit (long (second events))] + (list 'loophole '[n 0] '(while (< n limit) (setq n (inc n))) expression)) + program (backend/capture #'storage/select-storage form) + slots (storage/loop-slots (:body program)) + lowered (backend/capture #'compact/program form) + divisions (filter #(and (map? %) (= :host (:op %)) (= 'divide (:member (:operation %)))) + (tree-seq coll? seq (:body lowered))) + functions (mapv #(backend/compile-program form %) modes) + nan (Double. (Double/longBitsToDouble 9221120237041090626))] + (is (= 1 (count slots))) + (is (= {Long/TYPE 1} (frequencies (vals (select-keys (:types program) slots))))) + (is (= [parameters] (mapv #(get-in % [:operation :tags]) divisions))) + (doseq [x [nil false 0 Long/MIN_VALUE 1/3 10000000000000000000000N 1.25M + -0.0 Double/POSITIVE_INFINITY (Float. Float/NaN) nan] + limit [0 1 150] f functions] + (is (= (outcome reference [x limit]) (outcome f [x limit])) (pr-str [expression x limit])) + (when (or (identical? nan x) (and (instance? Float x) (Float/isNaN x))) + (is (identical? x (f [x limit])) "NaN division returns the original reference, even before a zero check"))) + (let [calls (atom []) + x (proxy [Number] [] + (longValue [] (swap! calls conj :long) 2) + (intValue [] (swap! calls conj :int) 2) + (doubleValue [] (swap! calls conj :double) 2.0) + (floatValue [] (swap! calls conj :float) (float 2))) + observe (fn [f] (reset! calls []) [(outcome f [x 150]) @calls])] + (doseq [f functions] (is (= (observe reference) (observe f))))))))