simon/jolt
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Thread an immutable env through the type-inference walk

Browse source 
types.clj drove inference through ~14 module-level atoms; the infer walk was
non-reentrant and depended on hidden set-*! install order. Thread one immutable
env (mk-env) through infer instead: it snapshots the installed config
(rtenv/vtypes/record-shapes/protocol-methods/map-shapes?) and carries the
per-run flags and accumulator/guard cells (diags/calls/checking-set/diag-memo).
A fresh env per run makes the pass re-entrant — isolated-diag-count's probe now
runs under a sub-env with its own diags cell instead of save/restoring a shared
atom.

Only state whose lifecycle spans separate API calls stays module-level: a
config-box the set-*! API writes, the escapes/user-sig sweep registries, and a
bridge holding the last checking run's diags for take-diags!. record-type-from-
entry/field-type-from-tag now take the shapes map directly rather than reading a
global.

jolt-ogib.10. Behavior pinned by the new infer gate (23 cases) plus selfhost +
buildsmoke. Re-minted seed.
This commit is contained in:
Yogthos 2026-06-23 09:19:24 -04:00
parent 9c5e46e91b
commit 4fdc9f165e
2 changed files with 412 additions and 437 deletions
Download patch file Download diff file Expand all files Collapse all files

414
host/chez/seed/image.ss
View file

File diff suppressed because one or more lines are too long

381
jolt-core/jolt/passes/types.clj
View file

@ -12,75 +12,71 @@
join-t join type-depth cap struct-safe? field-type shape-order type-shape join-t join type-depth cap struct-safe? field-type shape-order type-shape
mark-struct truthy-type? num-ret-fns vector-ret-fns]])) mark-struct truthy-type? num-ret-fns vector-ret-fns]]))
;; Inter-procedural state. The orchestrator (backend ;; --- engine state ------------------------------------------------------------
;; infer-unit!) drives a whole-unit fixpoint: before typing a fn body it installs ;; The walk threads an immutable `env` (mk-env) instead of reading scattered
;; the current return-type estimates of all unit fns here, and after typing it ;; module atoms: it carries the read-only config (rtenv/vtypes/record-shapes/
;; reads back the call sites this body made (callee + inferred arg types) to ;; protocol-methods/map-shapes?) plus the per-run flags (checking?/strict?) and
;; propagate into callee param types. Both are plain module state, like `dirty`. ;; per-run accumulator/guard CELLS (diags/calls/checking-set/diag-memo). A fresh
(def ^:private rtenv-box (atom {})) ;; "ns/name" -> inferred return type ;; env per run makes the pass re-entrant — a nested probe (isolated-diag-count)
(def ^:private calls-box (atom [])) ;; collected [ "ns/name" [arg-types...] ] ;; runs under a sub-env with its own diags cell, no save/restore.
(def ^:private escapes-box (atom #{})) ;; var-keys used as a VALUE (not a call head) ;;
(def ^:private diag-box (atom [])) ;; success-type-check diagnostics (RFC 0006) ;; Only state whose lifecycle spans separate API calls stays module-level: the
;; a var reference's VALUE type — a fn var is :truthy (non-nil), a def ;; config the orchestrator installs (set-*! before a sweep), the escapes and
;; var carries its inferred init type (e.g. a color table -> {:vec :struct-map}). ;; user-sig registries (collected/registered across the forms of a sweep), and a
;; The orchestrator populates this from sealed (opt-mode) cell roots + def inits. ;; bridge holding the last checking run's diagnostics for take-diags!.
(def ^:private vtype-box (atom {})) ;; "ns/name" -> value type (def ^:private config-box
(atom {:rtenv {} ;; "ns/name" -> inferred return type
;; User-function error domains, opt-in. As the checker walks defs it :vtypes {} ;; "ns/name" -> var VALUE type (fn=:truthy, def=init type)
;; registers each non-redefinable single-fixed-arity user fn's {:params :body} :record-shapes {} ;; "ns/->Name" -> {:fields :tags :type}
;; here, keyed "ns/name". At a later call site (strict mode only) the body is :protocol-methods {} ;; "ns/method" -> [proto method]
;; re-checked with ONE parameter bound to its concrete argument type — if that :map-shapes? false})) ;; shape generic const-key maps (opt-in, JOLT_SHAPE)
;; alone produces a diagnostic the all-:any body did not, that argument is ;; var-keys used as a VALUE (not a call head) — accumulated across a whole sweep,
;; provably wrong and the CALL is reported. Module state, like rtenv-box: a def ;; reset by reset-escapes! and read by collected-escapes.
;; must precede its call (the same closed-world ordering RFC 0005 assumes). (def ^:private escapes-box (atom #{}))
;; User-function error domains, opt-in. As the checker walks defs it registers
;; each non-redefinable single-fixed-arity user fn's {:params :body} here, keyed
;; "ns/name"; a later call site (strict mode) re-checks the body with one param
;; bound to its concrete argument type. Accumulates ACROSS forms — a def must
;; precede its call (the closed-world ordering RFC 0005 assumes).
(def ^:private user-sig-box (atom {})) ;; "ns/name" -> {:params [..] :body ir} (def ^:private user-sig-box (atom {})) ;; "ns/name" -> {:params [..] :body ir}
;; a record constructor's return shape. "ns/->Name" -> [field-kw ...] ;; Diagnostics from the last checking run-inference, for take-diags! to drain.
;; in DECLARED order (the runtime lays records out in declared field order, so (def ^:private last-diags-box (atom []))
;; the back end bare-indexes by that order). A call (->Point a b) types as a ;; Whether run-inference also checks, and strictly. Set by set-check-mode!.
;; struct of this shape, so field reads on the result bare-index — declared (def ^:private check-mode-box (atom {:on false :strict false}))
;; shapes are clean fuel: a lookup, not fragile inference.
(def ^:private record-shapes-box (atom {}))
;; protocol-method registry "ns/method" -> [proto method], for
;; devirtualizing a protocol call whose receiver is a known record type.
(def ^:private protocol-methods-box (atom {}))
;; build a record's struct TYPE from its registry entry, resolving each ;; build a per-run env: a snapshot of the installed config plus this run's flags
;; field's declared type hint. A field tagged with a record type (its ctor-key) ;; and fresh accumulator/guard cells. escapes/user-sigs reference the sweep-level
;; recurses, so a Vec3 stored in a Ray field reads back as Vec3 — not :any — ;; module cells (their lifecycle spans calls); diags/calls/checking-set/diag-memo
;; which is what lets nested-record code prove its reads. Depth-bounded so a ;; are this run's own.
;; self/cyclic-referencing record type can't loop. (defn- mk-env [checking? strict?]
(let [c @config-box]
{:rtenv (get c :rtenv) :vtypes (get c :vtypes)
:record-shapes (get c :record-shapes) :protocol-methods (get c :protocol-methods)
:map-shapes? (get c :map-shapes?)
:checking? checking? :strict? strict?
:diags (atom []) :calls (atom []) :checking-set (atom #{}) :diag-memo (atom {})
:escapes escapes-box :user-sigs user-sig-box}))
;; build a record's struct TYPE from its registry entry, resolving each field's
;; declared type hint against `shapes` ("ns/->Name" -> entry). A field tagged with
;; a record type (its ctor-key) recurses, so a Vec3 stored in a Ray field reads
;; back as Vec3 — not :any — which is what lets nested-record code prove its reads.
;; Depth-bounded so a self/cyclic-referencing record type can't loop.
(declare record-type-from-entry) (declare record-type-from-entry)
(defn- field-type-from-tag [tag depth] (defn- field-type-from-tag [tag depth shapes]
(cond (cond
(or (nil? tag) (<= depth 0)) :any (or (nil? tag) (<= depth 0)) :any
(= tag "num") :num (= tag "num") :num
:else (let [e (get @record-shapes-box tag)] :else (let [e (get shapes tag)]
(if e (record-type-from-entry e depth) :any)))) (if e (record-type-from-entry e depth shapes) :any))))
(defn- record-type-from-entry [rs depth] (defn- record-type-from-entry [rs depth shapes]
(let [fields (get rs :fields) (let [fields (get rs :fields)
tags (get rs :tags) tags (get rs :tags)
fmap (reduce (fn [m i] fmap (reduce (fn [m i]
(assoc m (nth fields i) (assoc m (nth fields i)
(field-type-from-tag (when tags (nth tags i)) (dec depth)))) (field-type-from-tag (when tags (nth tags i)) (dec depth) shapes)))
{} (range (count fields)))] {} (range (count fields)))]
(assoc (mk-struct fmap) :shape (vec fields) :type (get rs :type)))) (assoc (mk-struct fmap) :shape (vec fields) :type (get rs :type))))
;; whether to shape generic const-key MAP literals (opt-in, JOLT_SHAPE).
;; Records are shaped regardless; maps only when this is on.
(def ^:private map-shapes-box (atom false))
(def ^:private checking-box (atom #{})) ;; keys mid-recheck — cycle guard
(def ^:private strict-box (atom false)) ;; report against user-fn domains?
;; Memo for check-user-call's per-fn body re-inference: [:base key] -> baseline
;; diag count, [:arg key i argtype] -> does binding param i to argtype add a
;; diagnostic. Cleared per form (check-form) — the global type-env is stable within
;; one form's check, and isolated-diag-count's calls/escapes side effects are not
;; read there, so skipping a repeat probe is observably identical.
(def ^:private diag-memo-box (atom {}))
;; When true, `infer` emits success-type diagnostics as it types (jolt audit).
;; The checker IS the inference walk now — one O(n) pass that both types and
;; checks, instead of a separate check-walk that re-inferred every subtree
;; (quadratic in nesting). Off during the optimization fixpoint so it doesn't
;; emit intermediate diagnostics; on only inside check-form.
(def ^:private checking? (atom false))
;; fns that RETURN an element of their (first) collection arg, so a lookup on the ;; fns that RETURN an element of their (first) collection arg, so a lookup on the
;; result of (rand-nth coll-of-structs) etc. types as the element. ;; result of (rand-nth coll-of-structs) etc. types as the element.
@ -91,18 +87,19 @@
(defn- var-key [fnode] (str (get fnode :ns) "/" (get fnode :name))) (defn- var-key [fnode] (str (get fnode :ns) "/" (get fnode :name)))
(defn- call-ret-type [fnode] (defn- call-ret-type [fnode env]
(let [op (get fnode :op)] (let [op (get fnode :op)
shapes (get env :record-shapes)]
(cond (cond
;; a user fn whose return type the fixpoint has estimated ;; a user fn whose return type the fixpoint has estimated
(= op :var) (let [rs (get @record-shapes-box (var-key fnode))] (= op :var) (let [rs (get shapes (var-key fnode))]
(if rs (if rs
;; record ctor -> struct of declared shape; :shape ;; record ctor -> struct of declared shape; :shape
;; is the DECLARED field order the back end indexes by, :type ;; is the DECLARED field order the back end indexes by, :type
;; the record tag (devirt), and field types come from the ;; the record tag (devirt), and field types come from the
;; declared hints so nested records stay typed ;; declared hints so nested records stay typed
(record-type-from-entry rs type-depth) (record-type-from-entry rs type-depth shapes)
(let [r (get @rtenv-box (var-key fnode))] (let [r (get (get env :rtenv) (var-key fnode))]
(if r r (let [nm (and (= "clojure.core" (get fnode :ns)) (get fnode :name))] (if r r (let [nm (and (= "clojure.core" (get fnode :ns)) (get fnode :name))]
(cond (nil? nm) :any (cond (nil? nm) :any
(contains? num-ret-fns nm) :num (contains? num-ret-fns nm) :num
@ -161,7 +158,7 @@
types (seeds: param-index -> type), other params :any, captured locals from types (seeds: param-index -> type), other params :any, captured locals from
tenv. Returns [ret-type node'] — ret is the lub of arity tail types, used to tenv. Returns [ret-type node'] — ret is the lub of arity tail types, used to
type the HOF result (e.g. reduce's accumulator, mapv's element)." type the HOF result (e.g. reduce's accumulator, mapv's element)."
[node seeds tenv] [node seeds tenv env]
(let [res (mapv (fn [a] (let [res (mapv (fn [a]
(let [params (get a :params) (let [params (get a :params)
pe (reduce (fn [e i] pe (reduce (fn [e i]
@ -169,7 +166,7 @@
(let [s (get seeds i)] (if s s :any)))) (let [s (get seeds i)] (if s s :any))))
tenv (range (count params))) tenv (range (count params)))
pe (if (get a :rest) (assoc pe (get a :rest) :any) pe) pe (if (get a :rest) (assoc pe (get a :rest) :any) pe)
br (infer (get a :body) pe)] br (infer (get a :body) pe env)]
[(nth br 0) (assoc a :body (nth br 1))])) [(nth br 0) (assoc a :body (nth br 1))]))
(get node :arities)) (get node :arities))
rets (mapv (fn [r] (nth r 0)) res) rets (mapv (fn [r] (nth r 0)) res)
@ -179,8 +176,8 @@
(defn- infer (defn- infer
"Returns [type node'] — the inferred type of node and node with struct-safe "Returns [type node'] — the inferred type of node and node with struct-safe
:local references annotated :hint :struct. tenv maps in-scope local names to :local references annotated :hint :struct. tenv maps in-scope local names to
inferred types." inferred types; env carries the inference config and this run's accumulators."
[node tenv] [node tenv env]
(let [op (get node :op)] (let [op (get node :op)]
(cond (cond
(= op :const) (= op :const)
@ -202,8 +199,8 @@
(= op :map) (= op :map)
(let [pairs (get node :pairs) (let [pairs (get node :pairs)
res (mapv (fn [pr] res (mapv (fn [pr]
(let [kr (infer (nth pr 0) tenv) (let [kr (infer (nth pr 0) tenv env)
vr (infer (nth pr 1) tenv)] vr (infer (nth pr 1) tenv env)]
[(nth kr 1) (nth vr 1) (nth vr 0) (get (nth pr 0) :val)])) [(nth kr 1) (nth vr 1) (nth vr 0) (get (nth pr 0) :val)]))
pairs) pairs)
struct? (and (> (count res) 0) struct? (and (> (count res) 0)
@ -213,38 +210,38 @@
(cap (mk-struct (reduce (fn [m r] (assoc m (nth r 3) (nth r 2))) {} res)) type-depth)) (cap (mk-struct (reduce (fn [m r] (assoc m (nth r 3) (nth r 2))) {} res)) type-depth))
;; a literal is a COMPLETE shape: carry its sorted key vector so the ;; a literal is a COMPLETE shape: carry its sorted key vector so the
;; back end can lay it out and bare-index lookups ;; back end can lay it out and bare-index lookups
shp (when (and @map-shapes-box base (struct-type? base)) (shape-order (keys (sfields base)))) shp (when (and (get env :map-shapes?) base (struct-type? base)) (shape-order (keys (sfields base))))
t (if base (if shp (assoc base :shape shp) base) :any) t (if base (if shp (assoc base :shape shp) base) :any)
node' (assoc node :pairs (mapv (fn [r] [(nth r 0) (nth r 1)]) res))] node' (assoc node :pairs (mapv (fn [r] [(nth r 0) (nth r 1)]) res))]
[t (if shp (assoc node' :shape shp) node')]) [t (if shp (assoc node' :shape shp) node')])
(= op :vector) (= op :vector)
(let [irs (mapv (fn [x] (infer x tenv)) (get node :items)) (let [irs (mapv (fn [x] (infer x tenv env)) (get node :items))
ets (mapv (fn [r] (nth r 0)) irs) ets (mapv (fn [r] (nth r 0)) irs)
el (if (empty? ets) :any (reduce join (first ets) (rest ets)))] el (if (empty? ets) :any (reduce join (first ets) (rest ets)))]
[(cap (mk-vec el) type-depth) (assoc node :items (mapv (fn [r] (nth r 1)) irs))]) [(cap (mk-vec el) type-depth) (assoc node :items (mapv (fn [r] (nth r 1)) irs))])
(= op :set) (= op :set)
(let [irs (mapv (fn [x] (infer x tenv)) (get node :items)) (let [irs (mapv (fn [x] (infer x tenv env)) (get node :items))
ets (mapv (fn [r] (nth r 0)) irs) ets (mapv (fn [r] (nth r 0)) irs)
el (if (empty? ets) :any (reduce join (first ets) (rest ets)))] el (if (empty? ets) :any (reduce join (first ets) (rest ets)))]
[(cap (mk-set el) type-depth) (assoc node :items (mapv (fn [r] (nth r 1)) irs))]) [(cap (mk-set el) type-depth) (assoc node :items (mapv (fn [r] (nth r 1)) irs))])
(= op :if) (= op :if)
(let [tr (infer (get node :test) tenv) (let [tr (infer (get node :test) tenv env)
thn (infer (get node :then) tenv) thn (infer (get node :then) tenv env)
els (infer (get node :else) tenv)] els (infer (get node :else) tenv env)]
[(join (nth thn 0) (nth els 0)) [(join (nth thn 0) (nth els 0))
(assoc node :test (nth tr 1) :then (nth thn 1) :else (nth els 1))]) (assoc node :test (nth tr 1) :then (nth thn 1) :else (nth els 1))])
(= op :do) (= op :do)
(let [stmts (mapv (fn [s] (nth (infer s tenv) 1)) (get node :statements)) (let [stmts (mapv (fn [s] (nth (infer s tenv env) 1)) (get node :statements))
r (infer (get node :ret) tenv)] r (infer (get node :ret) tenv env)]
[(nth r 0) (assoc node :statements stmts :ret (nth r 1))]) [(nth r 0) (assoc node :statements stmts :ret (nth r 1))])
(= op :throw) (= op :throw)
[:any (assoc node :expr (nth (infer (get node :expr) tenv) 1))] [:any (assoc node :expr (nth (infer (get node :expr) tenv env) 1))]
;; a :var reached HERE is in value position (an arg, a let init, ...), not ;; a :var reached HERE is in value position (an arg, a let init, ...), not
;; a call head — so the fn it names escapes and its params can't be inferred. ;; a call head — so the fn it names escapes and its params can't be inferred.
;; Its VALUE type comes from vtype-box (a fn is :truthy, a def carries its ;; Its VALUE type comes from vtypes (a fn is :truthy, a def carries its
;; inferred type); unknown -> :any. ;; inferred type); unknown -> :any.
(= op :var) (do (swap! escapes-box conj (var-key node)) (= op :var) (do (swap! (get env :escapes) conj (var-key node))
[(let [vt (get @vtype-box (var-key node))] (if vt vt :any)) node]) [(let [vt (get (get env :vtypes) (var-key node))] (if vt vt :any)) node])
(= op :invoke) (= op :invoke)
(let [fnode (get node :fn) (let [fnode (get node :fn)
iscall-var (= :var (get fnode :op)) iscall-var (= :var (get fnode :op))
@ -258,32 +255,32 @@
;; after inference) collapsing any `if` it gates. Falls through to the ;; after inference) collapsing any `if` it gates. Falls through to the
;; normal call path when the answer isn't provable or the arg is impure. ;; normal call path when the answer isn't provable or the arg is impure.
(and iscall-var (contains? fold-preds cn) (= n 1)) (and iscall-var (contains? fold-preds cn) (= n 1))
(let [ar (infer (nth args 0) tenv) (let [ar (infer (nth args 0) tenv env)
v (pred-on cn (nth ar 0))] v (pred-on cn (nth ar 0))]
(if (and (not (nil? v)) (pure-node? (nth ar 1))) (if (and (not (nil? v)) (pure-node? (nth ar 1)))
[:any {:op :const :val v}] [:any {:op :const :val v}]
[(call-ret-type fnode) (assoc node :args [(nth ar 1)])])) [(call-ret-type fnode env) (assoc node :args [(nth ar 1)])]))
;; (:k m) / (:k m default): the result is m's field type, and if m is a ;; (:k m) / (:k m default): the result is m's field type, and if m is a
;; struct the subject is tagged so the back end drops the guard — this ;; struct the subject is tagged so the back end drops the guard — this
;; types nested access end to end (RFC 0005). ;; types nested access end to end (RFC 0005).
(and (= :const (get fnode :op)) (keyword? (get fnode :val)) (>= n 1) (<= n 2)) (and (= :const (get fnode :op)) (keyword? (get fnode :val)) (>= n 1) (<= n 2))
(let [mr (infer (nth args 0) tenv) (let [mr (infer (nth args 0) tenv env)
mt (nth mr 0) mt (nth mr 0)
msub (if (struct-safe? mt) (mark-struct (nth mr 1) mt) (nth mr 1)) msub (if (struct-safe? mt) (mark-struct (nth mr 1) mt) (nth mr 1))
ft (field-type mt (get fnode :val)) ft (field-type mt (get fnode :val))
dr (when (= n 2) (infer (nth args 1) tenv))] dr (when (= n 2) (infer (nth args 1) tenv env))]
[(if dr (join ft (nth dr 0)) ft) [(if dr (join ft (nth dr 0)) ft)
(assoc node :args (if dr [msub (nth dr 1)] [msub]))]) (assoc node :args (if dr [msub (nth dr 1)] [msub]))])
;; (get m :k [default]): same, when the key is a constant keyword. ;; (get m :k [default]): same, when the key is a constant keyword.
(and (or (and (= :var (get fnode :op)) (= "clojure.core" (get fnode :ns)) (= "get" (get fnode :name))) (and (or (and (= :var (get fnode :op)) (= "clojure.core" (get fnode :ns)) (= "get" (get fnode :name)))
(and (= :host (get fnode :op)) (= "get" (get fnode :name)))) (and (= :host (get fnode :op)) (= "get" (get fnode :name))))
(>= n 2) (= :const (get (nth args 1) :op)) (keyword? (get (nth args 1) :val))) (>= n 2) (= :const (get (nth args 1) :op)) (keyword? (get (nth args 1) :val)))
(let [mr (infer (nth args 0) tenv) (let [mr (infer (nth args 0) tenv env)
mt (nth mr 0) mt (nth mr 0)
msub (if (struct-safe? mt) (mark-struct (nth mr 1) mt) (nth mr 1)) msub (if (struct-safe? mt) (mark-struct (nth mr 1) mt) (nth mr 1))
kr (infer (nth args 1) tenv) kr (infer (nth args 1) tenv env)
ft (field-type mt (get (nth args 1) :val)) ft (field-type mt (get (nth args 1) :val))
dr (when (= n 3) (infer (nth args 2) tenv))] dr (when (= n 3) (infer (nth args 2) tenv env))]
[(if dr (join ft (nth dr 0)) ft) [(if dr (join ft (nth dr 0)) ft)
(assoc node :args (if dr [msub (nth kr 1) (nth dr 1)] [msub (nth kr 1)]))]) (assoc node :args (if dr [msub (nth kr 1) (nth dr 1)] [msub (nth kr 1)]))])
;; reduce over a typed vector with a fn-literal: seed the ;; reduce over a typed vector with a fn-literal: seed the
@ -292,11 +289,11 @@
;; it makes — see those types. ;; it makes — see those types.
(and (= cn "reduce") (>= n 2) (= :fn (get (nth args 0) :op))) (and (= cn "reduce") (>= n 2) (= :fn (get (nth args 0) :op)))
(let [three (>= n 3) (let [three (>= n 3)
coll-r (infer (nth args (if three 2 1)) tenv) coll-r (infer (nth args (if three 2 1)) tenv env)
init-r (when three (infer (nth args 1) tenv)) init-r (when three (infer (nth args 1) tenv env))
et (let [ct (nth coll-r 0)] (if (vec-type? ct) (velem ct) :any)) et (let [ct (nth coll-r 0)] (if (vec-type? ct) (velem ct) :any))
init-t (if init-r (nth init-r 0) :any) init-t (if init-r (nth init-r 0) :any)
fn-r (infer-fn-seeded (nth args 0) {0 init-t 1 et} tenv)] fn-r (infer-fn-seeded (nth args 0) {0 init-t 1 et} tenv env)]
[(join init-t (nth fn-r 0)) [(join init-t (nth fn-r 0))
(assoc node :args (if three (assoc node :args (if three
[(nth fn-r 1) (nth init-r 1) (nth coll-r 1)] [(nth fn-r 1) (nth init-r 1) (nth coll-r 1)]
@ -304,16 +301,16 @@
;; map/mapv/filter/... over a typed vector with a fn-literal: seed the ;; map/mapv/filter/... over a typed vector with a fn-literal: seed the
;; fn's element param; mapv/filterv produce a typed vector. ;; fn's element param; mapv/filterv produce a typed vector.
(and cn (get hof-table cn) (>= n 2) (= :fn (get (nth args 0) :op))) (and cn (get hof-table cn) (>= n 2) (= :fn (get (nth args 0) :op)))
(let [coll-r (infer (nth args 1) tenv) (let [coll-r (infer (nth args 1) tenv env)
et (let [ct (nth coll-r 0)] (if (vec-type? ct) (velem ct) :any)) et (let [ct (nth coll-r 0)] (if (vec-type? ct) (velem ct) :any))
fn-r (infer-fn-seeded (nth args 0) {(get (get hof-table cn) :epos) et} tenv) fn-r (infer-fn-seeded (nth args 0) {(get (get hof-table cn) :epos) et} tenv env)
rt (cond (= cn "mapv") (mk-vec (nth fn-r 0)) rt (cond (= cn "mapv") (mk-vec (nth fn-r 0))
(= cn "filterv") (mk-vec et) (= cn "filterv") (mk-vec et)
:else :any)] :else :any)]
[rt (assoc node :args [(nth fn-r 1) (nth coll-r 1)])]) [rt (assoc node :args [(nth fn-r 1) (nth coll-r 1)])])
;; conj/into: track the element type of a vector being grown. ;; conj/into: track the element type of a vector being grown.
(and (or (= cn "conj") (= cn "into")) (>= n 1)) (and (or (= cn "conj") (= cn "into")) (>= n 1))
(let [ares (mapv (fn [a] (infer a tenv)) args) (let [ares (mapv (fn [a] (infer a tenv env)) args)
base (nth (nth ares 0) 0) base (nth (nth ares 0) 0)
rest-ts (mapv (fn [r] (nth r 0)) (rest ares)) rest-ts (mapv (fn [r] (nth r 0)) (rest ares))
rt (cond rt (cond
@ -321,40 +318,40 @@
(mk-vec (reduce join (velem base) rest-ts)) (mk-vec (reduce join (velem base) rest-ts))
(and (= cn "into") (vec-type? base) (= 2 n) (vec-type? (nth rest-ts 0))) (and (= cn "into") (vec-type? base) (= 2 n) (vec-type? (nth rest-ts 0)))
(mk-vec (join (velem base) (velem (nth rest-ts 0)))) (mk-vec (join (velem base) (velem (nth rest-ts 0))))
:else (call-ret-type fnode))] :else (call-ret-type fnode env))]
[rt (assoc node :args (mapv (fn [r] (nth r 1)) ares))]) [rt (assoc node :args (mapv (fn [r] (nth r 1)) ares))])
;; everything else: type args, collect the call (var callee), use the ;; everything else: type args, collect the call (var callee), use the
;; declared/estimated return type. range produces a numeric vector. ;; declared/estimated return type. range produces a numeric vector.
:else :else
(let [fr (when (not iscall-var) (infer fnode tenv)) (let [fr (when (not iscall-var) (infer fnode tenv env))
fnode' (if iscall-var fnode (nth fr 1)) fnode' (if iscall-var fnode (nth fr 1))
;; the callee's value type: a var's from vtype-box (a fn is ;; the callee's value type: a var's from vtypes (a fn is
;; :truthy, a def carries its inferred type), else the inferred ;; :truthy, a def carries its inferred type), else the inferred
;; type of the callee expression ;; type of the callee expression
callee-t (if iscall-var (get @vtype-box (var-key fnode)) (nth fr 0)) callee-t (if iscall-var (get (get env :vtypes) (var-key fnode)) (nth fr 0))
ares (mapv (fn [a] (infer a tenv)) args)] ares (mapv (fn [a] (infer a tenv env)) args)]
(when iscall-var (when iscall-var
(swap! calls-box conj [(var-key fnode) (mapv (fn [r] (nth r 0)) ares)])) (swap! (get env :calls) conj [(var-key fnode) (mapv (fn [r] (nth r 0)) ares)]))
;; success-type check at this call, reusing the arg types just ;; success-type check at this call, reusing the arg types just
;; computed (jolt audit): core error domains always, user-fn domains ;; computed (jolt audit): core error domains always, user-fn domains
;; in strict mode. The arg subtrees are inferred exactly once. ;; in strict mode. The arg subtrees are inferred exactly once.
(when @checking? (when (get env :checking?)
(let [ats (mapv (fn [r] (nth r 0)) ares) pos (get node :pos)] (let [ats (mapv (fn [r] (nth r 0)) ares) pos (get node :pos)]
(when cn (check-invoke cn args ats pos)) (when cn (check-invoke cn args ats pos env))
;; calling a provably non-function ;; calling a provably non-function
(when (not-callable? callee-t) (when (not-callable? callee-t)
(swap! diag-box conj (swap! (get env :diags) conj
{:op :call :type (type-name callee-t) :pos pos {:op :call :type (type-name callee-t) :pos pos
:msg (str "cannot call " (type-name callee-t) " as a function")})) :msg (str "cannot call " (type-name callee-t) " as a function")}))
(when (and @strict-box iscall-var) (when (and (get env :strict?) iscall-var)
(let [k (var-key fnode) usig (get @user-sig-box k)] (let [k (var-key fnode) usig (get @(get env :user-sigs) k)]
(when usig (check-user-call k usig ats pos)))))) (when usig (check-user-call k usig ats pos env))))))
;; devirtualization: a protocol-method call whose receiver ;; devirtualization: a protocol-method call whose receiver
;; (arg 0) is a known record type resolves to a direct method call. ;; (arg 0) is a known record type resolves to a direct method call.
;; Annotate the node with [type-tag proto method]; the back end looks ;; Annotate the node with [type-tag proto method]; the back end looks
;; up the impl at emit time and calls it directly, skipping the ;; up the impl at emit time and calls it directly, skipping the
;; registry dispatch (~19x cheaper than protocol-dispatch). ;; registry dispatch (~19x cheaper than protocol-dispatch).
(let [pm (and iscall-var (get @protocol-methods-box (var-key fnode))) (let [pm (and iscall-var (get (get env :protocol-methods) (var-key fnode)))
rtype (when (and pm (pos? n)) (get (nth (nth ares 0) 0) :type)) rtype (when (and pm (pos? n)) (get (nth (nth ares 0) 0) :type))
base (assoc node :fn fnode' :args (mapv (fn [r] (nth r 1)) ares))] base (assoc node :fn fnode' :args (mapv (fn [r] (nth r 1)) ares))]
[(cond [(cond
@ -362,27 +359,27 @@
;; element-returning fn over a typed vector -> the element type ;; element-returning fn over a typed vector -> the element type
(and cn (contains? elem-fns cn) (> n 0)) (and cn (contains? elem-fns cn) (> n 0))
(let [a0 (nth (nth ares 0) 0)] (if (vec-type? a0) (velem a0) :any)) (let [a0 (nth (nth ares 0) 0)] (if (vec-type? a0) (velem a0) :any))
:else (call-ret-type fnode)) :else (call-ret-type fnode env))
(if rtype (if rtype
(assoc base :devirt-type rtype :devirt-proto (nth pm 0) :devirt-method (nth pm 1)) (assoc base :devirt-type rtype :devirt-proto (nth pm 0) :devirt-method (nth pm 1))
base)])))) base)]))))
(= op :let) (= op :let)
(let [res (reduce (fn [acc b] (let [res (reduce (fn [acc b]
(let [te (nth acc 0) binds (nth acc 1) (let [te (nth acc 0) binds (nth acc 1)
ir (infer (nth b 1) te)] ir (infer (nth b 1) te env)]
[(assoc te (nth b 0) (nth ir 0)) (conj binds [(nth b 0) (nth ir 1)])])) [(assoc te (nth b 0) (nth ir 0)) (conj binds [(nth b 0) (nth ir 1)])]))
[tenv []] (get node :bindings)) [tenv []] (get node :bindings))
br (infer (get node :body) (nth res 0))] br (infer (get node :body) (nth res 0) env)]
[(nth br 0) (assoc node :bindings (nth res 1) :body (nth br 1))]) [(nth br 0) (assoc node :bindings (nth res 1) :body (nth br 1))])
(= op :loop) (= op :loop)
;; conservative + sound: loop bindings join across recur, which we don't ;; conservative + sound: loop bindings join across recur, which we don't
;; track here, so they stay :any. Still descend to annotate any ;; track here, so they stay :any. Still descend to annotate any
;; known-type lookups inside the body. ;; known-type lookups inside the body.
[:any (assoc node [:any (assoc node
:bindings (mapv (fn [b] [(nth b 0) (nth (infer (nth b 1) tenv) 1)]) (get node :bindings)) :bindings (mapv (fn [b] [(nth b 0) (nth (infer (nth b 1) tenv env) 1)]) (get node :bindings))
:body (nth (infer (get node :body) tenv) 1))] :body (nth (infer (get node :body) tenv env) 1))]
(= op :recur) (= op :recur)
[:any (assoc node :args (mapv (fn [a] (nth (infer a tenv) 1)) (get node :args)))] [:any (assoc node :args (mapv (fn [a] (nth (infer a tenv env) 1)) (get node :args)))]
(= op :fn) (= op :fn)
;; a closure inherits the enclosing tenv so CAPTURED locals keep their ;; a closure inherits the enclosing tenv so CAPTURED locals keep their
;; types (e.g. a reduce closure that calls (f captured-struct ...)). Its own ;; types (e.g. a reduce closure that calls (f captured-struct ...)). Its own
@ -393,27 +390,28 @@
;; read its fields without the runtime tag guard. ;; read its fields without the runtime tag guard.
[:any (assoc node :arities [:any (assoc node :arities
(mapv (fn [a] (mapv (fn [a]
(let [phm (reduce (fn [m pr] (assoc m (nth pr 0) (nth pr 1))) (let [shapes (get env :record-shapes)
phm (reduce (fn [m pr] (assoc m (nth pr 0) (nth pr 1)))
{} (get a :phints)) {} (get a :phints))
pe (reduce (fn [e p] pe (reduce (fn [e p]
(assoc e p (assoc e p
(let [ent (get @record-shapes-box (get phm p))] (let [ent (get shapes (get phm p))]
(if ent (record-type-from-entry ent type-depth) :any)))) (if ent (record-type-from-entry ent type-depth shapes) :any))))
tenv (get a :params)) tenv (get a :params))
pe (if (get a :rest) (assoc pe (get a :rest) :any) pe)] pe (if (get a :rest) (assoc pe (get a :rest) :any) pe)]
(assoc a :body (nth (infer (get a :body) pe) 1)))) (assoc a :body (nth (infer (get a :body) pe env) 1))))
(get node :arities)))] (get node :arities)))]
(= op :def) (= op :def)
(do (when @checking? (register-user-fn! node)) (do (when (get env :checking?) (register-user-fn! node env))
[:any (assoc node :init (nth (infer (get node :init) tenv) 1))]) [:any (assoc node :init (nth (infer (get node :init) tenv env) 1))])
(= op :try) (= op :try)
[:any (assoc node [:any (assoc node
:body (nth (infer (get node :body) tenv) 1) :body (nth (infer (get node :body) tenv env) 1)
:catch-body (when (get node :catch-body) (nth (infer (get node :catch-body) tenv) 1)) :catch-body (when (get node :catch-body) (nth (infer (get node :catch-body) tenv env) 1))
:finally (when (get node :finally) (nth (infer (get node :finally) tenv) 1)))] :finally (when (get node :finally) (nth (infer (get node :finally) tenv env) 1)))]
:else [:any node]))) :else [:any node])))
(defn- infer-top [node] (nth (infer node {}) 1)) (defn- infer-top [node env] (nth (infer node {} env) 1))
;; --------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------
;; Success-type checking (RFC 0006). Reuse the inference above as a loose type ;; Success-type checking (RFC 0006). Reuse the inference above as a loose type
@ -473,15 +471,16 @@
(defn- check-invoke (defn- check-invoke
"If node is a core-op call whose argument type is provably in the error domain, "If node is a core-op call whose argument type is provably in the error domain,
conj a diagnostic. arg-types is the vector of inferred argument types; pos is conj a diagnostic into env's diags cell. arg-types is the vector of inferred
the call form's source offset, carried into each diagnostic." argument types; pos is the call form's source offset, carried into each
[cn args arg-types pos] diagnostic."
[cn args arg-types pos env]
(cond (cond
(contains? num-ops cn) (contains? num-ops cn)
(reduce (fn [_ i] (reduce (fn [_ i]
(let [t (nth arg-types i)] (let [t (nth arg-types i)]
(when (not-number? t) (when (not-number? t)
(swap! diag-box conj (swap! (get env :diags) conj
{:op cn :argpos i :type (type-name t) :pos pos {:op cn :argpos i :type (type-name t) :pos pos
:msg (str "`" cn "` requires a number, but argument " :msg (str "`" cn "` requires a number, but argument "
(inc i) " is " (type-name t))}))) (inc i) " is " (type-name t))})))
@ -490,7 +489,7 @@
(and (contains? seq-ops cn) (> (count args) 0)) (and (contains? seq-ops cn) (> (count args) 0))
(let [t (nth arg-types 0)] (let [t (nth arg-types 0)]
(when (not-seqable? t) (when (not-seqable? t)
(swap! diag-box conj (swap! (get env :diags) conj
{:op cn :argpos 0 :type (type-name t) :pos pos {:op cn :argpos 0 :type (type-name t) :pos pos
:msg (str "`" cn "` requires " :msg (str "`" cn "` requires "
(if (= cn "count") "a countable collection" "a seqable") (if (= cn "count") "a countable collection" "a seqable")
@ -504,22 +503,20 @@
(reduce (fn [e p] (assoc e p :any)) {} params)) (reduce (fn [e p] (assoc e p :any)) {} params))
(defn- isolated-diag-count (defn- isolated-diag-count
"Count of diagnostics typing body under tenv produces, with the shared "Count of diagnostics typing body under tenv produces. Runs under a SUB-ENV
diag-box saved and restored so this probe never leaks into the real report. with its own diags cell, so this probe never leaks into the real report (the
Runs the same checking inference as check-form (checking? is already on)." shared calls/escapes/guard cells are intentionally still threaded — they are
[body tenv] not read here). Runs the same checking inference as check-form."
(let [saved @diag-box] [body tenv env]
(reset! diag-box []) (let [sub (assoc env :diags (atom []))]
(infer body tenv) (infer body tenv sub)
(let [n (count @diag-box)] (count @(get sub :diags))))
(reset! diag-box saved)
n)))
(defn- register-user-fn! (defn- register-user-fn!
"Record a (def name (fn [params] body)) — single fixed arity, not redefinable — "Record a (def name (fn [params] body)) — single fixed arity, not redefinable —
for later user-fn call checking. Redefinable/dynamic and multi/variadic fns are for later user-fn call checking. Redefinable/dynamic and multi/variadic fns are
skipped (their body is not a stable requirement)." skipped (their body is not a stable requirement)."
[node] [node env]
(let [init (get node :init) (let [init (get node :init)
m (get node :meta) m (get node :meta)
redefable (and m (or (get m :redef) (get m :dynamic)))] redefable (and m (or (get m :redef) (get m :dynamic)))]
@ -528,7 +525,7 @@
(when (= 1 (count arities)) (when (= 1 (count arities))
(let [ar (first arities)] (let [ar (first arities)]
(when (not (get ar :rest)) (when (not (get ar :rest))
(swap! user-sig-box assoc (swap! (get env :user-sigs) assoc
(str (get node :ns) "/" (get node :name)) (str (get node :ns) "/" (get node :name))
{:name (get node :name) {:name (get node :name)
:params (get ar :params) :body (get ar :body)})))))))) :params (get ar :params) :body (get ar :body)}))))))))
@ -541,20 +538,22 @@
its arg type (others :any); a diagnostic the all-:any body did not already its arg type (others :any); a diagnostic the all-:any body did not already
have means the argument alone is provably wrong. Monotonic — binding a have means the argument alone is provably wrong. Monotonic — binding a
concrete type can only ADD error-domain hits — so no false positive. concrete type can only ADD error-domain hits — so no false positive.
Cycle-guarded so mutually recursive fns terminate." Cycle-guarded (env's checking-set) so mutually recursive fns terminate."
[key sig arg-types pos] [key sig arg-types pos env]
(when (not (contains? @checking-box key)) (let [cset (get env :checking-set)]
(let [prev @checking-box] (when (not (contains? @cset key))
(reset! checking-box (conj prev key)) (let [prev @cset]
(reset! cset (conj prev key))
(let [params (:params sig) (let [params (:params sig)
body (:body sig) body (:body sig)
npar (count params) npar (count params)
nargs (count arg-types)] nargs (count arg-types)
memo (get env :diag-memo)]
(if (not= npar nargs) (if (not= npar nargs)
;; arity is provably wrong regardless of types — report and stop (the ;; arity is provably wrong regardless of types — report and stop (the
;; per-arg type re-check would bind params positionally, meaningless ;; per-arg type re-check would bind params positionally, meaningless
;; under a mismatch) ;; under a mismatch)
(swap! diag-box conj (swap! (get env :diags) conj
{:op :user-call :type :arity :pos pos {:op :user-call :type :arity :pos pos
:msg (str "wrong number of args (" nargs ") passed to `" :msg (str "wrong number of args (" nargs ") passed to `"
(:name sig) "` (expected " npar ")")}) (:name sig) "` (expected " npar ")")})
@ -563,45 +562,45 @@
;; sites in this form re-infers its body at most once per (param, type). ;; sites in this form re-infers its body at most once per (param, type).
(let [base-env (all-any-env params) (let [base-env (all-any-env params)
base (let [bk [:base key]] base (let [bk [:base key]]
(if (contains? @diag-memo-box bk) (if (contains? @memo bk)
(get @diag-memo-box bk) (get @memo bk)
(let [b (isolated-diag-count body base-env)] (let [b (isolated-diag-count body base-env env)]
(swap! diag-memo-box assoc bk b) b)))] (swap! memo assoc bk b) b)))]
(reduce (reduce
(fn [_ i] (fn [_ i]
(let [at (nth arg-types i)] (let [at (nth arg-types i)]
(when (and (not= at :any) (not= at :truthy)) (when (and (not= at :any) (not= at :truthy))
(let [mk [:arg key i at] (let [mk [:arg key i at]
rejects (if (contains? @diag-memo-box mk) rejects (if (contains? @memo mk)
(get @diag-memo-box mk) (get @memo mk)
(let [r (> (isolated-diag-count body (assoc base-env (nth params i) at)) base)] (let [r (> (isolated-diag-count body (assoc base-env (nth params i) at) env) base)]
(swap! diag-memo-box assoc mk r) r))] (swap! memo assoc mk r) r))]
(when rejects (when rejects
(swap! diag-box conj (swap! (get env :diags) conj
{:op :user-call :argpos i :type (type-name at) :pos pos {:op :user-call :argpos i :type (type-name at) :pos pos
:msg (str "argument " (inc i) " to `" (:name sig) :msg (str "argument " (inc i) " to `" (:name sig)
"` is " (type-name at) "` is " (type-name at)
", which its body provably rejects")}))))) ", which its body provably rejects")})))))
nil) nil)
nil (range npar))))) nil (range npar)))))
(reset! checking-box prev)))) (reset! cset prev)))))
;; --- Inter-procedural driver API consumed by the back end ------------------- ;; --- Inter-procedural driver API consumed by the back end -------------------
(defn set-rtenv! (defn set-rtenv!
"Install the current return-type estimates (a map \"ns/name\" -> type) used to "Install the current return-type estimates (a map \"ns/name\" -> type) used to
type call results during the fixpoint." type call results during the fixpoint."
[m] (reset! rtenv-box m)) [m] (swap! config-box assoc :rtenv (or m {})))
;; install record-ctor shapes ("ns/->Name" -> [field-kw ...]) and the ;; install record-ctor shapes ("ns/->Name" -> [field-kw ...]) and the
;; map-shaping flag (opt-in JOLT_SHAPE), both read by infer. ;; map-shaping flag (opt-in JOLT_SHAPE), both read by infer.
(defn set-record-shapes! [m] (reset! record-shapes-box (or m {}))) (defn set-record-shapes! [m] (swap! config-box assoc :record-shapes (or m {})))
(defn set-protocol-methods! [m] (reset! protocol-methods-box (or m {}))) (defn set-protocol-methods! [m] (swap! config-box assoc :protocol-methods (or m {})))
(defn set-map-shapes! [b] (reset! map-shapes-box (boolean b))) (defn set-map-shapes! [b] (swap! config-box assoc :map-shapes? (boolean b)))
(defn set-vtypes! (defn set-vtypes!
"Install var VALUE types (a map \"ns/name\" -> type): fn vars are :truthy "Install var VALUE types (a map \"ns/name\" -> type): fn vars are :truthy
(non-nil), def vars carry their inferred init type." (non-nil), def vars carry their inferred init type."
[m] (reset! vtype-box m)) [m] (swap! config-box assoc :vtypes (or m {})))
(defn join-types (defn join-types
"Public structural join (lub), used by the orchestrator's fixpoint so param/ "Public structural join (lub), used by the orchestrator's fixpoint so param/
@ -623,18 +622,12 @@
def must precede its call — the same ordering RFC 0005 already assumes." def must precede its call — the same ordering RFC 0005 already assumes."
([node] (check-form node false)) ([node] (check-form node false))
([node strict?] ([node strict?]
(reset! strict-box (if strict? true false)) ;; the check IS the inference: one walk that types and emits diagnostics into
(reset! checking-box #{}) ;; this run's env. The optimization fixpoint runs with checking? false so it
(reset! diag-box []) ;; stays silent.
(reset! diag-memo-box {}) (let [env (mk-env true strict?)]
;; the check IS the inference: one walk that types and emits diagnostics (infer node {} env)
;; (jolt audit). checking? gates emission so the optimization fixpoint, which (vec @(get env :diags)))))
;; also calls infer, stays silent.
(reset! checking? true)
(infer node {})
(reset! checking? false)
(reset! strict-box false)
(vec @diag-box)))
(defn infer-body (defn infer-body
"Type `body` under tenv (local-name -> type). Returns [ret-type node' calls], "Type `body` under tenv (local-name -> type). Returns [ret-type node' calls],
@ -642,9 +635,9 @@
propagating into callee param types). Also accumulates escapes (read with propagating into callee param types). Also accumulates escapes (read with
collected-escapes after a full sweep)." collected-escapes after a full sweep)."
[body tenv] [body tenv]
(reset! calls-box []) (let [env (mk-env false false)
(let [r (infer body tenv)] r (infer body tenv env)]
[(nth r 0) (nth r 1) @calls-box])) [(nth r 0) (nth r 1) @(get env :calls)]))
(defn reinfer-def (defn reinfer-def
"Re-run inference on a stashed :def's fn arity bodies with param types seeded "Re-run inference on a stashed :def's fn arity bodies with param types seeded
@ -652,7 +645,9 @@
end emits the result directly (no further passes), so the param-typed lookups end emits the result directly (no further passes), so the param-typed lookups
keep their specialization. Used by the inter-procedural recompile." keep their specialization. Used by the inter-procedural recompile."
[def-node ptmap] [def-node ptmap]
(let [fnode (get def-node :init)] (let [fnode (get def-node :init)
env (mk-env false false)
shapes (get env :record-shapes)]
(if (= :fn (get fnode :op)) (if (= :fn (get fnode :op))
(assoc def-node :init (assoc def-node :init
(assoc fnode :arities (assoc fnode :arities
@ -664,12 +659,12 @@
;; as precise), so this only fills the gaps. ;; as precise), so this only fills the gaps.
(let [pt (reduce (fn [m pr] (let [pt (reduce (fn [m pr]
(let [nm (nth pr 0) (let [nm (nth pr 0)
e (get @record-shapes-box (nth pr 1))] e (get shapes (nth pr 1))]
(if (and e (not (contains? m nm))) (if (and e (not (contains? m nm)))
(assoc m nm (record-type-from-entry e type-depth)) (assoc m nm (record-type-from-entry e type-depth shapes))
m))) m)))
ptmap (get a :phints))] ptmap (get a :phints))]
(assoc a :body (nth (infer (get a :body) pt) 1)))) (assoc a :body (nth (infer (get a :body) pt env) 1))))
(get fnode :arities)))) (get fnode :arities))))
def-node))) def-node)))
@ -684,11 +679,12 @@
fixpoint, so a field read off it (e.g. (:origin ^Ray r)) never tells a shared fixpoint, so a field read off it (e.g. (:origin ^Ray r)) never tells a shared
callee its arg is a Vec3." callee its arg is a Vec3."
[params phints] [params phints]
(let [m (reduce (fn [acc pr] (assoc acc (nth pr 0) (nth pr 1))) {} phints)] (let [shapes (get @config-box :record-shapes)
m (reduce (fn [acc pr] (assoc acc (nth pr 0) (nth pr 1))) {} phints)]
(mapv (fn [nm] (mapv (fn [nm]
(let [ck (get m nm) (let [ck (get m nm)
e (and ck (get @record-shapes-box ck))] e (and ck (get shapes ck))]
(when e (record-type-from-entry e type-depth)))) (when e (record-type-from-entry e type-depth shapes))))
params))) params)))
;; Piggyback checking (jolt audit). In direct-link mode infer-top already runs ;; Piggyback checking (jolt audit). In direct-link mode infer-top already runs
@ -698,27 +694,22 @@
;; run-passes and reads take-diags! after. It checks the POST-optimization IR, ;; run-passes and reads take-diags! after. It checks the POST-optimization IR,
;; which matches what the optimized program actually evaluates (scalar-replace ;; which matches what the optimized program actually evaluates (scalar-replace
;; only drops provably-pure code, an accepted opt-mode divergence). ;; only drops provably-pure code, an accepted opt-mode divergence).
(def ^:private check-mode-box (atom {:on false :strict false}))
(defn set-check-mode! (defn set-check-mode!
"Enable/disable checking during the next run-passes inference (direct-link)." "Enable/disable checking during the next run-passes inference (direct-link)."
[on strict?] (reset! check-mode-box {:on (if on true false) :strict (if strict? true false)})) [on strict?] (reset! check-mode-box {:on (if on true false) :strict (if strict? true false)}))
(defn take-diags! (defn take-diags!
"Diagnostics accumulated by the last checking run-passes; clears the buffer." "Diagnostics accumulated by the last checking run-passes; clears the buffer."
[] (let [d (vec @diag-box)] (reset! diag-box []) d)) [] (let [d @last-diags-box] (reset! last-diags-box []) d))
(defn run-inference (defn run-inference
"Type-infer the optimized node (the inference walk specializes struct-safe "Type-infer the optimized node (the inference walk specializes struct-safe
lookups). When check mode is on (set-check-mode!), the same walk also emits lookups). When check mode is on (set-check-mode!), the same walk also emits
success-type diagnostics into the buffer take-diags! drains afterward. Pulled success-type diagnostics, stashed for take-diags! to drain afterward. Pulled
out of run-passes so the checking state stays private to this namespace." out of run-passes so the checking state stays private to this namespace."
[opt] [opt]
(if (get @check-mode-box :on) (if (get @check-mode-box :on)
(do (reset! diag-box []) (let [env (mk-env true (get @check-mode-box :strict))
(reset! checking-box #{}) r (infer-top opt env)]
(reset! strict-box (get @check-mode-box :strict)) (reset! last-diags-box @(get env :diags))
(reset! checking? true) r)
(let [r (infer-top opt)] (infer-top opt (mk-env false false))))
(reset! checking? false)
(reset! strict-box false)
r))
(infer-top opt)))