diff --git a/jolt-core/jolt/passes.clj b/jolt-core/jolt/passes.clj index 6887b82..3793b3e 100644 --- a/jolt-core/jolt/passes.clj +++ b/jolt-core/jolt/passes.clj @@ -875,6 +875,15 @@ ;; provably wrong and the CALL is reported. Module state, like rtenv-box: a def ;; must precede its call (the same closed-world ordering RFC 0005 assumes). (def ^:private user-sig-box (atom {})) ;; "ns/name" -> {:params [..] :body ir} +;; jolt-t34: a record constructor's return shape. "ns/->Name" -> [field-kw ...] +;; in DECLARED order (the runtime lays records out in declared field order, so +;; the back end bare-indexes by that order). A call (->Point a b) types as a +;; struct of this shape, so field reads on the result bare-index — declared +;; shapes are clean fuel: a lookup, not fragile inference. +(def ^:private record-shapes-box (atom {})) +;; jolt-t34: 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? ;; When true, `infer` emits success-type diagnostics as it types (jolt audit). @@ -897,12 +906,18 @@ (let [op (get fnode :op)] (cond ;; a user fn whose return type the fixpoint has estimated - (= op :var) (let [r (get @rtenv-box (var-key fnode))] - (if r r (let [nm (and (= "clojure.core" (get fnode :ns)) (get fnode :name))] - (cond (nil? nm) :any - (contains? num-ret-fns nm) :num - (contains? vector-ret-fns nm) (mk-vec :any) - :else :any)))) + (= op :var) (let [rs (get @record-shapes-box (var-key fnode))] + (if rs + ;; record ctor -> struct of declared shape (jolt-t34); :shape + ;; is the DECLARED field order, which the back end indexes by + (assoc (mk-struct (reduce (fn [m k] (assoc m k :any)) {} rs)) + :shape (vec rs)) + (let [r (get @rtenv-box (var-key fnode))] + (if r r (let [nm (and (= "clojure.core" (get fnode :ns)) (get fnode :name))] + (cond (nil? nm) :any + (contains? num-ret-fns nm) :num + (contains? vector-ret-fns nm) (mk-vec :any) + :else :any)))))) (= op :host) (let [nm (get fnode :name)] (cond (contains? num-ret-fns nm) :num (contains? vector-ret-fns nm) (mk-vec :any) @@ -976,7 +991,7 @@ (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 ;; back end can lay it out and bare-index lookups (jolt-t34) - shp (when (and base (struct-type? base)) (shape-order (keys (sfields base)))) + shp (when (and @map-shapes-box base (struct-type? base)) (shape-order (keys (sfields base)))) 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))] [t (if shp (assoc node' :shape shp) node')]) @@ -1312,6 +1327,11 @@ type call results during the fixpoint." [m] (reset! rtenv-box m)) +;; jolt-t34: install record-ctor shapes ("ns/->Name" -> [field-kw ...]) and the +;; map-shaping flag (opt-in JOLT_SHAPE), both read by infer. +(defn set-record-shapes! [m] (reset! record-shapes-box (or m {}))) +(defn set-map-shapes! [b] (reset! map-shapes-box (boolean b))) + (defn set-vtypes! "Install var VALUE types (a map \"ns/name\" -> type): fn vars are :truthy (non-nil), def vars carry their inferred init type (jolt-d6u)." diff --git a/src/jolt/api.janet b/src/jolt/api.janet index 8e89e63..dd6fa75 100644 --- a/src/jolt/api.janet +++ b/src/jolt/api.janet @@ -223,11 +223,15 @@ # the inline pass only inlines targets that won't be redefined, the same # safety the direct-linking flag asserts (jolt-87f). (put (ctx :env) :inline? (if (get (ctx :env) :direct-linking?) true false)) - # Shape-records are OPT-IN (jolt-t34). Measurement showed shaping generic - # const-key maps net-loses in a bytecode VM (unproven reads can't beat a - # native struct-get), so shapes are not defaulted on. The win is records - # with declared shapes + proven reads; that path is enabled separately. + # jolt-t34. Two shape gates: + # :shapes? — shape-recs are active. Records use declared-shape layout + + # bare-index reads here. ON wherever the inference that proves + # reads runs = direct-linking. JOLT_NO_SHAPE force-disables. + # :map-shapes? — also shape generic const-key MAP literals. Opt-in (JOLT_SHAPE) + # because shaping maps net-loses on unproven reads; records win. (put (ctx :env) :shapes? + (and (get (ctx :env) :direct-linking?) (not (os/getenv "JOLT_NO_SHAPE")))) + (put (ctx :env) :map-shapes? (and (os/getenv "JOLT_SHAPE") (not (os/getenv "JOLT_NO_SHAPE")))) ctx)) diff --git a/src/jolt/backend.janet b/src/jolt/backend.janet index 3187d8a..b8e8d8f 100644 --- a/src/jolt/backend.janet +++ b/src/jolt/backend.janet @@ -370,15 +370,15 @@ "(a phm/sorted/transient/lazy-seq), not the plain " "struct/record the ^:struct/^Record hint asserts")])) # Subject carries a complete :shape (jolt-t34) => it is provably a shape-rec; - # the field reads by bare index. The :shape is just the KEY SET; the layout - # comes from the runtime's canonical shape-sort (the same order shape-for and - # emit-map use), so construction and lookup always agree. + # the field reads by bare index. The :shape vector is ALREADY in layout order — + # declared order for records (record-shape-for), str-sorted for map literals + # (the inference's shape-order, matching emit-map) — so the field's position in + # :shape IS its slot. (:shapes? = shapes active = direct-link.) (def sidx (when (and (get (ctx :env) :shapes?) subj-node (subj-node :shape)) (def raw (let [s (subj-node :shape)] (if (pv/pvec? s) (pv/pv->array s) s))) - (def sk (shape-sort raw)) (var pos nil) (var i 0) - (each kk sk (when (= kk k) (set pos i)) (++ i)) + (each kk raw (when (= kk k) (set pos i)) (++ i)) (when pos (+ pos 1)))) # sidx => proven complete shape: bare index (fastest). Otherwise a raw-get-safe # value may still be a shape-rec (its :shape dropped by a join, or an unproven @@ -507,7 +507,7 @@ # compiler's own IR-node map literals (which the back end reads with raw # keyword access and would break if turned into tuples) (def shape-keys - (when (and fast (get (ctx :env) :shapes?) (get (ctx :env) :inline?)) + (when (and fast (get (ctx :env) :map-shapes?) (get (ctx :env) :inline?)) (def ks @[]) (each pair pairs (array/push ks ((norm-node (in (vview pair) 0)) :val))) (shape-sort ks))) @@ -945,6 +945,8 @@ (def f-infer-body (and pns (ns-find pns "infer-body"))) (def f-reinfer (and pns (ns-find pns "reinfer-def"))) (def f-reset-esc (and pns (ns-find pns "reset-escapes!"))) + (def f-set-rshapes (and pns (ns-find pns "set-record-shapes!"))) # jolt-t34 + (def f-set-mshapes (and pns (ns-find pns "set-map-shapes!"))) # jolt-t34 (def f-get-esc (and pns (ns-find pns "collected-escapes"))) (def ns (ctx-find-ns ctx ns-name)) (def report @{}) @@ -976,6 +978,9 @@ (array/push defs @{:key key :init (d :init) :vt nil})))) (when (or (> (length fns) 0) (> (length defs) 0)) ((var-get f-reset-esc)) + # jolt-t34: feed record-ctor shapes + the map-shaping flag to the inference + (when f-set-rshapes ((var-get f-set-rshapes) (or (get (ctx :env) :record-shapes) @{}))) + (when f-set-mshapes ((var-get f-set-mshapes) (get (ctx :env) :map-shapes?))) # --- param/return/value-type fixpoint (chaotic iteration to LEAST fixpoint) --- # Param types are RECOMPUTED FRESH each iteration, not accumulated: :any is # the lattice top, so a join with an early-iteration :any (a caller whose own diff --git a/src/jolt/evaluator.janet b/src/jolt/evaluator.janet index b90ffc7..cfe20c6 100644 --- a/src/jolt/evaluator.janet +++ b/src/jolt/evaluator.janet @@ -1368,11 +1368,18 @@ [ctx type-name-sym field-kws] (def type-tag (string (ctx-current-ns ctx) "." (type-name-sym :name))) (def kws (d-realize field-kws)) - # Records become shape-recs only under JOLT_SHAPE (jolt-t34 R3) — part of the - # shape feature, which the whole field-access pipeline handles. With the flag - # off, records are the original :jolt/deftype tables. Read the flag at ctor- - # BUILD time (deftype eval) so a type is consistently one rep or the other. - (if (os/getenv "JOLT_SHAPE") + # jolt-t34: register this record's ctor return shape (DECLARED field order) so + # the inference types (->Name ...) as a struct of these fields and field reads + # on the result bare-index. Keyed by the ctor var-key "ns/->Name" to match how + # the IR names the call head. Harmless when records aren't shaped (sidx gated). + (let [rs (or (get (ctx :env) :record-shapes) + (let [t @{}] (put (ctx :env) :record-shapes t) t))] + (put rs (string (ctx-current-ns ctx) "/->" (type-name-sym :name)) (tuple ;kws))) + # Records are shape-recs when shapes are active (:shapes? = direct-link, where + # the inference proves the reads) — the whole field-access pipeline handles + # them; otherwise the original :jolt/deftype tables. Read at ctor-BUILD time so + # a type is consistently one representation or the other. + (if (get (ctx :env) :shapes?) (fn [& args] (make-record type-tag kws args)) (fn [& args] (var inst @{:jolt/deftype type-tag}) diff --git a/src/jolt/main.janet b/src/jolt/main.janet index 4b53bab..fdce089 100644 --- a/src/jolt/main.janet +++ b/src/jolt/main.janet @@ -506,9 +506,13 @@ (when (= "1" (os/getenv "JOLT_DIRECT_LINK")) (put (ctx :env) :direct-linking? true) (put (ctx :env) :inline? true)) - # Recompute :shapes? from the runtime env (the baked ctx computed it at build - # time, before JOLT_SHAPE was set in this process). Opt-in (jolt-t34). + # Recompute the shape gates from the runtime env (the baked ctx computed them + # at build time, before JOLT_DIRECT_LINK/JOLT_SHAPE were set here). jolt-t34: + # :shapes? = shape-recs active (records), on with direct-linking; :map-shapes? = + # also shape generic maps (opt-in JOLT_SHAPE). (put (ctx :env) :shapes? + (and (get (ctx :env) :direct-linking?) (not (os/getenv "JOLT_NO_SHAPE")))) + (put (ctx :env) :map-shapes? (and (os/getenv "JOLT_SHAPE") (not (os/getenv "JOLT_NO_SHAPE")))) (cond (empty? argv) (run-repl) diff --git a/src/jolt/types.janet b/src/jolt/types.janet index 93587d9..998376b 100644 --- a/src/jolt/types.janet +++ b/src/jolt/types.janet @@ -674,10 +674,16 @@ (let [idx @{}] (var i 0) (each k field-keys (put idx k i) (++ i)) (struct :jolt/shape (tuple ;field-keys) :idx (table/to-struct idx) :type type-tag))) +# Interned per (type-tag, field-keys): keying on the tag alone would hand back a +# STALE descriptor after a record is redefined with different fields (a REPL +# redefine, or two same-named records in different test cases) — the new instance +# would carry the old layout. Old instances keep their own descriptor and stay +# valid; new ones get the new layout. (jolt-t34) (defn record-shape-for [type-tag field-keys] - (or (get record-desc-cache type-tag) + (def ck (tuple type-tag (tuple ;field-keys))) + (or (get record-desc-cache ck) (let [desc (record-desc type-tag field-keys)] - (put record-desc-cache type-tag desc) + (put record-desc-cache ck desc) desc))) (defn make-record [type-tag field-keys args] (def out @[(record-shape-for type-tag field-keys)]) diff --git a/test/integration/record-declared-shape-test.janet b/test/integration/record-declared-shape-test.janet new file mode 100644 index 0000000..5171f47 --- /dev/null +++ b/test/integration/record-declared-shape-test.janet @@ -0,0 +1,39 @@ +# Records use declared-shape layout with fast field access (jolt-t34), by default +# in a direct-linking unit — no JOLT_SHAPE needed. The key property: a record is +# laid out in DECLARED field order, and field reads bare-index by that order, so +# fields that are NOT alphabetically sorted must still read correctly. This is +# what `sidx` reads off the :shape vector (declared order, not str-sorted). +(use ../../src/jolt/api) + +(var failures 0) +(defn- check [label got want] + (unless (= got want) + (++ failures) + (printf "FAIL [%s] got %q want %q" label got want))) + +# A direct-linking ctx: records are shape-recs, reads proven/bare-indexed. +(def dl (init {:compile? true :direct-linking? true})) + +# --- representation: a record is a shape-rec (tuple), not a table ------------- +(check "record is a shape-rec" + (tuple? (eval-string dl "(do (defrecord Sp [x y]) (->Sp 1 2))")) true) + +# --- DECLARED-ORDER field access: fields are NOT alphabetically sorted; each +# must read its own value, locally and through a fn boundary. Each case uses a +# DISTINCT record name (redefining a record with new fields is jolt-wf4). ------- +(def cases + [["decl-order local" "(do (defrecord Ra [b a c]) (let [r (->Ra 10 20 30)] (= [10 20 30] [(:b r) (:a r) (:c r)])))"] + ["decl-order via fn" "(do (defrecord Rb [b a c]) (defn rdb [r] [(:b r) (:a r) (:c r)]) (= [10 20 30] (rdb (->Rb 10 20 30))))"] + ["single field z-first" "(do (defrecord Rc [z m a]) (= 7 (:z (->Rc 7 8 9))))"] + ["protocol method body" "(do (defprotocol Sh (area [s])) (defrecord Box [w h] Sh (area [b] (* (:w b) (:h b)))) (= 12 (area (->Box 3 4))))"] + ["record? true" "(do (defrecord Rd [x y]) (record? (->Rd 1 2)))"] + ["record vs map not=" "(do (defrecord Re [x y]) (not (= (->Re 1 2) {:x 1 :y 2})))"] + ["assoc keeps type" "(do (defrecord Rf [x y]) (record? (assoc (->Rf 1 2) :x 9)))"] + ["pr declared order" "(do (defrecord Rg [b a c]) (= \"#user.Rg{:b 10, :a 20, :c 30}\" (pr-str (->Rg 10 20 30))))"]]) + +(each [label prog] cases + (check label (eval-string dl prog) true)) + +(if (pos? failures) + (do (printf "record-declared-shape: %d failure(s)" failures) (os/exit 1)) + (print "record-declared-shape: all cases passed"))