Support mutable deftype fields under shapes (jolt-c3q) (#125)
A deftype field tagged ^:unsynchronized-mutable / ^:volatile-mutable is set!-able,
but under direct-link immutable records are shape-rec tuples, so set! errored
("Can't set! field on non-deftype: tuple").
A deftype with any mutable field now opts out of the shape-rec layout and uses
the existing :jolt/deftype table form regardless of :shapes? — set! already
mutates that form and field reads route through the tagged-table path. Such a
type is also not registered as a shape, so the inference never emits a bare-index
read against the table. Immutable deftypes/records keep the fast shape-rec.
deftype extracts per-field mutability from the field metadata and passes it to
make-deftype-ctor, which picks the representation at ctor-build time.
Co-authored-by: Yogthos <yogthos@gmail.com>
This commit is contained in:
parent
8ee04eed8e
commit
d200725811
3 changed files with 82 additions and 8 deletions
|
|
@ -295,6 +295,15 @@
|
||||||
(and mt (:num mt)) "num"
|
(and mt (:num mt)) "num"
|
||||||
:else nil)))
|
:else nil)))
|
||||||
fields)
|
fields)
|
||||||
|
;; per-field MUTABILITY (jolt-c3q): ^:unsynchronized-mutable / ^:volatile-
|
||||||
|
;; mutable marks a field set!-able. A type with any mutable field opts out
|
||||||
|
;; of the immutable shape-rec layout and uses the mutable table form, so
|
||||||
|
;; set! can mutate it (the ctor reads this vector). Spliced as a literal.
|
||||||
|
field-muts (map (fn [f] (let [mt (meta f)]
|
||||||
|
(if (and mt (or (:unsynchronized-mutable mt)
|
||||||
|
(:volatile-mutable mt)))
|
||||||
|
true false)))
|
||||||
|
fields)
|
||||||
impl (fn [proto specs]
|
impl (fn [proto specs]
|
||||||
`(extend-type ~tname ~proto
|
`(extend-type ~tname ~proto
|
||||||
~@(map (fn [spec]
|
~@(map (fn [spec]
|
||||||
|
|
@ -304,7 +313,7 @@
|
||||||
`(~(first spec) ~argv (let [~@binds] ~@(drop 2 spec)))))
|
`(~(first spec) ~argv (let [~@binds] ~@(drop 2 spec)))))
|
||||||
specs)))]
|
specs)))]
|
||||||
`(do
|
`(do
|
||||||
(def ~tname (make-deftype-ctor (quote ~tname) [~@field-kws] [~@field-tags]))
|
(def ~tname (make-deftype-ctor (quote ~tname) [~@field-kws] [~@field-tags] [~@field-muts]))
|
||||||
(def ~arrow ~tname)
|
(def ~arrow ~tname)
|
||||||
~@(map (fn [g] (impl (first g) (rest g))) (group-by-head body))
|
~@(map (fn [g] (impl (first g) (rest g))) (group-by-head body))
|
||||||
~tname)))
|
~tname)))
|
||||||
|
|
|
||||||
|
|
@ -385,20 +385,26 @@
|
||||||
instances carry a stable tag matching what extend-type registers methods under.
|
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
|
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."
|
those keys. A ctx-capturing closure (make-deftype-ctor) is the public handle."
|
||||||
[ctx type-name-sym field-kws &opt field-tags]
|
[ctx type-name-sym field-kws &opt field-tags field-muts]
|
||||||
(def type-tag (string (ctx-current-ns ctx) "." (type-name-sym :name)))
|
(def type-tag (string (ctx-current-ns ctx) "." (type-name-sym :name)))
|
||||||
(def kws (d-realize field-kws))
|
(def kws (d-realize field-kws))
|
||||||
# per-field type hints (jolt-3ko): a tuple parallel to kws — "Vec3" (a record
|
# 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 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).
|
# 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))))
|
(def tags (if field-tags (d-realize field-tags) (array/new-filled (length kws))))
|
||||||
|
# jolt-c3q: a type with any ^:unsynchronized-mutable / ^:volatile-mutable field
|
||||||
|
# is set!-able, so it CAN'T be an immutable shape-rec tuple. Such a type uses
|
||||||
|
# the mutable :jolt/deftype table form regardless of :shapes? (set! mutates it,
|
||||||
|
# field reads route through the tagged-table path), and is NOT registered as a
|
||||||
|
# shape so the inference never emits a bare-index read against the table.
|
||||||
|
(def mutable? (and field-muts (some |(identity $) (d-realize field-muts))))
|
||||||
# The ctor closure itself. Built FIRST so it can be indexed by value below.
|
# The ctor closure itself. Built FIRST so it can be indexed by value below.
|
||||||
# Records are shape-recs when shapes are active (:shapes? = direct-link, where
|
# Records are shape-recs when shapes are active (:shapes? = direct-link, where
|
||||||
# the inference proves the reads) — the whole field-access pipeline handles
|
# the inference proves the reads) — the whole field-access pipeline handles
|
||||||
# them; otherwise the original :jolt/deftype tables. Read at ctor-BUILD time so
|
# them; otherwise (or when mutable) the original :jolt/deftype tables. Read at
|
||||||
# a type is consistently one representation or the other.
|
# ctor-BUILD time so a type is consistently one representation or the other.
|
||||||
(def the-ctor
|
(def the-ctor
|
||||||
(if (get (ctx :env) :shapes?)
|
(if (and (get (ctx :env) :shapes?) (not mutable?))
|
||||||
(fn [& args] (make-record type-tag kws args))
|
(fn [& args] (make-record type-tag kws args))
|
||||||
(fn [& args]
|
(fn [& args]
|
||||||
(var inst @{:jolt/deftype type-tag})
|
(var inst @{:jolt/deftype type-tag})
|
||||||
|
|
@ -408,6 +414,8 @@
|
||||||
# the inference types (->Name ...) as a struct of these fields and field reads
|
# 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
|
# 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).
|
# the IR names the call head. Harmless when records aren't shaped (sidx gated).
|
||||||
|
# Skipped for mutable types — they're tables, not shape-recs (jolt-c3q).
|
||||||
|
(unless mutable?
|
||||||
(let [rs (or (get (ctx :env) :record-shapes)
|
(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))
|
||||||
# ctor-value index: maps each ctor closure to its rs key, so a ^Type hint
|
# ctor-value index: maps each ctor closure to its rs key, so a ^Type hint
|
||||||
|
|
@ -428,7 +436,7 @@
|
||||||
tags)]
|
tags)]
|
||||||
(put rs (string (ctx-current-ns ctx) "/->" (type-name-sym :name))
|
(put rs (string (ctx-current-ns ctx) "/->" (type-name-sym :name))
|
||||||
{:fields (tuple ;kws) :type type-tag :tags (tuple ;resolved)})
|
{:fields (tuple ;kws) :type type-tag :tags (tuple ;resolved)})
|
||||||
(put cix the-ctor (string (ctx-current-ns ctx) "/->" (type-name-sym :name))))
|
(put cix the-ctor (string (ctx-current-ns ctx) "/->" (type-name-sym :name)))))
|
||||||
the-ctor)
|
the-ctor)
|
||||||
|
|
||||||
(defn install-stateful-fns!
|
(defn install-stateful-fns!
|
||||||
|
|
@ -504,7 +512,7 @@
|
||||||
(ns-intern core "refer-clojure" (fn [& args] (refer-clojure-impl ctx ;args)))
|
(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 "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 "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 &opt field-tags] (make-deftype-ctor-impl ctx name-sym field-kws field-tags)))
|
(ns-intern core "make-deftype-ctor" (fn [name-sym field-kws &opt field-tags field-muts] (make-deftype-ctor-impl ctx name-sym field-kws field-tags field-muts)))
|
||||||
# Var/namespace lookups that need the ctx (the rest of the var fns — var-get/
|
# 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).
|
# 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)))
|
(ns-intern core "find-var" (fn [sym] (find-var ctx sym)))
|
||||||
|
|
|
||||||
57
test/integration/mutable-deftype-test.janet
Normal file
57
test/integration/mutable-deftype-test.janet
Normal file
|
|
@ -0,0 +1,57 @@
|
||||||
|
# Mutable deftype fields under shapes/direct-link (jolt-c3q).
|
||||||
|
#
|
||||||
|
# A deftype field tagged ^:unsynchronized-mutable / ^:volatile-mutable is set! at
|
||||||
|
# runtime. Immutable records are shape-recs (immutable tuples) where shapes are
|
||||||
|
# active (direct-link), so set! can't mutate them. A deftype with ANY mutable
|
||||||
|
# field opts out of the shape-rec layout and uses the mutable table form (which
|
||||||
|
# set! already mutates and field reads route through), regardless of :shapes?.
|
||||||
|
# Immutable deftypes/records keep the fast shape-rec.
|
||||||
|
|
||||||
|
(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)))
|
||||||
|
|
||||||
|
# direct-linking? true => :shapes? on (the mode where immutable records are
|
||||||
|
# tuples and this used to error "Can't set! field on non-deftype: tuple").
|
||||||
|
(let [ctx (init {:compile? true :direct-linking? true})]
|
||||||
|
(eval-string ctx "(deftype Counter [^:unsynchronized-mutable n])")
|
||||||
|
(eval-string ctx "(def c (->Counter 0))")
|
||||||
|
(check "read initial mutable field" (eval-string ctx "(.-n c)") 0)
|
||||||
|
(eval-string ctx "(set! (.-n c) 5)")
|
||||||
|
(check "read after set!" (eval-string ctx "(.-n c)") 5)
|
||||||
|
(eval-string ctx "(set! (.-n c) (inc (.-n c)))")
|
||||||
|
(check "set! using prior value" (eval-string ctx "(.-n c)") 6)
|
||||||
|
# keyword access reads the same mutated field
|
||||||
|
(check "keyword access sees mutation" (eval-string ctx "(:n c)") 6))
|
||||||
|
|
||||||
|
# Mixed mutable + immutable fields: a method reads both, set! touches the mutable.
|
||||||
|
(let [ctx (init {:compile? true :direct-linking? true})]
|
||||||
|
(eval-string ctx "(deftype Cell [label ^:unsynchronized-mutable v] Object (toString [_] (str label \"=\" v)))")
|
||||||
|
(eval-string ctx "(def cell (->Cell \"x\" 1))")
|
||||||
|
(check "immutable field reads" (eval-string ctx "(.-label cell)") "x")
|
||||||
|
(check "custom toString before" (eval-string ctx "(str cell)") "x=1")
|
||||||
|
(eval-string ctx "(set! (.-v cell) 42)")
|
||||||
|
(check "mutable field after set!" (eval-string ctx "(.-v cell)") 42)
|
||||||
|
(check "custom toString after mutation" (eval-string ctx "(str cell)") "x=42")
|
||||||
|
(check "immutable field unchanged" (eval-string ctx "(.-label cell)") "x"))
|
||||||
|
|
||||||
|
# volatile-mutable is treated the same (also a mutable field).
|
||||||
|
(let [ctx (init {:compile? true :direct-linking? true})]
|
||||||
|
(eval-string ctx "(deftype Box [^:volatile-mutable x])")
|
||||||
|
(eval-string ctx "(def b (->Box :a))")
|
||||||
|
(eval-string ctx "(set! (.-x b) :z)")
|
||||||
|
(check "volatile-mutable set!" (eval-string ctx "(.-x b)") :z))
|
||||||
|
|
||||||
|
# An all-immutable deftype/record is unaffected: still a shape-rec, fast reads.
|
||||||
|
(let [ctx (init {:compile? true :direct-linking? true})]
|
||||||
|
(eval-string ctx "(defrecord Pt [x y])")
|
||||||
|
(check "immutable record reads" (eval-string ctx "(:x (->Pt 3 4))") 3)
|
||||||
|
(check "immutable record reads y" (eval-string ctx "(:y (->Pt 3 4))") 4))
|
||||||
|
|
||||||
|
(if (pos? failures)
|
||||||
|
(do (printf "mutable-deftype: %d failure(s)" failures) (os/exit 1))
|
||||||
|
(print "mutable-deftype: all cases passed"))
|
||||||
Loading…
Add table
Add a link
Reference in a new issue