Skip to content

feat(ir): def+name* IR-compile seam + block-junk agreement (salvaged from #556) #625

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Closed
nnunley wants to merge 1 commit into from
Closed

feat(ir): def+name* IR-compile seam + block-junk agreement (salvaged from #556) #625

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
85 changes: 85 additions & 0 deletions pkg/compiler/compiler.go
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand All @@ -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
Expand Down
11 changes: 11 additions & 0 deletions pkg/ir/ir_bridge.lg
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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"
Expand Down
180 changes: 154 additions & 26 deletions pkg/rt/core/ir/lower.lg
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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.
Expand Down Expand Up @@ -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)
Expand Down Expand Up @@ -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)
Expand Down Expand Up @@ -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)
Expand Down Expand Up @@ -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)
Expand All @@ -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]
Expand All @@ -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
Expand Down Expand Up @@ -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).
Expand All @@ -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]
Expand All @@ -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
Expand Down
Loading
Loading