diff --git a/jolt-core/clojure/core/30-macros.clj b/jolt-core/clojure/core/30-macros.clj index dc54a97..118f80e 100644 --- a/jolt-core/clojure/core/30-macros.clj +++ b/jolt-core/clojure/core/30-macros.clj @@ -286,6 +286,15 @@ ;; a seq of field keywords; spliced into a vector LITERAL below ([~@…]) so ;; the analyzer sees a vector form, not a runtime pvec value. field-kws (map (fn [f] (keyword (name f))) fields) + ;; per-field TYPE HINT (jolt-3ko): ^Vec3 origin -> "Vec3" (a record type + ;; name), ^:num x -> "num", else nil. Lets the inference know a field's + ;; exact type up front, so reading it back carries that type (not :any) — + ;; the key to fast nested-record code. Spliced as a vector literal too. + field-tags (map (fn [f] (let [mt (meta f)] + (cond (and mt (:tag mt)) (:tag mt) + (and mt (:num mt)) "num" + :else nil))) + fields) impl (fn [proto specs] `(extend-type ~tname ~proto ~@(map (fn [spec] @@ -295,7 +304,7 @@ `(~(first spec) ~argv (let [~@binds] ~@(drop 2 spec))))) specs)))] `(do - (def ~tname (make-deftype-ctor (quote ~tname) [~@field-kws])) + (def ~tname (make-deftype-ctor (quote ~tname) [~@field-kws] [~@field-tags])) (def ~arrow ~tname) ~@(map (fn [g] (impl (first g) (rest g))) (group-by-head body)) ~tname))) diff --git a/jolt-core/jolt/passes.clj b/jolt-core/jolt/passes.clj index ad08082..ae85dc3 100644 --- a/jolt-core/jolt/passes.clj +++ b/jolt-core/jolt/passes.clj @@ -884,6 +884,27 @@ ;; jolt-41m: 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 {})) + +;; jolt-3ko: build a record's struct TYPE from its registry entry, resolving each +;; field's declared type hint. 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) +(defn- field-type-from-tag [tag depth] + (cond + (or (nil? tag) (<= depth 0)) :any + (= tag "num") :num + :else (let [e (get @record-shapes-box tag)] + (if e (record-type-from-entry e depth) :any)))) +(defn- record-type-from-entry [rs depth] + (let [fields (get rs :fields) + tags (get rs :tags) + fmap (reduce (fn [m i] + (assoc m (nth fields i) + (field-type-from-tag (when tags (nth tags i)) (dec depth)))) + {} (range (count fields)))] + (assoc (mk-struct fmap) :shape (vec fields) :type (get rs :type)))) ;; 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)) @@ -912,11 +933,10 @@ (= 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 the back end indexes by, and - ;; :type is the record tag (for devirtualizing protocol calls) - (let [fields (get rs :fields)] - (assoc (mk-struct (reduce (fn [m k] (assoc m k :any)) {} fields)) - :shape (vec fields) :type (get rs :type))) + ;; is the DECLARED field order the back end indexes by, :type + ;; the record tag (devirt), and field types come from the + ;; declared hints so nested records stay typed (jolt-3ko) + (record-type-from-entry rs type-depth) (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 diff --git a/src/jolt/evaluator.janet b/src/jolt/evaluator.janet index df84c71..a2ec702 100644 --- a/src/jolt/evaluator.janet +++ b/src/jolt/evaluator.janet @@ -1372,17 +1372,30 @@ instances carry a stable tag matching what extend-type registers methods under. field-kws is the [:f1 :f2 …] keyword vector; the ctor maps positional args to those keys. A ctx-capturing closure (make-deftype-ctor) is the public handle." - [ctx type-name-sym field-kws] + [ctx type-name-sym field-kws &opt field-tags] (def type-tag (string (ctx-current-ns ctx) "." (type-name-sym :name))) (def kws (d-realize field-kws)) + # per-field type hints (jolt-3ko): a tuple parallel to kws — "Vec3" (a record + # type name), "num", or nil. The inference resolves these to the field's exact + # type so reading a field back carries it (a nested record stays typed). + (def tags (if field-tags (d-realize field-tags) (array/new-filled (length kws)))) # 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))] + (let [t @{}] (put (ctx :env) :record-shapes t) t)) + # resolve a record-typed hint ("Vec3") to its ctor-key ("ns/->Vec3") so + # the inference resolves it with a direct lookup. "num" stays as-is; an + # unresolved name (cross-ns / not-yet-defined) stays bare -> :any. + resolved (map (fn [t] + (cond (nil? t) nil + (= t "num") "num" + (let [ck (string (ctx-current-ns ctx) "/->" t)] + (if (get rs ck) ck t)))) + tags)] (put rs (string (ctx-current-ns ctx) "/->" (type-name-sym :name)) - {:fields (tuple ;kws) :type type-tag})) + {:fields (tuple ;kws) :type type-tag :tags (tuple ;resolved)})) # 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 @@ -1467,7 +1480,7 @@ (ns-intern core "refer-clojure" (fn [& args] (refer-clojure-impl ctx ;args))) (ns-intern core "defmulti-setup" (fn [name-sym dispatch & opts] (defmulti-setup ctx name-sym dispatch ;opts))) (ns-intern core "defmethod-setup" (fn [mm-sym dval impl] (defmethod-setup ctx mm-sym dval impl))) - (ns-intern core "make-deftype-ctor" (fn [name-sym field-kws] (make-deftype-ctor-impl ctx name-sym field-kws))) + (ns-intern core "make-deftype-ctor" (fn [name-sym field-kws &opt field-tags] (make-deftype-ctor-impl ctx name-sym field-kws field-tags))) # Var/namespace lookups that need the ctx (the rest of the var fns — var-get/ # var-set/var?/alter-var-root/alter-meta!/reset-meta! — are plain core-bindings). (ns-intern core "find-var" (fn [sym] (find-var ctx sym)))