| author | Alan Dipert
<alan@dipert.org> 2026-11-11 00:39:35 UTC |
| committer | Alan Dipert
<alan@dipert.org> 2026-11-11 00:39:35 UTC |
| parent | 6262a4e2a3d659a0774c7bcf05d4d9d606a2c527 |
| doc/compiler.md | +11 | -11 |
| doc/tutorial.md | +11 | -15 |
| src/com/tailrecursion/blacktide/compiler.clj | +8 | -14 |
| src/com/tailrecursion/blacktide/compiler/languages.clj | +2 | -11 |
| src/com/tailrecursion/blacktide/compiler/passes/boundaries.clj | +16 | -14 |
| src/com/tailrecursion/blacktide/compiler/passes/cases.clj | +0 | -31 |
| src/com/tailrecursion/blacktide/compiler/passes/collections.clj | +5 | -5 |
| src/com/tailrecursion/blacktide/compiler/passes/graph.clj | +8 | -7 |
| src/com/tailrecursion/blacktide/compiler/passes/lower.clj | +9 | -9 |
| src/com/tailrecursion/blacktide/compiler/passes/order.clj | +3 | -3 |
| src/com/tailrecursion/blacktide/compiler/passes/results.clj | +0 | -22 |
| src/com/tailrecursion/blacktide/compiler/passes/source_values.clj | +0 | -44 |
| src/com/tailrecursion/blacktide/compiler/passes/storage.clj | +1 | -1 |
| src/com/tailrecursion/blacktide/compiler/passes/structured_emit.clj | +18 | -18 |
| test/com/tailrecursion/blacktide/backend_fixture.clj | +41 | -0 |
| test/com/tailrecursion/blacktide/backend_test.clj | +16 | -51 |
| test/com/tailrecursion/blacktide/check.clj | +6 | -4 |
| test/com/tailrecursion/blacktide/collections_test.clj | +9 | -14 |
| test/com/tailrecursion/blacktide/generated_test.clj | +1 | -1 |
| test/com/tailrecursion/blacktide/graph_test.clj | +6 | -6 |
| test/com/tailrecursion/blacktide/invocation_test.clj | +1 | -1 |
| test/com/tailrecursion/blacktide/lookup_test.clj | +1 | -1 |
| test/com/tailrecursion/blacktide/machine_test.clj | +2 | -11 |
| test/com/tailrecursion/blacktide/native_sites_test.clj | +3 | -2 |
| test/com/tailrecursion/blacktide/numeric_test.clj | +14 | -10 |
| test/com/tailrecursion/blacktide/source_loops_test.clj | +2 | -6 |
| test/com/tailrecursion/blacktide/source_values_test.clj | +1 | -1 |
diff --git a/doc/compiler.md b/doc/compiler.md index 1c7ff77..463dde5 100644 --- a/doc/compiler.md +++ b/doc/compiler.md @@ -15,32 +15,32 @@ For a walkthrough with actual inputs, intermediate data and generated code, see | Stage | Responsibility | | --- | --- | | Source | Expand macros in order. Assign unique lexical identities, record source JVM facts and enforce the supported subset. Determine loop representations without repeating expansion. | -| Classification | Preserve analyzed loops without DSL effects and native keyword calls. Make representations explicit for loops that need lowering. | -| Normalization | Lower sequential and parallel assignments, case and collections. Prepare conversions and save operands in evaluation order. | -| Graph | Resolve outer labels and check destinations and definite initialization. Compute liveness and allocate slots. | -| Backend | Fold literal branches and recover structured control with shared joins. Prove numeric values, choose safe primitive storage, lower numeric operations and compact safe intermediates. Use the dispatcher when structured recovery is ineligible. | +| Classification | Preserve analyzed loops without DSL effects and native keyword calls. Make lowered loop representations and primitive source-local reads explicit. | +| Normalization | Lower sequential and parallel assignments and collections. Prepare conversions and save operands in evaluation order. | +| Graph | Lower branches and case dispatch, resolve outer labels and check destinations and definite initialization before simplifying control flow. | +| Backend | Fold literal branches, compute liveness and recover structured control with shared joins. Prove numeric values, choose safe primitive storage, lower numeric operations and compact safe intermediates. Allocate the original graph for the dispatcher when structured recovery is ineligible. | | Emission | Emit Clojure that preserves conversions and construction sites. Preserve the Object result boundary at exits without taking a tail loop out of tail position. | `compiler/compile-form` orchestrates source analysis and lowering: ```text -Bound → Classified → Sequential → Assigned → Cases → Collections - → Prepared → Ordered → Symbolic → CFG → Machine +Bound → Classified → Sequential → Assigned → Collections + → Prepared → Ordered → Symbolic → CFG ``` The linear driver uses ordinary `->` composition of unary stages. Each tree language has a `Compilation` nonterminal: a `[supply tree]` pair containing the immutable fresh-name supply and that language's `Expr`. Stage entry points live beside their recursive processors. They use `pipeline/map-value` to preserve the supply or `apply` to pass both components to a processor that allocates names. Graph construction consumes the pair and returns a graph. Typed Clojure checks each stage's input and output, including the tree inside `Compilation`. Incompatible language transitions are type errors; semantic ordering constraints within the same language still require tests. Recursive processors keep their own precise arguments and results. -The outer bindings enter as one lexical scope. `Native` contains analyzed subtrees without DSL operations. Both backends share graph validation: +The outer bindings enter as one lexical scope. `Native` contains analyzed subtrees without DSL operations. Both backends start with the validated CFG; each allocates slots for the edges it will emit: ```text -Dispatcher: Machine → Code -Structured: Machine → Numeric → Analysis → Planned → Joined - → Represented → Lexical → Compact → Sealed → Code +Dispatcher: CFG → Machine → Code +Structured: CFG → Machine → Numeric → Analysis → Planned → Joined + → Represented → Lexical → Compact → Code ``` -`numeric` recognizes numeric runtime calls and implicit Java numeric conversions, retaining their original signatures. `value-facts` proves scalar values across assignments and backedges; a boxed result can still be known to contain a long. `storage` chooses representations after accounting for consumers, copies and observable identity. `lexical` makes loop arguments explicit. `numeric-lower` implements the proven equivalences using host operations and ordinary control flow. `compact` simplifies safe intermediates, and `results` marks public exits before emission. +`numeric` recognizes numeric runtime calls and implicit Java numeric conversions, retaining their original signatures. `value-facts` proves scalar values across assignments and backedges; a boxed result can still be known to contain a long. `storage` chooses representations after accounting for consumers, copies and observable identity. `lexical` makes loop arguments explicit. `numeric-lower` implements the proven equivalences using host operations and ordinary control flow. `compact` simplifies safe intermediates. Emission applies the Object result boundary at public exits and leaves join values internal. Inference and lowering share `numeric-rules`. Knowing the operands' values is insufficient: their original overload determines overflow, conversion and reference-return behavior. diff --git a/doc/tutorial.md b/doc/tutorial.md index f0925fb..c54a58a 100644 --- a/doc/tutorial.md +++ b/doc/tutorial.md @@ -144,9 +144,7 @@ The remaining examples use `stages` to run the pipeline and retain intermediate '[com.tailrecursion.blacktide.compiler :as compiler] '[com.tailrecursion.blacktide.compiler.passes.source :as source] '[com.tailrecursion.blacktide.compiler.passes.boundaries :as boundaries] - '[com.tailrecursion.blacktide.compiler.passes.source-values :as source-values] '[com.tailrecursion.blacktide.compiler.passes.assignment :as assignment] - '[com.tailrecursion.blacktide.compiler.passes.cases :as cases] '[com.tailrecursion.blacktide.compiler.passes.collections :as collections] '[com.tailrecursion.blacktide.compiler.passes.prepare :as prepare] '[com.tailrecursion.blacktide.compiler.passes.order :as order] @@ -162,19 +160,17 @@ The remaining examples use `stages` to run the pipeline and retain intermediate :site {:form form :file nil :line nil :column nil}} [supply bound] (source/parse-scope {:prefix "demo" :next 0} ctx true (vec form)) classified (boundaries/classify bound) - values (source-values/expression classified) - sequential (assignment/sequential values) + sequential (assignment/sequential classified) [supply assigned] (assignment/parallel supply sequential) - selected (cases/normalize assigned) - constructed (collections/normalize selected) + constructed (collections/normalize assigned) prepared (prepare/prepare constructed) [supply ordered] (order/normalize supply prepared) symbolic (lower/compile-graph supply ordered) - cfg (transfers/resolve-program symbolic) - machine (graph/analyze cfg)] + cfg (-> symbolic transfers/resolve-program graph/validate) + machine (graph/allocate cfg)] {:bound bound :ordered ordered :cfg cfg :machine machine :dispatcher (emit/program-form machine) - :code (compiler/compile-program machine)})) + :code (compiler/compile-program cfg)})) (defn readable [value] (walk/postwalk @@ -343,10 +339,10 @@ Now return to the summation. We can ask the graph for its entry block and termin ```text {0 {:op :jump, :target 1}, - 1 {:op :branch, :test {:op :local, :id v34}, :yes 2, :no 3}, + 1 {:op :branch, :test {:op :local, :id v32}, :yes 2, :no 3}, 2 {:op :jump, :target 1}, 3 {:op :jump, :target 4}, - 4 {:op :return, :value {:op :local, :id v47}}, + 4 {:op :return, :value {:op :local, :id v0}}, 5 {:op :jump, :target 4}} ``` @@ -430,7 +426,7 @@ Our `stages` function asks for dispatcher code as well as normal compiler output ```clojure (binding [*print-meta* true] - (pprint (readable (second (second (:dispatcher compilation)))))) + (pprint (readable (second (:dispatcher compilation))))) ``` ```text @@ -486,9 +482,9 @@ Having carefully dismantled the loop, we would now like a loop. Here's the norma (if (^{:param-tags [long long]} clojure.lang.Numbers/lt v3 '10) (let* - [v41 (^{:param-tags [long long]} clojure.lang.Numbers/add v0 v3)] + [v37 (^{:param-tags [long long]} clojure.lang.Numbers/add v0 v3)] (recur - v41 + v37 (^{:param-tags [long]} clojure.lang.Numbers/unchecked_inc v3))) (^{:param-tags [java.lang.Object]} clojure.lang.RT/box v0))) ``` @@ -505,7 +501,7 @@ Two terms help here: a _join_ is a point where control-flow paths meet, and a _l | Join planning and structured recovery | Arrange shared paths and recover conditionals and loops. | | Invariants and storage | Remove loop parameters that only forward unchanged outer values; choose storage without changing object identity. | | Numeric lowering | Select proven primitive overloads; preserve other calls unchanged. | -| Compaction, result boundaries and emission | Remove safe intermediates, mark public exits and emit Clojure. | +| Compaction and emission | Remove safe intermediates and emit Clojure with an Object boundary at public exits. | The [architecture guide](compiler.md) covers these passes in detail. Graphs outside the structured backend's supported shapes use the dispatcher. A graph with nested cycles does not automatically get reconstructed as nested Clojure loops. diff --git a/src/com/tailrecursion/blacktide/compiler.clj b/src/com/tailrecursion/blacktide/compiler.clj index 137204a..cb95f37 100644 --- a/src/com/tailrecursion/blacktide/compiler.clj +++ b/src/com/tailrecursion/blacktide/compiler.clj @@ -7,9 +7,7 @@ [com.tailrecursion.blacktide.compiler.passes.source :as source] [com.tailrecursion.blacktide.compiler.passes.source-jvm :as facts] [com.tailrecursion.blacktide.compiler.passes.boundaries :as boundaries] - [com.tailrecursion.blacktide.compiler.passes.cases :as cases] [com.tailrecursion.blacktide.compiler.passes.assignment :as assignment] - [com.tailrecursion.blacktide.compiler.passes.source-values :as source-values] [com.tailrecursion.blacktide.compiler.passes.collections :as collections] [com.tailrecursion.blacktide.compiler.passes.order :as order] [com.tailrecursion.blacktide.compiler.passes.prepare :as prepare] @@ -26,17 +24,16 @@ [com.tailrecursion.blacktide.compiler.passes.invariants :as invariants] [com.tailrecursion.blacktide.compiler.passes.storage :as storage] [com.tailrecursion.blacktide.compiler.passes.compact :as compact] - [com.tailrecursion.blacktide.compiler.passes.results :as results] [com.tailrecursion.blacktide.compiler.passes.structured-emit :as structured] [com.tailrecursion.blacktide.compiler.passes.emit :as emit] [typed.clojure :as-alias t])) (np/defpass compile-program - {:from [l/Machine Program] :to [l/Machine Code] :body true} - [machine] - (let [analysis (-> {:entry (:entry machine) :blocks (:blocks machine)} + {:from [l/CFG Program] :to [l/Machine Code] :body true} + [cfg] + (let [analysis (-> cfg feasible/program - graph/analyze + graph/allocate numeric/program value-facts/analyze) decision (-> analysis joins/plan structure/recover)] @@ -46,26 +43,23 @@ (storage/select-storage analysis) lexical/program numeric-lower/program - compact/program - results/program)] - (structured/expression (:types program) (:body program))) - (emit/program-form machine)))) + compact/program)] + (structured/expression (:types program) true (:body program))) + (emit/program-form (graph/allocate cfg))))) (np/defpass compile-tree {:from [l/Bound Compilation] :to [l/Machine Code] :body true} [compilation] (-> compilation boundaries/stage - source-values/stage assignment/sequential-stage assignment/parallel-stage - cases/stage collections/stage prepare/stage order/stage lower/stage transfers/resolve-program - graph/analyze + graph/validate compile-program)) (np/defpass caller-locals diff --git a/src/com/tailrecursion/blacktide/compiler/languages.clj b/src/com/tailrecursion/blacktide/compiler/languages.clj index f2ee98a..26568c2 100644 --- a/src/com/tailrecursion/blacktide/compiler/languages.clj +++ b/src/com/tailrecursion/blacktide/compiler/languages.clj @@ -39,7 +39,7 @@ Selection (t/HMap :mandatory {:method (t/Option Method) :exact? t/Bool :tied? t/Bool} :complete? true)}) ;; Source normalization: Bound -> Classified -> Sequential -> Assigned -> -;; Cases -> Collections -> Prepared -> Ordered. Native is a restricted subtree. +;; Collections -> Prepared -> Ordered. Native is a restricted subtree. (np/deflanguage Bound {Raw t/Any Forms (t/Vec Raw) @@ -104,11 +104,7 @@ (np/derive-language Assigned Sequential {:remove {Node #{:psetq}}}) -(np/derive-language Cases Assigned - {:remove {Node #{:case}} - :add {Node [(t/HMap :mandatory {:op ':select :selector Expr :arms Exprs} :complete? true)]}}) - -(np/derive-language Collections Cases +(np/derive-language Collections Assigned {:remove {Node #{:collection}} :add {Node [(t/HMap :mandatory {:op ':build :kind CollectionKind :items Exprs :unique? t/Bool :metadata (t/Option Expr)} :complete? true)]}}) @@ -260,8 +256,3 @@ {:remove {Rhs #{:numeric}} :add {Atom [(t/HMap :mandatory {:op ':inline :value Rhs :type (t/Option java.lang.Class)} :complete? true)] Expr [(t/HMap :mandatory {:op ':effect :binding Operation :body Expr} :complete? true)]}}) - -;; Public exits carry an Object boundary; join results remain internal values. -(np/derive-language Sealed Compact - {:add {Expr [(t/HMap :mandatory {:op ':result :value Atom} :complete? true) - (t/HMap :mandatory {:op ':raise :value Atom} :complete? true)]}}) diff --git a/src/com/tailrecursion/blacktide/compiler/passes/boundaries.clj b/src/com/tailrecursion/blacktide/compiler/passes/boundaries.clj index cfc82f1..8257cf4 100644 --- a/src/com/tailrecursion/blacktide/compiler/passes/boundaries.clj +++ b/src/com/tailrecursion/blacktide/compiler/passes/boundaries.clj @@ -1,6 +1,7 @@ (ns ^:typed.clojure com.tailrecursion.blacktide.compiler.passes.boundaries "Classify analyzed native bodies before expression lowering. Native subtrees - exclude DSL effects; lowered loops materialize their source representations." + exclude DSL effects; lowered loops materialize their source representations. + Preserve separate boxing at Object uses of primitive source-local reads." (:require [com.tailrecursion.blacktide.compiler.passes.effects :refer [effects]] [com.tailrecursion.nanopass :as np] [com.tailrecursion.nanopass.pipeline :as pipeline] @@ -11,17 +12,10 @@ (np/defpasses (native-node {:from [l/Bound Node] :to [l/Native Node] - :processors {Expr native Exprs native-forms Binding native-binding}} + :processors {Expr native Exprs native-forms Binding native-binding + Local clojure.core/identity Raw clojure.core/identity CollectionKind clojure.core/identity + RecurTarget clojure.core/identity CaseSpec clojure.core/identity}} [node] - :literal node :local node :global node :var node - :case {:op :case :selector (native (:selector node)) - :arms (native-forms (:arms node))} - :dispatch {:op :dispatch :value (native (:value node)) :spec (:spec node)} - :collection {:op :collection :kind (:kind node) :items (native-forms (:items node)) - :metadata (when-let [metadata (:metadata node)] (native metadata))} - :recur {:op :recur :target (:target node) :args (mapv native (:args node))} - :loop {:op :loop :id (:id node) :bindings (mapv native-binding (:bindings node)) - :body (native (:body node))} :setq (if (empty? (:pairs node)) {:op :literal :value nil} (throw (IllegalStateException. "Native local write"))) :psetq (if (empty? (:pairs node)) {:op :literal :value nil} (throw (IllegalStateException. "Native parallel write"))) :label (throw (IllegalStateException. "Native label")) @@ -43,8 +37,7 @@ :processors {Expr classify Exprs classify-forms Binding classify-binding Assignments classify-pairs Local clojure.core/identity RecurTarget clojure.core/identity Raw clojure.core/identity CollectionKind clojure.core/identity CaseSpec clojure.core/identity}} - [node] - :loop {:op :loop :id (:id node) :bindings (mapv classify-binding (:bindings node)) :body (classify (:body node))}) + [node]) (classify-pair {:from [l/Bound Assignment] :to [l/Classified Assignment] :processors {Expr classify Local clojure.core/identity}} @@ -74,7 +67,16 @@ (and (= :loop (:op node)) (not (effects expr))) (assoc expr :node {:op :native :value (native expr)}) (= :loop (:op node)) (let [expr (loops/lower expr)] (assoc expr :node (classify-node (:node expr)))) - :else (assoc expr :node (classify-node node)))))) + :else + (let [expr (assoc expr :node (classify-node node)) type (:type (:jvm expr))] + ;; A machine slot must not turn separate Object uses of a primitive + ;; source local into aliases of one box. Native bodies retain those + ;; uses already; mutable locals have reference semantics. + (if (and (= :local (:op (:node expr))) (:primitive? (:jvm expr)) + (class? type) (.isPrimitive ^Class type) (not= Void/TYPE type)) + (assoc expr :node {:op :host :operation {:op :static :class clojure.lang.RT + :member (symbol (str (.getName ^Class type) "Cast")) :tags [type]} + :args [expr]}) expr)))))) (np/defpass stage {:from [l/Bound Compilation] :to [l/Classified Compilation] :body true} diff --git a/src/com/tailrecursion/blacktide/compiler/passes/cases.clj b/src/com/tailrecursion/blacktide/compiler/passes/cases.clj deleted file mode 100644 index d2150b5..0000000 --- a/src/com/tailrecursion/blacktide/compiler/passes/cases.clj +++ /dev/null @@ -1,31 +0,0 @@ -(ns ^:typed.clojure com.tailrecursion.blacktide.compiler.passes.cases - "Separate source case from ordinal arm selection after native constant dispatch. - Each source arm occurs once, including grouped and hash-collision alternatives." - (:require [com.tailrecursion.nanopass :as np] - [com.tailrecursion.nanopass.pipeline :as pipeline] - [com.tailrecursion.blacktide.compiler.languages :as l])) - -(np/defpasses - (normalize-node - {:from [l/Assigned Node] :to [l/Cases Node] - :processors {Expr normalize Exprs normalize-forms Binding normalize-binding - Raw clojure.core/identity Local clojure.core/identity CollectionKind clojure.core/identity - RecurTarget clojure.core/identity CaseSpec clojure.core/identity}} - [node] - :case - {:op :select :selector (normalize (:selector node)) :arms (normalize-forms (:arms node))}) - - (normalize-binding {:from [l/Assigned Binding] :to [l/Cases Binding] - :processors {Expr normalize Local clojure.core/identity}} - [binding]) - - (normalize-forms {:from [l/Assigned Exprs] :to [l/Cases Exprs] :processors {Expr normalize}} - [forms]) - - (normalize {:from [l/Assigned Expr] :to [l/Cases Expr] :body true} - [expr] (assoc expr :node (normalize-node (:node expr))))) - -(np/defpass stage - {:from [l/Assigned Compilation] :to [l/Cases Compilation] :body true} - [compilation] - (pipeline/map-value normalize compilation)) diff --git a/src/com/tailrecursion/blacktide/compiler/passes/collections.clj b/src/com/tailrecursion/blacktide/compiler/passes/collections.clj index d11a478..5029433 100644 --- a/src/com/tailrecursion/blacktide/compiler/passes/collections.clj +++ b/src/com/tailrecursion/blacktide/compiler/passes/collections.clj @@ -40,11 +40,11 @@ (np/defpasses (normalize-forms - {:from [l/Cases Exprs] :to [l/Collections Exprs] :processors {Expr normalize}} + {:from [l/Assigned Exprs] :to [l/Collections Exprs] :processors {Expr normalize}} [forms]) (normalize-node - {:from [l/Cases Node] :to [l/Collections Node] + {:from [l/Assigned Node] :to [l/Collections Node] :processors {Expr normalize Exprs normalize-forms Binding normalize-binding Raw clojure.core/identity Local clojure.core/identity RecurTarget clojure.core/identity CaseSpec clojure.core/identity}} [node] @@ -60,16 +60,16 @@ {:op :build :kind (:kind node) :items items :metadata metadata :unique? unique?}))) (normalize-binding - {:from [l/Cases Binding] :to [l/Collections Binding] + {:from [l/Assigned Binding] :to [l/Collections Binding] :processors {Expr normalize Local clojure.core/identity}} [binding]) (normalize - {:from [l/Cases Expr] :to [l/Collections Expr] :body true} + {:from [l/Assigned Expr] :to [l/Collections Expr] :body true} [expr] (assoc expr :node (normalize-node (:node expr))))) (np/defpass stage - {:from [l/Cases Compilation] :to [l/Collections Compilation] :body true} + {:from [l/Assigned Compilation] :to [l/Collections Compilation] :body true} [compilation] (pipeline/map-value normalize compilation)) diff --git a/src/com/tailrecursion/blacktide/compiler/passes/graph.clj b/src/com/tailrecursion/blacktide/compiler/passes/graph.clj index a9fe93b..c64e4f5 100644 --- a/src/com/tailrecursion/blacktide/compiler/passes/graph.clj +++ b/src/com/tailrecursion/blacktide/compiler/passes/graph.clj @@ -127,17 +127,18 @@ (if (= live next) live (recur next)))) {})) (np/defpass allocate - {:from [l/CFG Program] :to [l/Machine Program] :args [l/CFG-Flow] :body true} - [live program] - (assoc program :live live :slots (vec (sort (reduce set/union #{} (vals live)))))) + {:from [l/CFG Program] :to [l/Machine Program] :body true} + [program] + (let [live (liveness (collect-facts program))] + (assoc program :live live :slots (vec (sort (reduce set/union #{} (vals live))))))) -(np/defpass analyze {:from [l/CFG Program] :to [l/Machine Program] :body true} +(np/defpass validate {:from [l/CFG Program] :to [l/CFG Program] :body true} [program] (let [facts (collect-facts 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) - ;; Even unreachable native bodies must reach Clojure's compiler. Pruning - ;; them here suppresses Java call errors in source code. - (allocate (liveness facts) program))) + ;; Validate before feasibility removes edges. Retain dead native bodies for + ;; Clojure's compiler even though only reachable reads need initialization. + program)) diff --git a/src/com/tailrecursion/blacktide/compiler/passes/lower.clj b/src/com/tailrecursion/blacktide/compiler/passes/lower.clj index 4e4efc4..3cfbde7 100644 --- a/src/com/tailrecursion/blacktide/compiler/passes/lower.clj +++ b/src/com/tailrecursion/blacktide/compiler/passes/lower.clj @@ -33,12 +33,12 @@ (np/defpasses (lower-forms - {:from [l/Ordered Exprs] :to (t/HVec [l/Symbolic-Builder (t/Vec l/Symbolic-Atom)]) + {:from [l/Ordered Exprs] :to (t/HVec [l/Symbolic-Builder l/Symbolic-Atom]) :args [l/Symbolic-Builder] :body true} [builder forms] - (reduce (fn [^{::t/- (t/HVec [l/Symbolic-Builder (t/Vec l/Symbolic-Atom)])} acc ^{::t/- l/Ordered-Expr} expr] - (let [[builder out] acc [builder value] (lower builder expr)] [builder (conj out value)])) - [builder []] forms)) + (reduce (fn [^{::t/- (t/HVec [l/Symbolic-Builder l/Symbolic-Atom])} acc ^{::t/- l/Ordered-Expr} expr] + (lower (first acc) expr)) + [builder {:op :literal :value nil}] forms)) (lower-bindings {:from [l/Ordered Bindings] :to [l/Symbolic Builder] :args [l/Symbolic-Builder] :body true} @@ -54,14 +54,15 @@ [builder expr node] :literal [builder {:op :literal :value (:value node)}] :local (let [local (:local node)] - (evaluate builder (if (:external? local) {:op :external :name (:id local) :jvm (:jvm local)} - {:op :value :value {:op :local :id (:id local)}}))) + ;; Ordered bindings already snapshot operands before later writes. + (if (:external? local) (evaluate builder {:op :external :name (:id local) :jvm (:jvm local)}) + [builder {:op :local :id (:id local)}])) :global (evaluate builder {:op :global :name (:name node)}) :var (evaluate builder {:op :var :name (:name node)}) :native (evaluate builder node) :dispatch (evaluate builder {:op :dispatch :spec (:spec node) :value {:value {:op :local :id (:id (:value node))} :jvm (:jvm (:value node))}}) - :select + :case (let [[builder test] (lower builder (:selector node)) [builder join] (fresh-block builder) [supply result] (source/fresh "case_result" (:supply builder)) @@ -123,8 +124,7 @@ :goto (let [builder (seal builder {:op :transfer :name (:name node) :site (:site expr)}) [builder next] (fresh-block builder)] [(start builder next) {:op :literal :value nil}]) - :do (let [[builder values] (lower-forms builder (:forms node))] - [builder (or (peek values) {:op :literal :value nil})]) + :do (lower-forms builder (:forms node)) :let (lower (lower-bindings builder (:bindings node)) (:body node))) (lower diff --git a/src/com/tailrecursion/blacktide/compiler/passes/order.clj b/src/com/tailrecursion/blacktide/compiler/passes/order.clj index 0ffe501..ac58bc8 100644 --- a/src/com/tailrecursion/blacktide/compiler/passes/order.clj +++ b/src/com/tailrecursion/blacktide/compiler/passes/order.clj @@ -54,9 +54,9 @@ :label [supply (assoc expr :node node)] :goto [supply (assoc expr :node node)] :native [supply (assoc expr :node node)] - :select (let [[supply selector] (normalize supply (:selector node)) - [supply arms] (normalize-forms supply (:arms node))] - [supply (assoc expr :node {:op :select :selector selector :arms arms})]) + :case (let [[supply selector] (normalize supply (:selector node)) + [supply arms] (normalize-forms supply (:arms node))] + [supply (assoc expr :node {:op :case :selector selector :arms arms})]) :dispatch (let [[supply value] (normalize supply (:value node)) [supply binding local] (save supply value)] [supply (assoc expr :node {:op :let :bindings [binding] diff --git a/src/com/tailrecursion/blacktide/compiler/passes/results.clj b/src/com/tailrecursion/blacktide/compiler/passes/results.clj deleted file mode 100644 index 87ae959..0000000 --- a/src/com/tailrecursion/blacktide/compiler/passes/results.clj +++ /dev/null @@ -1,22 +0,0 @@ -(ns ^:typed.clojure com.tailrecursion.blacktide.compiler.passes.results - "Place the public Object boundary at exits, not around the whole region. - This leaves tail loops in tail position; Clojure otherwise wraps an expression - loop in a function. A join's result belongs to its enclosing computation." - (:require [com.tailrecursion.nanopass :as np] - [com.tailrecursion.blacktide.compiler.languages :as l] - [typed.clojure :as-alias t])) - -(np/defpass expression {:from [l/Compact Expr] :to [l/Sealed Expr] :args [t/Bool]} - [public? node] - :bind (assoc node :body (expression public? (:body node))) - :effect (assoc node :body (expression public? (:body node))) - :join (assoc node :value (expression false (:value node)) :body (expression public? (:body node))) - :branch (assoc node :yes (expression public? (:yes node)) :no (expression public? (:no node))) - :switch (assoc node :arms (mapv #(expression public? %) (:arms node))) - :loop (assoc node :body (expression public? (:body node))) - :recur node - :return (if public? (assoc node :op :result) node) - :throw (if public? (assoc node :op :raise) node)) - -(np/defpass program {:from [l/Compact Program] :to [l/Sealed Program] :body true} - [program] (assoc program :body (expression true (:body program)))) diff --git a/src/com/tailrecursion/blacktide/compiler/passes/source_values.clj b/src/com/tailrecursion/blacktide/compiler/passes/source_values.clj deleted file mode 100644 index 77fa5ed..0000000 --- a/src/com/tailrecursion/blacktide/compiler/passes/source_values.clj +++ /dev/null @@ -1,44 +0,0 @@ -(ns ^:typed.clojure com.tailrecursion.blacktide.compiler.passes.source-values - "Restore primitive source-local reads before compiler temporaries exist. - Clojure boxes each Object use of a primitive local independently; a machine - slot must not turn those reads into aliases of one box. Native trees already - preserve this behavior, and mutable locals have reference semantics." - (:require [com.tailrecursion.nanopass :as np] - [com.tailrecursion.nanopass.pipeline :as pipeline] - [com.tailrecursion.blacktide.compiler.languages :as l] - [typed.clojure :as-alias t])) - -(np/defpasses - (node - {:from [l/Classified Node] :to [l/Classified Node] - :processors {Expr expression Exprs forms Binding binding-form Assignments pairs - Local clojure.core/identity Raw clojure.core/identity - CollectionKind clojure.core/identity RecurTarget clojure.core/identity CaseSpec clojure.core/identity}} - [node] - :native node) - - (binding-form {:from [l/Classified Binding] :to [l/Classified Binding] - :processors {Expr expression Local clojure.core/identity}} [binding]) - - (pair {:from [l/Classified Assignment] :to [l/Classified Assignment] - :processors {Expr expression Local clojure.core/identity}} [assignment]) - - (pairs {:from [l/Classified Assignments] :to [l/Classified Assignments] - :processors {Assignment pair}} [assignments]) - - (forms {:from [l/Classified Exprs] :to [l/Classified Exprs] :processors {Expr expression}} [exprs]) - - (expression {:from [l/Classified Expr] :to [l/Classified Expr] :body true} - [expr] - (let [expr (assoc expr :node (node (:node expr))) - type (:type (:jvm expr))] - (if (and (= :local (:op (:node expr))) (:primitive? (:jvm expr)) - (class? type) (.isPrimitive ^Class type) (not= Void/TYPE type)) - (assoc expr :node {:op :host :operation {:op :static :class clojure.lang.RT - :member (symbol (str (.getName ^Class type) "Cast")) :tags [type]} - :args [expr]}) expr)))) - -(np/defpass stage - {:from [l/Classified Compilation] :to [l/Classified Compilation] :body true} - [compilation] - (pipeline/map-value expression compilation)) diff --git a/src/com/tailrecursion/blacktide/compiler/passes/storage.clj b/src/com/tailrecursion/blacktide/compiler/passes/storage.clj index 9f12626..a77345a 100644 --- a/src/com/tailrecursion/blacktide/compiler/passes/storage.clj +++ b/src/com/tailrecursion/blacktide/compiler/passes/storage.clj @@ -77,7 +77,7 @@ (np/defpass select-storage {:from [l/Joined Expr] :to [l/Represented Program] :args [l/Analysis-Program] :body true} [analysis expr] - ;; The results pass preserves the public Object boundary at every exit. + ;; Emission preserves the public Object boundary at every exit. (let [reboxable (origins/reboxable-values analysis) slots (loop-slots expr) initial (reduce-kv diff --git a/src/com/tailrecursion/blacktide/compiler/passes/structured_emit.clj b/src/com/tailrecursion/blacktide/compiler/passes/structured_emit.clj index a403479..723f7ce 100644 --- a/src/com/tailrecursion/blacktide/compiler/passes/structured_emit.clj +++ b/src/com/tailrecursion/blacktide/compiler/passes/structured_emit.clj @@ -1,6 +1,7 @@ (ns ^:typed.clojure com.tailrecursion.blacktide.compiler.passes.structured-emit "Emit lexical control with proven storage classes. Consumer source types stay - distinct from storage; Java argument conversions remain explicit evaluations." + distinct from storage; Java argument conversions remain explicit evaluations. + Public exits carry an Object boundary without taking loops out of tail position." (:require [com.tailrecursion.nanopass :as np] [com.tailrecursion.blacktide.compiler.languages :as l] [com.tailrecursion.blacktide.compiler.passes.compact :as compact] @@ -75,36 +76,35 @@ (binding-form types (:target op) (rhs-type types (:value op)) (rhs-form types (:value op)))) (np/defpasses - (let-form {:from [l/Sealed Expr] :to [l/Machine Code] :args [l/Compact-Types] :body true} - [types node] - ((fn ^{::t/- [(t/Vec t/Any) l/Sealed-Expr :-> l/Machine-Code]} bindings [pairs node] + (let-form {:from [l/Compact Expr] :to [l/Machine Code] :args [l/Compact-Types t/Bool] :body true} + [types public? node] + ((fn ^{::t/- [(t/Vec t/Any) l/Compact-Expr :-> l/Machine-Code]} bindings [pairs node] (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 (:value node)))) (:body node)) - (list 'let* pairs (expression types node)))) [] node)) + (binding-form types (:target node) nil (expression types false (:value node)))) (:body node)) + (list 'let* pairs (expression types public? node)))) [] node)) - (expression {:from [l/Sealed Expr] :to [l/Machine Code] :args [l/Compact-Types]} - [types node] - :bind (let-form types node) + (expression {:from [l/Compact Expr] :to [l/Machine Code] :args [l/Compact-Types t/Bool]} + [types public? node] + :bind (let-form types public? node) :effect (let [binding (:binding node) rhs (:value binding) type (get types (:target binding)) form (rhs-form types rhs)] (list 'do (if (and type (not= type (rhs-type types rhs))) (primitive-form type form) form) - (expression types (:body node)))) - :join (let-form types node) - :branch (list 'if (atom-form types (:test node)) (expression types (:yes node)) (expression types (:no node))) - :switch (cases/arms-form (mapv #(expression types %) (:arms node)) (atom-form types (:test node))) + (expression types public? (:body node)))) + :join (let-form types public? node) + :branch (list 'if (atom-form types (:test node)) (expression types public? (:yes node)) (expression types public? (:no node))) + :switch (cases/arms-form (mapv #(expression types public? %) (:arms node)) (atom-form types (:test node))) :loop (list 'loop* (into [] (mapcat (fn [binding] [(:target binding) (binding-form types (:target binding) (compact/atom-type types (:value binding)) (atom-form types (:value binding)))])) (:bindings node)) - (expression types (:body 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 (and (= :inline (:op value)) (= :native (:op (:value value)))) + (if (or public? (and (= :inline (:op value)) (= :native (:op (:value value))))) (host/box-form form) form)) - :result (host/box-form (atom-form types (:value node))) - :raise (host/box-form (list 'throw (atom-form types (:value node)))) - :throw (list 'throw (atom-form types (:value node))))) + :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_fixture.clj b/test/com/tailrecursion/blacktide/backend_fixture.clj new file mode 100644 index 0000000..d39eee3 --- /dev/null +++ b/test/com/tailrecursion/blacktide/backend_fixture.clj @@ -0,0 +1,41 @@ +(ns com.tailrecursion.blacktide.backend-fixture + "Compile source and machine forms in a stable namespace; observe backend stages." + (:require [com.tailrecursion.blacktide :refer [loophole label goto setq psetq]] + [com.tailrecursion.blacktide.compiler :as compiler] + [com.tailrecursion.blacktide.compiler.passes.graph :as graph] + [com.tailrecursion.blacktide.compiler.passes.emit :as emit] + [com.tailrecursion.blacktide.compiler.passes.numeric :as numeric])) + +(defn with-backend [mode f] + (with-redefs [numeric/program (if (= mode :generic) identity numeric/program) + compiler/compile-program (if (= mode :dispatcher) + (comp emit/program-form graph/allocate) + compiler/compile-program)] + (f))) + +(defn compile-program [form mode] + (binding [*ns* (the-ns 'com.tailrecursion.blacktide.backend-fixture)] + (with-backend mode #(eval (list 'fn '[events] form))))) + +(defn capture [pass form] + (let [result (atom nil) original @pass] + (with-redefs-fn {pass (fn [& args] (let [out (apply original args)] (reset! result out) out))} + #(compile-program form :default)) + @result)) + +(defn execution [form mode] + (let [f (compile-program form mode) events (atom [])] + (try {:value (f events) :trace @events} + (catch Throwable error {:throw (class error) :trace @events})))) + +(defn literal [value] {:op :literal :value value}) +(defn local [id] {:op :local :id id}) +(defn assign [id rhs] {:target id :value rhs}) +(defn put-value [id value] (assign id {:op :value :value (literal value)})) +(defn call [id f & args] (assign id {:op :invoke :function (local f) :args (vec args)})) +(defn block [ops term] {:ops (vec ops) :term term}) +(defn checked-machine [program] (graph/allocate (graph/validate program))) +(defn run-machine [machine] + (binding [*ns* (the-ns 'com.tailrecursion.blacktide.backend-fixture)] + (eval (emit/program-form machine)))) + diff --git a/test/com/tailrecursion/blacktide/backend_test.clj b/test/com/tailrecursion/blacktide/backend_test.clj index 99b12a5..0afcb6a 100644 --- a/test/com/tailrecursion/blacktide/backend_test.clj +++ b/test/com/tailrecursion/blacktide/backend_test.clj @@ -4,52 +4,15 @@ [clojure.test.check :as tc] [clojure.test.check.generators :as gen] [clojure.test.check.properties :as prop] - [com.tailrecursion.blacktide :refer [loophole label goto setq psetq]] - [com.tailrecursion.blacktide.compiler :as compiler] - [com.tailrecursion.blacktide.compiler.passes.emit :as emit] [com.tailrecursion.blacktide.compiler.passes.structure :as structure] [com.tailrecursion.blacktide.compiler.passes.storage :as storage] [com.tailrecursion.blacktide.compiler.passes.compact :as compact] [com.tailrecursion.blacktide.compiler.passes.value-facts :as facts] - [com.tailrecursion.blacktide.compiler.passes.numeric :as numeric] [com.tailrecursion.blacktide.compiler.passes.box-origins :as origins] - [com.tailrecursion.blacktide.compiler.passes.graph :as graph] [com.tailrecursion.blacktide.compiler.jvm :as jvm] [com.tailrecursion.blacktide.compiler.passes.prepare :as prepare] [com.tailrecursion.blacktide.compiler.passes.lower :as lower] - [com.tailrecursion.blacktide.machine-test :as m])) - -(defn compile-program [form mode] - (binding [*ns* (the-ns 'com.tailrecursion.blacktide.backend-test)] - (with-redefs [numeric/program (if (= mode :generic) identity numeric/program) - compiler/compile-program (if (= mode :dispatcher) - emit/program-form - compiler/compile-program)] - (eval (list 'fn '[events] form))))) - -(defn selection [form] - (let [selected (atom nil) recover structure/recover] - (with-redefs [structure/recover (fn [analysis] (let [out (recover analysis)] (reset! selected out) out))] - (compile-program form :default)) - @selected)) - -(defn stored [form] - (let [selected (atom nil) choose storage/select-storage] - (with-redefs [storage/select-storage (fn [analysis expr] - (let [out (choose analysis expr)] (reset! selected out) out))] - (compile-program form :default)) - @selected)) - -(defn execution [form mode] - (let [f (compile-program form mode) events (atom [])] - (try {:value (f events) :trace @events} - (catch Throwable error {:throw (class error) :trace @events})))) - -(defn compacted [form] - (let [selected (atom nil) simplify compact/program] - (with-redefs [compact/program (fn [program] (let [out (simplify program)] (reset! selected out) out))] - (compile-program form :default)) - @selected)) + [com.tailrecursion.blacktide.backend-fixture :as m :refer [compile-program execution capture]])) (defmacro local-class [name] (let [^clojure.lang.Compiler$LocalBinding binding (get &env name)] @@ -90,7 +53,7 @@ (deftest result-type-boundary (doseq [body '[1 2.5 nil false "text" (loop [] 1) (do (goto end) :dead (label end) 42)] mode [:default :dispatcher]] - (let [form (list 'let ['result (list 'loophole [] body)] '(local-class result))] + (let [form (list 'let ['result (list 'loophole [] body)] '(com.tailrecursion.blacktide.backend-test/local-class result))] (is (= Object ((compile-program form mode) nil)) (pr-str [body mode]))))) (deftest object-arguments-need-facts-and-snapshots-but-no-cast @@ -181,7 +144,7 @@ 'y [{:op :value :value (m/local 'x)} {:op :value :value (m/literal 2.0)}]})))) (deftest dead-blocks-are-retained-but-not-type-proofs - (let [machine (graph/analyze {:entry 0 :blocks {0 (m/block [(m/put-value 'x 1)] {:op :return :value (m/local 'x)}) + (let [machine (m/checked-machine {:entry 0 :blocks {0 (m/block [(m/put-value 'x 1)] {:op :return :value (m/local 'x)}) 1 (m/block [(m/put-value 'x nil)] {:op :return :value (m/local 'x)})}}) analysis (facts/analyze machine)] (is (= machine (:machine analysis))) @@ -195,7 +158,7 @@ :else (unchecked-inc total)) i (unchecked-inc i))) (long total)) - program (stored form) + program (capture #'storage/select-storage form) slots (storage/loop-slots (:body program))] (is (= 2 (count slots))) (is (= #{Long/TYPE} (set (vals (select-keys (:types program) slots))))) @@ -218,18 +181,18 @@ (if (< i 6) (do (psetq a b b (+ a b)) (setq i (inc i)) (goto again)) [a b]))] - (is (= :structured (:op (selection form)))) + (is (= :structured (:op (capture #'structure/recover form)))) (doseq [mode [:default :dispatcher]] (let [events (atom [])] (is (= [8 13] ((compile-program form mode) events))) (is (= [[0 0 1] [1 1 1] [2 1 2] [3 2 3] [4 3 5] [5 5 8] [6 8 13]] @events))))) - (is (= :cycles (:reason (selection '(loophole [i 0 j 0] + (is (= :cycles (:reason (capture #'structure/recover '(loophole [i 0 j 0] (while (< i 2) (setq i (inc i))) (while (< j 3) (setq j (inc j))) [i j]))))) (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])] - (is (= :budget (:reason (selection form)))) + (is (= :budget (:reason (capture #'structure/recover form)))) (is (= [40 40] ((compile-program form :default) (atom [])))))) (deftest structured-code-preserves-native-validation @@ -242,7 +205,7 @@ (label again) (setq i (inc i)) (when (< i 2) (goto again)) (goto done) (swap! events conj :dead) (label done)) events (atom [])] - (is (= :validation (:reason (selection form)))) + (is (= :validation (:reason (capture #'structure/recover form)))) (is (nil? ((compile-program form :default) events))) (is (empty? @events)))) @@ -250,7 +213,7 @@ (let [step '(if (odd? i) (setq hits (inc hits)) (setq hits (+ hits 2))) form (list 'loophole '[i 0 hits 0] (list* 'while '(< i 3) (concat (repeat 8 step) ['(setq i (inc i))])) 'hits) - decision (selection form)] + decision (capture #'structure/recover form)] (is (= :structured (:op decision))) (is (= 9 (count (filter #(and (map? %) (= :branch (:op %))) (tree-seq coll? seq (:body decision)))))) (doseq [mode [:default :dispatcher]] (is (= 40 ((compile-program form mode) (atom [])))))) @@ -258,7 +221,7 @@ (list 'while '(< i 96) (list 'setq 'answer (list* 'case 'i (concat (mapcat #(vector % %) (range 96)) [nil]))) '(setq i (inc i))) 'answer)] - (is (= :structured (:op (selection form)))) + (is (= :structured (:op (capture #'structure/recover form)))) (doseq [mode [:default :dispatcher]] (is (= 95 ((compile-program form mode) (atom [])))))) (doseq [mode [:default :dispatcher]] (let [events (atom [])] @@ -291,7 +254,7 @@ (setq i (inc i)))) mode))) (let [f (compile-program '(loophole [^long i 0] (while (< i 1) - (primitive-target (do (swap! events conj :argument) 5)) + (com.tailrecursion.blacktide.backend-test/primitive-target (do (swap! events conj :argument) 5)) (setq i (inc i)))) mode) events (atom [])] (with-redefs [primitive-target (fn [x] x)] @@ -301,8 +264,10 @@ (is (= {:value 6 :trace []} (execution '(loophole [^long i 0 result nil] (while (< i 1) - (setq result (primitive-target - (do (alter-var-root #'primitive-target (constantly primitive-replacement)) 5)) + (setq result (com.tailrecursion.blacktide.backend-test/primitive-target + (do (alter-var-root #'com.tailrecursion.blacktide.backend-test/primitive-target + (constantly com.tailrecursion.blacktide.backend-test/primitive-replacement)) + 5)) i (inc i))) result) mode)))))) (deftest object-conversions-preserve-references-dispatch-and-order @@ -338,7 +303,7 @@ (deftest primitive-cast-cleanup-keeps-observable-boxes (let [form '(loophole [x (long events)] (< (^{:param-tags [long]} clojure.lang.RT/longCast x) 0)) - program (compacted form)] + program (capture #'compact/program form)] (is (not-any? #(and (map? %) (= :host (:op %)) (= clojure.lang.RT (:class (:operation %))) (= 'longCast (:member (:operation %))) diff --git a/test/com/tailrecursion/blacktide/check.clj b/test/com/tailrecursion/blacktide/check.clj index d343df1..6c6553c 100644 --- a/test/com/tailrecursion/blacktide/check.clj +++ b/test/com/tailrecursion/blacktide/check.clj @@ -59,16 +59,18 @@ (probes/accepts? 'com.tailrecursion.blacktide.compiler.languages/Ordered-Node (assoc prepared :args [{:op :literal :value nil}]) false))) -(deftest case-selection-boundary +(deftest case-control-flow-boundary (let [expr {:site {:form nil :file nil :line nil :column nil} :jvm {:hint nil :var-meta {} :type Long/TYPE :primitive? true :hint-error nil} :node {:op :literal :value 0}} node {:op :case :selector expr :arms [expr]}] (probes/accepts? 'com.tailrecursion.blacktide.compiler.languages/Assigned-Node node true) - (probes/accepts? 'com.tailrecursion.blacktide.compiler.languages/Cases-Node node false) - (probes/accepts? 'com.tailrecursion.blacktide.compiler.languages/Cases-Node (assoc node :op :select) true) + (probes/accepts? 'com.tailrecursion.blacktide.compiler.languages/Ordered-Node node true) + (probes/accepts? 'com.tailrecursion.blacktide.compiler.languages/CFG-Term node false) (probes/accepts? 'com.tailrecursion.blacktide.compiler.languages/CFG-Term - {:op :switch :test {:op :literal :value 0} :targets [1 2]} true))) + {:op :switch :test {:op :literal :value 0} :targets [1 2]} true) + (probes/accepts? 'com.tailrecursion.blacktide.compiler.languages/Ordered-Node + {:op :switch :test {:op :literal :value 0} :targets [1 2]} false))) (deftest numeric-representation-boundary (let [call {:op :numeric :operation {:op :static :class clojure.lang.Numbers :member 'add :tags nil} :args [] :parameters [] :return Number} diff --git a/test/com/tailrecursion/blacktide/collections_test.clj b/test/com/tailrecursion/blacktide/collections_test.clj index 95eb0c0..46bca6c 100644 --- a/test/com/tailrecursion/blacktide/collections_test.clj +++ b/test/com/tailrecursion/blacktide/collections_test.clj @@ -5,8 +5,7 @@ [clojure.test.check.generators :as gen] [clojure.test.check.properties :as prop] [com.tailrecursion.blacktide :refer [loophole]] - [com.tailrecursion.blacktide.compiler :as compiler] - [com.tailrecursion.blacktide.compiler.passes.emit :as emit])) + [com.tailrecursion.blacktide.backend-fixture :as backend])) (defn record! [events tag value] (swap! events conj tag) value) (defmacro key-a [] :a) @@ -88,18 +87,15 @@ (deftest vector-construction-boundaries (doseq [mode [:default :dispatcher]] (binding [*ns* (the-ns 'com.tailrecursion.blacktide.collections-test)] - (with-redefs [compiler/compile-program (if (= mode :dispatcher) - emit/program-form - compiler/compile-program)] + (backend/with-backend mode (fn [] (doseq [size [0 1 6 7 32 33 63] metadata [nil {} {:note :yes}]] (let [body (with-meta (mapv #(list 'record! 'events % %) (range size)) metadata) - wrap identity constant (with-meta (vec (range size)) metadata) - plain (eval (list 'fn [] (wrap constant))) - compiled (eval (list 'fn [] (list 'loophole [] (wrap constant)))) + plain (eval (list 'fn [] constant)) + compiled (eval (list 'fn [] (list 'loophole [] constant))) observation (fn [f] [(class (f)) (meta (f))])] - (is (= [(observe (wrap body)) (observation plain)] - [(observe (list 'loophole [] (wrap body))) (observation compiled)]) + (is (= [(observe body) (observation plain)] + [(observe (list 'loophole [] body)) (observation compiled)]) (pr-str [mode size metadata])))) (doseq [size [1 6 7 32 33] offset (distinct [0 (quot size 2) (dec size)])] @@ -112,11 +108,10 @@ (mapv class (second (first (observe (list 'loophole [] body))))))))) (doseq [size [1 6 7 33] value [1000 1.5 (Integer/valueOf 1000)]] (let [body (with-meta (assoc (vec (range size)) 0 value) {}) - wrap identity - plain (eval (list 'fn [] (wrap body))) - compiled (eval (list 'fn [] (list 'loophole [] (wrap body)))) + plain (eval (list 'fn [] body)) + compiled (eval (list 'fn [] (list 'loophole [] body))) observation (fn [f] [(class (first (f))) (first (f))])] - (is (= (observation plain) (observation compiled)) (pr-str [mode size value])))))))) + (is (= (observation plain) (observation compiled)) (pr-str [mode size value]))))))))) (def collection-form (gen/let [items (gen/vector (gen/tuple (gen/choose 0 7) (gen/elements [:literal :event :let])) 0 24) diff --git a/test/com/tailrecursion/blacktide/generated_test.clj b/test/com/tailrecursion/blacktide/generated_test.clj index 39a0125..7b4da6f 100644 --- a/test/com/tailrecursion/blacktide/generated_test.clj +++ b/test/com/tailrecursion/blacktide/generated_test.clj @@ -7,7 +7,7 @@ [clojure.test.check.properties :as prop] [clojure.walk :as walk] [com.tailrecursion.blacktide :refer [loophole label goto setq psetq]] - [com.tailrecursion.blacktide.backend-test :as backend] + [com.tailrecursion.blacktide.backend-fixture :as backend] [com.tailrecursion.blacktide.compiler.passes.structure :as structure] [com.tailrecursion.blacktide.compiler.passes.storage :as storage] [com.tailrecursion.blacktide.compiler.passes.numeric :as numeric] diff --git a/test/com/tailrecursion/blacktide/graph_test.clj b/test/com/tailrecursion/blacktide/graph_test.clj index 653c6c0..382e332 100644 --- a/test/com/tailrecursion/blacktide/graph_test.clj +++ b/test/com/tailrecursion/blacktide/graph_test.clj @@ -5,12 +5,12 @@ [clojure.test.check.generators :as gen] [clojure.test.check.properties :as prop] [com.tailrecursion.blacktide.compiler.passes.graph :as graph] - [com.tailrecursion.blacktide.machine-test :as m])) + [com.tailrecursion.blacktide.backend-fixture :as m])) (defn jump [target] {:op :jump :target target}) (defn result [value] {:op :return :value value}) (defn failure [program] - (try (graph/analyze program) nil (catch clojure.lang.ExceptionInfo e (ex-data e)))) + (try (graph/validate program) nil (catch clojure.lang.ExceptionInfo e (ex-data e)))) (deftest validate-destinations-before-reachability (is (= {:kind :invalid-graph :block 0} (failure {:entry 0 :blocks {}}))) @@ -39,7 +39,7 @@ (m/block [(m/assign 'y {:op :value :value (m/local 'x)}) (m/put-value 'x 2)] (result (m/local 'y)))))) (let [data {:op :local :id 'ghost} - machine (graph/analyze {:entry 0 :blocks {0 (m/block [(m/put-value 'x data)] + machine (m/checked-machine {:entry 0 :blocks {0 (m/block [(m/put-value 'x data)] (result (m/local 'x))) 9 (m/block [] (result (m/local 'ghost)))}})] (is (= #{0 9} (set (keys (:blocks machine))))) @@ -54,12 +54,12 @@ 2 (m/block [(m/put-value 'x :middle)] (jump 4)) 3 (m/block [(m/put-value 'x :last)] (jump 4)) 4 (m/block [] (result (m/local 'x)))}}] - (is (= (nth [:first :middle :last] index) (m/run-machine (graph/analyze program)))) + (is (= (nth [:first :middle :last] index) (m/run-machine (m/checked-machine program)))) (is (= :uninitialized-slot (:kind (failure (assoc-in program [:blocks 2 :ops] [])))))))) (deftest joins-and-live-value-survival (doseq [test [true false]] - (let [machine (graph/analyze + (let [machine (m/checked-machine {:entry 0 :blocks {0 (m/block [(m/put-value 'x 10) (m/assign 'saved {:op :value :value (m/local 'x)})] {:op :branch :test (m/literal test) :yes 1 :no 2}) @@ -107,4 +107,4 @@ (every? true? (for [variant [program (rename-blocks program) (assoc-in program [:blocks 99] (m/block [] (result (m/local 'uninitialized))))]] - (= expected (m/run-machine (graph/analyze variant)))))))) + (= expected (m/run-machine (m/checked-machine variant)))))))) diff --git a/test/com/tailrecursion/blacktide/invocation_test.clj b/test/com/tailrecursion/blacktide/invocation_test.clj index 968c9e1..3e72e58 100644 --- a/test/com/tailrecursion/blacktide/invocation_test.clj +++ b/test/com/tailrecursion/blacktide/invocation_test.clj @@ -3,7 +3,7 @@ method Var. Compare values, failures and evaluation traces with Clojure." (:require [clojure.test :refer [deftest is]] [clojure.core.protocols :as p] - [com.tailrecursion.blacktide.backend-test :as backend])) + [com.tailrecursion.blacktide.backend-fixture :as backend])) (deftype DirectReduction [events] p/CollReduce diff --git a/test/com/tailrecursion/blacktide/lookup_test.clj b/test/com/tailrecursion/blacktide/lookup_test.clj index f936066..875dba5 100644 --- a/test/com/tailrecursion/blacktide/lookup_test.clj +++ b/test/com/tailrecursion/blacktide/lookup_test.clj @@ -2,7 +2,7 @@ "Keyword call syntax determines cached IKeywordLookup versus ordinary ILookup dispatch. Native emission must preserve call sites, effects and cache faults." (:require [clojure.test :refer [deftest is]] - [com.tailrecursion.blacktide.backend-test :as backend])) + [com.tailrecursion.blacktide.backend-fixture :as backend])) (deftype ObservedLookup [events entries] clojure.lang.ILookup diff --git a/test/com/tailrecursion/blacktide/machine_test.clj b/test/com/tailrecursion/blacktide/machine_test.clj index 9e515aa..cedc3bd 100644 --- a/test/com/tailrecursion/blacktide/machine_test.clj +++ b/test/com/tailrecursion/blacktide/machine_test.clj @@ -3,17 +3,8 @@ (:require [clojure.test :refer [deftest is]] [com.tailrecursion.blacktide.compiler.jvm :as jvm] [com.tailrecursion.blacktide.compiler.passes.host-emit :as host] - [com.tailrecursion.blacktide.compiler.passes.emit :as emit])) - -(defn literal [value] {:op :literal :value value}) -(defn local [id] {:op :local :id id}) -(defn assign [id rhs] {:target id :value rhs}) -(defn put-value [id value] (assign id {:op :value :value (literal value)})) -(defn call [id f & args] (assign id {:op :invoke :function (local f) :args (vec args)})) -(defn block [ops term] {:ops (vec ops) :term term}) -(defn run-machine [machine] - (binding [*ns* (the-ns 'com.tailrecursion.blacktide.machine-test)] - (eval (emit/program-form machine)))) + [com.tailrecursion.blacktide.compiler.passes.emit :as emit] + [com.tailrecursion.blacktide.backend-fixture :refer [literal local assign put-value call block run-machine]])) (deftest emission-is-complete-before-returning (let [calls (atom []) original host/global-form diff --git a/test/com/tailrecursion/blacktide/native_sites_test.clj b/test/com/tailrecursion/blacktide/native_sites_test.clj index 94d2526..a028312 100644 --- a/test/com/tailrecursion/blacktide/native_sites_test.clj +++ b/test/com/tailrecursion/blacktide/native_sites_test.clj @@ -5,7 +5,8 @@ [clojure.test.check.clojure-test :refer [defspec]] [clojure.test.check.generators :as gen] [clojure.test.check.properties :as prop] - [com.tailrecursion.blacktide.backend-test :as backend] + [com.tailrecursion.blacktide.compiler.passes.structure :as structure] + [com.tailrecursion.blacktide.backend-fixture :as backend] [com.tailrecursion.blacktide :refer [loophole setq label goto]] [com.tailrecursion.blacktide.invocation-test] [com.tailrecursion.blacktide.lookup-test :as lookup])) @@ -97,5 +98,5 @@ [(mapv (fn [[picked f]] [picked (f "abc")]) values) (identity-pattern (mapv (comp class second) values)) @events])) expected (observe body :default)] - (and (= :structured (:op (backend/selection (source form)))) + (and (= :structured (:op (backend/capture #'structure/recover (source form)))) (every? #(= expected (observe form %)) [:default :dispatcher]))))) diff --git a/test/com/tailrecursion/blacktide/numeric_test.clj b/test/com/tailrecursion/blacktide/numeric_test.clj index 1b5c9bb..659a683 100644 --- a/test/com/tailrecursion/blacktide/numeric_test.clj +++ b/test/com/tailrecursion/blacktide/numeric_test.clj @@ -5,7 +5,8 @@ [clojure.test.check :as tc] [clojure.test.check.generators :as gen] [clojure.test.check.properties :as prop] - [com.tailrecursion.blacktide.backend-test :as backend] + [com.tailrecursion.blacktide.backend-fixture :as backend] + [com.tailrecursion.blacktide.compiler.passes.compact :as compact] [com.tailrecursion.blacktide.compiler.passes.storage :as storage])) (def modes [:default :generic :dispatcher]) @@ -14,9 +15,9 @@ (let [form '(loophole [sum 0] (dotimes [i 10] (when (= i 5) (goto done)) (setq sum (+ sum i))) (label done) sum) - program (backend/stored form) + program (backend/capture #'storage/select-storage form) slots (storage/loop-slots (:body program)) - code (backend/compacted form) + code (backend/capture #'compact/program form) adds (filter #(and (map? %) (= :host (:op %)) (= 'add (:member (:operation %)))) (tree-seq coll? seq (:body code)))] (is (= 2 (count slots))) @@ -68,6 +69,10 @@ (defn boxed [form] (list (with-meta 'clojure.lang.RT/box {:param-tags [Object]}) form)) +(defn compile-reference [bindings expression] + (backend/compile-program + (list 'let (vec (mapcat (fn [[id value]] [id (boxed value)]) (partition 2 bindings))) expression) :default)) + (deftest numeric-surface ;; Compile each shape once, then exercise boundaries. The ordinary Clojure ;; oracle explicitly boxes its locals, matching mutable source-local reads. @@ -78,9 +83,7 @@ (map #(list % 'x 'y 'x) '[+ - * / +' -' *' min max < <= > >= = ==])) :let [bindings ['x (list left '(nth events 0)) 'y (list right '(nth events 1))] form (list 'loophole bindings expression) - reference (backend/compile-program - (list 'let (vec (mapcat (fn [[id value]] [id (boxed value)]) (partition 2 bindings))) - expression) :default) + reference (compile-reference bindings expression) functions (mapv #(backend/compile-program form %) modes) inputs (for [x (boundaries left) y (if (= 2 (count expression)) [(first (boundaries right))] (boundaries right))] [x y]) @@ -193,7 +196,8 @@ :let [bindings ['x (list kind '(first events)) 'y (list kind '(second events))] form (list 'loophole bindings expression) functions (binding [*unchecked-math* unchecked] - (mapv #(backend/compile-program form %) modes))]] + (into [(compile-reference bindings expression)] + (map #(backend/compile-program form %)) modes))]] (doseq [input [[-0.0 0.0] [1 2] [Long/MAX_VALUE -1] [Double/MAX_VALUE 2] [Double/NaN 0] [nil nil] [\a \b] [false true]]] (is (apply = (map #(outcome % input) functions)) (pr-str [form unchecked input]))))) @@ -204,7 +208,7 @@ (while (< i (alength xs)) (setq sum (+ sum (aget xs i)) i (inc i))) (double sum))) - program (backend/stored form) + program (backend/capture #'storage/select-storage form) slots (storage/loop-slots (:body program))] (is (= #{Long/TYPE Double/TYPE} (set (vals (select-keys (:types program) slots))))) (doseq [mode modes xs [[] [1.0] [1.0 2.0 3.0] [Double/NaN] [-0.0]]] @@ -212,7 +216,7 @@ (is (= (outcome reference xs) (outcome (backend/compile-program form mode) (double-array xs)))))))) (deftest primitive-java-widening-stays-unboxed - (let [program (backend/compacted '(let [n (long (first events))] (loophole [] (Math/sin n)))) + (let [program (backend/capture #'compact/program '(let [n (long (first events))] (loophole [] (Math/sin n)))) casts (filter #(and (map? %) (= :host (:op %)) (= 'doubleCast (:member (:operation %)))) (tree-seq coll? seq (:body program)))] (is (= 1 (count casts))) @@ -222,7 +226,7 @@ (deftest selected-origins-and-primitive-emission (doseq [form '[(loophole [x 0] (dotimes [i 10] (setq x (max x i))) x) (loophole [x (double 0)] (dotimes [i 10] (setq x (max x (double i)))) x)]] - (let [program (backend/stored form) + (let [program (backend/capture #'storage/select-storage form) slots (storage/loop-slots (:body program))] (is (every? (:types program) slots) (pr-str form)) (doseq [mode modes] (is (= 9.0 (double (:value (backend/execution form mode)))))))) diff --git a/test/com/tailrecursion/blacktide/source_loops_test.clj b/test/com/tailrecursion/blacktide/source_loops_test.clj index c5c64dc..61c941d 100644 --- a/test/com/tailrecursion/blacktide/source_loops_test.clj +++ b/test/com/tailrecursion/blacktide/source_loops_test.clj @@ -7,8 +7,7 @@ [clojure.test.check.properties :as prop] [clojure.walk :as walk] [com.tailrecursion.blacktide :refer [loophole]] - [com.tailrecursion.blacktide.compiler :as compiler] - [com.tailrecursion.blacktide.compiler.passes.emit :as emit] + [com.tailrecursion.blacktide.backend-fixture :as backend] [com.tailrecursion.blacktide.jvm-test :as jvm])) (defn root-error [e] (if-let [cause (ex-cause e)] (recur cause) e)) @@ -40,10 +39,7 @@ (defn compile-body [body mode] (try (binding [*ns* (the-ns 'com.tailrecursion.blacktide.source-loops-test)] - (with-redefs [compiler/compile-program (if (= mode :dispatcher) - emit/program-form - compiler/compile-program)] - (eval (list 'fn '[events input n] (enclose body mode))))) + (backend/with-backend mode #(eval (list 'fn '[events input n] (enclose body mode))))) (catch Throwable e {:compile (class (root-error e))}))) (defn outcome [f input n] (if (map? f) f diff --git a/test/com/tailrecursion/blacktide/source_values_test.clj b/test/com/tailrecursion/blacktide/source_values_test.clj index 9a46f1a..bbe7221 100644 --- a/test/com/tailrecursion/blacktide/source_values_test.clj +++ b/test/com/tailrecursion/blacktide/source_values_test.clj @@ -2,7 +2,7 @@ "Primitive source reads box at each Object use; mutable locations and saved Object references retain their identity across normalization and transfers." (:require [clojure.test :refer [deftest is]] - [com.tailrecursion.blacktide.backend-test :as backend])) + [com.tailrecursion.blacktide.backend-fixture :as backend])) (def initializers '[1000 1.5 (int 1000) (short 1000) (byte 4) (float 1.5) (char 256) (boolean true)