From 227c4764539f89200f9de4bc933d3b0fe8a13bc2 Mon Sep 17 00:00:00 2001 From: "Norman Nunley, Jr" Date: Wed, 22 Jul 2026 22:50:05 -0400 Subject: [PATCH] salvage(ir): def+name* IR-compile seam + block-junk agreement (extracted from #556 mis-snapshot) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Two unmerged IR/compiler features that a bad whole-working-copy snapshot swept into #556's 'self-heal submodule' commit (pxvytswo). Neither is in main; neither belongs in a submodule PR. Extracted here to preserve them for a proper PR home + review — NOT ready as-is: - compiler.go maybeIRCompileDefFnArg + pipeline.lg compile-def-fn-value: route top-level (def NAME (name* ... (fn ...))) grammar defs through the IR pipeline (the def+name* / grammar-def-closure AOT seam). - lower.lg :block-junk-seen: fall-through predecessors must AGREE on junk-below (disagreement aborts lowering) instead of take-the-max — fixes a stack underflow. Overlaps #579's lower.lg stack-discipline rework; needs re-review against it. TODO: decide home (grammar/yamlstar effort?), split into 2 PRs, review vs #579. --- pkg/compiler/compiler.go | 85 ++++++++++++++ pkg/ir/ir_bridge.lg | 11 ++ pkg/rt/core/ir/lower.lg | 180 +++++++++++++++++++++++++----- pkg/rt/core/ir/passes/pipeline.lg | 36 +++++- pkg/rt/generated.sums | 2 +- pkg/rt/ir_bridge_generated.go | 24 ++++ 6 files changed, 308 insertions(+), 30 deletions(-) diff --git a/pkg/compiler/compiler.go b/pkg/compiler/compiler.go index d692cfd1f..3b97775f1 100644 --- a/pkg/compiler/compiler.go +++ b/pkg/compiler/compiler.go @@ -1934,6 +1934,9 @@ func defCompiler(c *Context, form vm.Value) error { c.defName = "" return nil } + if rewritten := c.maybeIRCompileDefFnArg(sym.(vm.Symbol), val); rewritten != nil { + val = rewritten + } err := c.compileForm(val) if err != nil { return compileErrorAt("compiling def value", form).Wrap(err) @@ -1945,6 +1948,88 @@ func defCompiler(c *Context, form vm.Value) error { return nil } +// maybeIRCompileDefFnArg is the runtime seam for name*-wrapped fn defs: +// when *ir-compile* is on and a TOP-LEVEL `(def NAME (name* ... (fn ...) ...))` +// is being compiled, route the inner fn form through the Lisp IR pipeline +// (ir.passes.pipeline/compile-def-fn-value) and substitute the compiled Fn +// value as an embedded constant — the same def-value shape the defn macro +// produces via chunk->fn. The defn macro can't cover these: `def` is a +// special form, so grammar-style rule defs never reach the macro layer and +// their bodies otherwise always compile via the plain bytecode compiler. +// Returns the rewritten value form, or nil to compile the original +// (any failure falls back silently, mirroring the defn macro's hybrid path). +func (c *Context) maybeIRCompileDefFnArg(name vm.Symbol, val vm.Value) vm.Value { + // Top-level defs only: an inner fn compiled through the pipeline cannot + // capture enclosing locals. + if len(c.locals) != 0 { + return nil + } + icv, ok := c.CurrentNS().Lookup(vm.Symbol("clojure.core/*ir-compile*")).(*vm.Var) + if !ok || !vm.IsTruthy(icv.Deref()) { + return nil + } + lst, ok := val.(*vm.List) + if !ok { + return nil + } + headSym, ok := lst.First().(vm.Symbol) + if !ok { + return nil + } + _, headName, hasNS := headSym.NamespacedRaw() + if !hasNS { + headName = headSym + } + if headName != vm.Symbol("name*") { + return nil + } + elems, ok := lst.Unbox().([]vm.Value) + if !ok { + return nil + } + fnIdx := -1 + for i := 1; i < len(elems); i++ { + el, isList := elems[i].(*vm.List) + if !isList { + continue + } + h, isSym := el.First().(vm.Symbol) + if !isSym || (h != "fn" && h != "fn*") { + continue + } + if fnIdx != -1 { + return nil // more than one fn argument: ambiguous, leave alone + } + fnIdx = i + } + if fnIdx == -1 { + return nil + } + hv, ok := c.CurrentNS().Lookup(vm.Symbol("ir.passes.pipeline/compile-def-fn-value")).(*vm.Var) + if !ok { + return nil + } + hfn, ok := hv.Deref().(vm.Fn) + if !ok { + return nil + } + compiled, err := hfn.Invoke([]vm.Value{elems[fnIdx], c.CurrentNS(), name}) + if err != nil || compiled == vm.NIL { + return nil + } + newElems := make([]vm.Value, len(elems)) + copy(newElems, elems) + newElems[fnIdx] = compiled + rewritten, berr := vm.ListType.Box(newElems) + if berr != nil { + return nil + } + if info := vm.FormSource.Get(val); info != nil { + vm.FormSource.Set(rewritten, *info) + } + return rewritten +} + func setBangCompiler(c *Context, form vm.Value) error { tc := c.tailPosition c.tailPosition = false diff --git a/pkg/ir/ir_bridge.lg b/pkg/ir/ir_bridge.lg index a276244a0..205f3558e 100644 --- a/pkg/ir/ir_bridge.lg +++ b/pkg/ir/ir_bridge.lg @@ -428,6 +428,17 @@ arg0.Append32(arg2) return vm.NIL, nil"} + ;; Emit n OP_POPs — drop the top n stack slots. Used by the branch + ;; pass-through fast path to clear dead extras above the args without + ;; DUP shuffling. NOTE: vm.OP_POP_N is NOT "pop n" — it preserves the + ;; top value and drops n beneath it (a squash op) — hence plain POPs. + {:name "chunk-emit-pop-n" :lisp-name "ir/chunk-emit-pop-n" + :args [Self Int Int] + :body "for i := 0; i < int(arg2); i++ { + arg0.Append(vm.OP_POP | int32((arg1-i)<<16)) + } + return vm.NIL, nil"} + ;; Emit the 4-word OP_RECUR sequence (for loop back-edges with ;; stack cleanup). Returns the IP of the placeholder offset slot. {:name "chunk-emit-recur" :lisp-name "ir/chunk-emit-recur" diff --git a/pkg/rt/core/ir/lower.lg b/pkg/rt/core/ir/lower.lg index 5c4c74611..97fbffac0 100644 --- a/pkg/rt/core/ir/lower.lg +++ b/pkg/rt/core/ir/lower.lg @@ -84,6 +84,9 @@ ;; minus 1 below the target's params; OP_RECUR/clean BRANCH ;; leave 0). Used to compute true runtime SP for max-stack. :block-junk (vec (repeat n-blocks 0)) + ;; Exact junk each pred reported per target (nil = none yet); + ;; disagreement aborts lowering — see record-block-junk!. + :block-junk-seen {} :current-block 0}))) ;; Field accessors that read the atom — keep call sites tidy. @@ -126,11 +129,25 @@ (get (:block-junk @l) bid 0)) (defn- record-block-junk! [l bid junk] - "Record (or raise) junk-below for block bid. Multiple predecessors may - set this; take the max." - (let [cur (block-junk-of l bid)] - (when (> junk cur) - (swap! l update :block-junk assoc bid junk)))) + "Record junk-below for block bid. Every fall-through predecessor must + agree: junk is baked into the target's OP_RECUR drop counts, so a + path entering with different junk over- or under-drops the runtime + stack (observed as `slice bounds out of range` underflows). The old + take-the-max rule was harmless only while mismatching shapes could + not lower at all; the deferral/RPO fixes let them lower, so a + disagreement now aborts this fn's lowering (the defn hybrid falls + back to the plain bytecode compiler, exactly as before). RECUR-edge + preds do not report: they rebuild the target's stack to junk 0, the + same silent normalization main's back-edges have always relied on." + (let [seen (:block-junk-seen @l) + cur (get seen bid)] + (if (nil? cur) + (do (swap! l update :block-junk-seen assoc bid junk) + (when (pos? junk) + (swap! l update :block-junk assoc bid junk))) + (when (not= cur junk) + (throw (str "ir/lower: junk-below mismatch for block " bid + " (" cur " vs " junk "); unsupported shape")))))) (defn- bump-max-stack! [l] "If current runtime SP (= lower-sp + current block's junk-below) @@ -563,6 +580,11 @@ ;; branch-if's leftovers) leaks `junk` slots per ;; iteration until the frame stack overflows. ignore (+ (- drop-count argc) cur-junk) + ;; RECUR rebuilds the target's stack from scratch: junk 0. + ;; Register that as this pred's exact junk report so a + ;; mismatch with another pred's nonzero junk is caught + ;; (→ fallback) instead of silently over-dropping. + _ (record-block-junk! l target 0) off-ip (ir/chunk-emit-recur (chunk-of l) cur-sp argc ignore)] (record-source-info! l nid) (add-patch! l {:src-ip (dec off-ip) @@ -607,9 +629,10 @@ :offset-slot 1 :negate? false}) (bump-stack-sp! l -1) ; cond popped - ;; If true-target is the immediately-following block, fall through. + ;; If true-target is the next block in EMISSION order (RPO, not + ;; id order), fall through; otherwise jump explicitly. (let [my-block (ir/block-of nid f) - next-block-id (inc my-block)] + next-block-id (get (:next-of @l) my-block -1)] (when (not= tt-target next-block-id) (let [arg-ip2 (emit-placeholder! l nid :branch)] (add-patch! l {:src-ip (dec arg-ip2) @@ -716,20 +739,38 @@ (defn- deferrable-branch-if-cond? [l term cond-ref] "True iff cond-ref is safe to defer past the body walk: it has - exactly one use (use-count==1) and that user is the branch-if - terminator itself. build-if always produces such conds; only - hand-built IR could violate this." + exactly one use (use-count==1), that user is the branch-if + terminator itself, AND it is not also one of the terminator's + branch-target args. The last condition matters because the use + bitset counts USERS, not uses: a value that is both the cond and + a branch arg (e.g. `(let [v (f x)] (when v ...) v)` threads v as + the join's block-arg) still reads as one user, but the terminator + materializes the branch args BEFORE the deferred cond — asking for + a value whose emission was skipped. For non-cheap ops (:call) that + is an ir/lower throw and the whole fn silently falls back to the + plain bytecode compiler." ;; cond-ref is typed as native int (InstId) by gogen; :branch-if ;; always has exactly one ref so cond-ref is never nil here. - (and (= 1 (use-count-of l cond-ref)) - ;; use-count==1 → bitset has exactly one user-id; read via - ;; ir/uses-first (bitsets are vec-of-int64-words, so raw - ;; `first`/`count` would return a word and the word-count). - (let [uses (:uses @l) - us (when (< cond-ref (count uses)) (nth uses cond-ref))] - (and us - (not (ir/uses-empty? us)) - (= term (ir/uses-first us)))))) + (and + ;; A :block-arg cond must NOT defer: deferral means "emit at the + ;; terminator", but emitting a :block-arg emits nothing (its value + ;; sits at a param slot) — BRANCH_F would then pop whatever is on + ;; top (usually a just-materialized branch arg) as the cond. The + ;; normal path DUPs it from its slot correctly. + (not= :block-arg (ir/op cond-ref (f-of l))) + (= 1 (use-count-of l cond-ref)) + ;; use-count==1 → bitset has exactly one user-id; read via + ;; ir/uses-first (bitsets are vec-of-int64-words, so raw + ;; `first`/`count` would return a word and the word-count). + (let [uses (:uses @l) + us (when (< cond-ref (count uses)) (nth uses cond-ref))] + (and us + (not (ir/uses-empty? us)) + (= term (ir/uses-first us)))) + ;; Not a branch arg of its own terminator (targets are symmetric + ;; by validate-fn!, so checking the true side suffices). + (let [tt (ir/cond-target-true (ir/aux term (f-of l)))] + (not (some (fn [a] (= a cond-ref)) (ir/branch-target-args tt)))))) (defn- lower-block! [l bid] (swap! l assoc :current-block bid) @@ -745,7 +786,32 @@ (when (= term-op :branch-if) (let [cond-ref (first (ir/refs term f))] (when (deferrable-branch-if-cond? l term cond-ref) - cond-ref)))] + cond-ref))) + ;; Tail-call fusion: a :return whose value is a single-use :call + ;; that is this block's last live inst lowers as TAIL_CALL (frame + ;; reuse) instead of INVOKE+RETURN — mirroring the plain bytecode + ;; compiler's tail-position emission. Safe w.r.t. try: the IR + ;; models try bodies as inner closures referenced by a :try inst, + ;; so a fusable :call is never inside a guarded region of this + ;; frame. + fused-tail-call + (when (= term-op :return) + (let [r (first (ir/refs term f))] + (when (and r + (= :call (ir/op r f)) + (= 1 (use-count-of l r)) + (let [uses (:uses @l) + us (when (< r (count uses)) (nth uses r))] + (and us + (not (ir/uses-empty? us)) + (= term (ir/uses-first us)))) + ;; Must be the last live inst of THIS block so + ;; skipping it in the body walk reorders nothing. + (let [remaining (drop-while (fn [x] (not= x r)) insts)] + (and (seq remaining) + (every? (fn [x] (= :invalid (ir/op x f))) + (rest remaining))))) + r)))] ;; Block-args are pre-placed by predecessors. Entry block has none. (set-stack-sp! l (count params)) (loop [i 0] @@ -766,6 +832,8 @@ (doseq [r (ir/refs nid f)] (decrement-use! l r)) ;; Deferred cond (emitted after branch-target args). (and deferred-cond (= nid deferred-cond)) nil + ;; Tail-call-fused call (emitted as part of the terminator). + (and fused-tail-call (= nid fused-tail-call)) nil ;; Cheap-load deferral: skip body emission when not body-emit-cheap. ;; Only set!-TARGET :load-vars are excluded — those must be ;; materialized once so two loads can't straddle the set! and read @@ -815,6 +883,18 @@ (materialize-refs! l term-refs))))) ;; 3. Emit BRANCH_FALSE. (lower-node! l term)) + fused-tail-call + ;; Fused tail call: put the call's fn+args on top, emit TAIL_CALL + ;; argc. The RETURN after it is dead (the VM treats TAIL_CALL as + ;; terminal) but kept for parity with the plain compiler's shape. + (let [crefs (ir/refs fused-tail-call f)] + (if (refs-at-top-last-use? l crefs) + (consume-refs-in-place! l crefs) + (materialize-refs! l crefs)) + (decrement-use! l fused-tail-call) + (emit-with-arg! l fused-tail-call :tail-call + (int (ir/aux fused-tail-call f))) + (emit! l term :return)) :else (let [term-refs (ir/refs term f)] ;; Direct Refs (return value, branch's empty refs, call's fn+args). @@ -840,6 +920,50 @@ (+ src-ip (:offset-slot p)) offset)))) +;; --- emission order -------------------------------------------------- + +(defn- block-succs [f bid] + (let [term (ir/block-term bid f)] + (if (or (nil? term) (zero? term)) + [] + (let [op (ir/op term f) + aux (ir/aux term f)] + (cond + (= op :branch) + [(ir/branch-target-target aux)] + (= op :branch-if) + [(ir/branch-target-target (ir/cond-target-true aux)) + (ir/branch-target-target (ir/cond-target-false aux))] + :else []))))) + +(defn- rpo-block-order [f] + "Reverse-postorder over the CFG from the entry block. Emission MUST + follow an order where every non-back edge points forward: a block's + junk-below (values a pred's BRANCH_F leaves beneath its params) is + recorded by the pred's lowering, so lowering a block before one of + its preds bakes in a stale junk count — its RECUR under-drops and + every later slot reference shifts (miscompile, e.g. a loop whose + cond is an `and`: build-loop gives the body a LOWER id than the + cond-chain blocks). Raw id order only worked for CFGs where preds + happen to have lower ids. Back-edge preds are exempt: OP_RECUR + rebuilds the stack, junk 0. Successors are visited highest-id-first + so the order coincides with id order whenever id order was already + valid (keeps existing output byte-stable). Unreachable blocks are + appended in id order so block-ips stays total." + (let [n (count (ir/blocks f)) + state (atom {:visited #{} :post []})] + ((fn dfs [b] + (when-not (contains? (:visited @state) b) + (swap! state update :visited conj b) + (doseq [s (reverse (sort (distinct (block-succs f b))))] + (dfs s)) + (swap! state update :post conj b))) + 0) + (let [order (vec (reverse (:post @state))) + seen (set order)] + (vec (concat order + (filter (fn [b] (not (contains? seen b))) (range n))))))) + ;; --- entry point ----------------------------------------------------- (defn lower [f] @@ -850,12 +974,16 @@ (throw "ir/lower: nil function")) (let [l (new-lowerer f)] (check-cross-block! f (:uses @l)) - (let [n-blocks (count (ir/blocks f))] - (loop [bid 0] - (when (< bid n-blocks) - (set-block-ip! l bid (ir/chunk-length (chunk-of l))) - (lower-block! l bid) - (recur (inc bid))))) + (let [order (rpo-block-order f) + next-of (loop [i 0 acc {}] + (if (>= i (dec (count order))) + acc + (recur (inc i) + (assoc acc (nth order i) (nth order (inc i))))))] + (swap! l assoc :next-of next-of) + (doseq [bid order] + (set-block-ip! l bid (ir/chunk-length (chunk-of l))) + (lower-block! l bid))) (patch-branches! l) ;; Conservative max-stack guard: bump by the max number of params ;; across all blocks. The block-junk tracking above handles the diff --git a/pkg/rt/core/ir/passes/pipeline.lg b/pkg/rt/core/ir/passes/pipeline.lg index 65af32f8c..c3b92ba41 100644 --- a/pkg/rt/core/ir/passes/pipeline.lg +++ b/pkg/rt/core/ir/passes/pipeline.lg @@ -628,10 +628,20 @@ _ (swap! built assoc :private? private?) ;; Stash the built IR (pre-optimize) so later same-ns defns can ;; seed the inline registry from this one. Opt-in: only when - ;; *enable-inline* is bound true. + ;; *enable-inline* is bound true. Retention is single-ns: the + ;; registry seeds same-ns only, so entries for other (already + ;; loaded) namespaces are dead weight — retaining them across a + ;; whole corpus load measurably raises live heap and GC mark + ;; cost per cycle. A require mid-file switches the cache to the + ;; dependency's ns and back, which at worst drops seed entries + ;; for defns that preceded the require (requires normally come + ;; first, and a lost seed only forfeits an inline opportunity). _ (when ir.passes.inline/*enable-inline* - (swap! *runtime-defn-ir-cache* - assoc-in [(str (ns-name *ns*)) (str name-sym)] built))] + (let [ns-str (str (ns-name *ns*))] + (swap! *runtime-defn-ir-cache* + (fn [c] + {ns-str (assoc (get c ns-str {}) + (str name-sym) built)}))))] ;; Target-specific orchestration (lambda-lift for :go, fold-outline for ;; :bytecode) wraps the actual lowering — but the lowering itself is ;; DELEGATED to the `lowerings` strategy registry via *target* (#387's @@ -754,6 +764,26 @@ (assoc result :status :lowered) result))) +(defn compile-def-fn-value [fn-form the-ns def-name] + "Runtime seam for name*-wrapped rule defs (the Go defCompiler hook). + Compiles a bare `(fn ...)`/`(fn* ...)` form that appears as an argument + inside a top-level `(def NAME (name* ... (fn ...) ...))` through the IR + pipeline, returning the compiled Fn VALUE — the hook substitutes it as a + constant in place of the fn form, exactly like the defn macro's + chunk->fn embedding. Single-arity only; throws on any other shape or on + any pipeline failure, and the hook then falls back to the plain + bytecode compile of the original form." + (let [tail (rest fn-form) + tail (if (symbol? (first tail)) (rest tail) tail) + args-vec (first tail)] + (if (vector? args-vec) + (let [variadic? (boolean (some (fn [a] (= a '&)) args-vec)) + arity (if variadic? (- (count args-vec) 1) (count args-vec)) + defn-form (apply list 'defn (symbol def-name) args-vec (rest tail)) + chunk (compile-form defn-form the-ns)] + (chunk->fn arity variadic? chunk)) + (throw "compile-def-fn-value: multi-arity fn form unsupported")))) + ;; --- Go bootstrap generation ------------------------------------------- (defn- go-name-for [name-sym] diff --git a/pkg/rt/generated.sums b/pkg/rt/generated.sums index 1f1af7b89..36454d14a 100644 --- a/pkg/rt/generated.sums +++ b/pkg/rt/generated.sums @@ -2,4 +2,4 @@ # Content digest of all .lg + lgbgen sources that feed the .lgb # bundle and the lowered Go tree. The genmanifest staleness test # fails if this no longer matches the sources on disk. -3e6422d48afd47a710f152282f00679029a1ce7144036d8774eee0831e857d87 +3ef74f301cf32f0158364ee2a1f337e66b7dad69b2a05fc9e7165be0248c6a32 diff --git a/pkg/rt/ir_bridge_generated.go b/pkg/rt/ir_bridge_generated.go index 3e723c509..cd2ab8791 100644 --- a/pkg/rt/ir_bridge_generated.go +++ b/pkg/rt/ir_bridge_generated.go @@ -376,6 +376,30 @@ func installIRBridgeBuiltins() { return vm.NIL, nil }) ns.Def("chunk-emit-dup-nth", chunk_chunk_emit_dup_nth_Fn) + chunk_chunk_emit_pop_n_Fn, _ := vm.NativeFnType.Wrap(func(vs []vm.Value) (vm.Value, error) { + if len(vs) != 3 { + return vm.NIL, fmt.Errorf("ir/chunk-emit-pop-n: expected (Self Int Int), got %d args", len(vs)) + } + arg0, err := chunkFromBoxed(vs[0]) + if err != nil { + return vm.NIL, fmt.Errorf("ir/chunk-emit-pop-n: %v", err) + } + arg1Int, ok1 := vs[1].(vm.Int) + if !ok1 { + return vm.NIL, fmt.Errorf("ir/chunk-emit-pop-n: arg 1 must be Int, got %s", vs[1].Type().Name()) + } + arg1 := int(arg1Int) + arg2Int, ok2 := vs[2].(vm.Int) + if !ok2 { + return vm.NIL, fmt.Errorf("ir/chunk-emit-pop-n: arg 2 must be Int, got %s", vs[2].Type().Name()) + } + arg2 := int(arg2Int) + for i := 0; i < int(arg2); i++ { + arg0.Append(vm.OP_POP | int32((arg1-i)<<16)) + } + return vm.NIL, nil + }) + ns.Def("chunk-emit-pop-n", chunk_chunk_emit_pop_n_Fn) chunk_chunk_emit_recur_Fn, _ := vm.NativeFnType.Wrap(func(vs []vm.Value) (vm.Value, error) { if len(vs) != 4 { return vm.NIL, fmt.Errorf("ir/chunk-emit-recur: expected (Self Int Int Int), got %d args", len(vs))