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

delay exception memoization, deftype cross-protocol method merge, more map-like dispatch

Browse source 
Further clojure.core.cache fixes (198 -> 257 of its assertions):

- delay: a throwing body re-ran on every force and never became realized?. Run it
  once like Clojure's Delay — cache the exception, mark realized, re-throw the same
  on each deref. Fixes value-fn memoization / cache-stampede protection.
- deftype/defrecord: a method name appearing in two protocols with different
  arities (data.priority-map's seq is in IPersistentMap [this] AND Sorted
  [this asc]) registered per-protocol and shadowed; merge clauses by name across
  all protocols into one multi-arity fn.
- empty?/peek/pop (IPersistentStack) dispatch through a deftype's methods; (= a-
  deftype other) uses its equiv method (so caches compare to their backing map);
  seq handles a host iterator (iterator-seq over .iterator).
- pop of an empty PersistentQueue returns it, like the JVM (was an error).

JVM-certified corpus rows. make test + shakesmoke green.
This commit is contained in:
Yogthos 2026-06-25 10:57:31 -04:00
parent c445aaeaa2
commit 5d0989a860
7 changed files with 614 additions and 581 deletions
Download patch file Download diff file Expand all files Collapse all files

14
host/chez/concurrency.ss
View file

@ -228,15 +228,21 @@
;; (delay body) -> (make-delay (fn [] body)) (overlay macro); force/deref run the
;; thunk once under a lock and cache the value (JVM delays are thread-safe). force
;; (overlay) is (if (delay? x) (deref x) x), so it works once delay?/deref do.
(define-record-type jolt-delay (fields thunk (mutable realized?) (mutable value) mu)
(define-record-type jolt-delay (fields thunk (mutable realized?) (mutable value) (mutable exn) mu)
(nongenerative jolt-delay-v1))
(define (jolt-make-delay thunk) (make-jolt-delay thunk #f jolt-nil (make-mutex)))
(define (jolt-make-delay thunk) (make-jolt-delay thunk #f jolt-nil #f (make-mutex)))
;; run the thunk once, like Clojure's Delay: if it throws, cache the exception
;; (the delay IS realized) and re-throw it on every deref — do NOT re-run the
;; body (so value-fns memoize and there is no cache-stampede / retried side
;; effect). Store the exception inside the lock, re-raise outside it so the mutex
;; is always released.
(define (jolt-delay-force d)
(with-mutex (jolt-delay-mu d)
(unless (jolt-delay-realized? d)
(guard (e (#t (jolt-delay-exn-set! d e) (jolt-delay-realized?-set! d #t)))
(jolt-delay-value-set! d (jolt-invoke (jolt-delay-thunk d)))
(jolt-delay-realized?-set! d #t)))
(jolt-delay-value d))
(jolt-delay-realized?-set! d #t))))
(if (jolt-delay-exn d) (raise (jolt-delay-exn d)) (jolt-delay-value d)))
;; --- deref extension --------------------------------------------------------
;; Chain the fully-built jolt-deref (atoms/vars/volatiles/reduced) with futures,

4
host/chez/natives-queue.ss
View file

@ -19,7 +19,9 @@
(define (queue-peek q) (if (null? (jolt-queue-front q)) jolt-nil (car (jolt-queue-front q))))
(define (queue-pop q)
(let ((f (jolt-queue-front q)))
(cond ((null? f) (error 'pop "can't pop empty queue"))
;; popping an empty PersistentQueue returns it (Clojure's pop: if f==null
;; return this) — unlike a vector, which throws.
(cond ((null? f) q)
((null? (cdr f)) (make-jolt-queue (reverse (jolt-queue-rear q)) '() (fx- (jolt-queue-cnt q) 1)))
(else (make-jolt-queue (cdr f) (jolt-queue-rear q) (fx- (jolt-queue-cnt q) 1))))))

18
host/chez/records.ss
View file

@ -62,8 +62,16 @@
"}"))
;; ---- extend the collection dispatchers with a jrec arm ----------------------
;; equality for a jrec: a deftype implementing IPersistentCollection/equiv (e.g.
;; core.cache's caches, which equiv to their backing map) compares through that
;; method, so (= cache {…}) works; a plain record has no equiv and falls back to
;; field-wise jrec=? (and a record is never = a plain map).
(register-eq-arm! (lambda (a b) (or (jrec? a) (jrec? b)))
(lambda (a b) (and (jrec? a) (jrec? b) (jrec=? a b))))
(lambda (a b)
(cond ((and (jrec? a) (jrec-cl a "equiv")) => (lambda (m) (if (jolt-truthy? (jolt-invoke m a b)) #t #f)))
((and (jrec? b) (jrec-cl b "equiv")) => (lambda (m) (if (jolt-truthy? (jolt-invoke m b a)) #t #f)))
((and (jrec? a) (jrec? b)) (jrec=? a b))
(else #f))))
(register-hash-arm! jrec? jrec-hash)
;; get on a jrec: a real field reads raw (so a deftype method's own field bindings,
;; compiled to (get inst :field), never recurse); a NON-field key on a deftype that
@ -131,6 +139,10 @@
(else (%r-jolt-conj1 coll x)))))
;; peek/pop on a deftype implementing IPersistentStack (data.priority-map, which
;; core.cache's LRU/LU caches lean on) dispatch to its methods.
;; empty? over a jrec: a map-like deftype is empty iff its entry seq is (data
;; .priority-map's peek calls (.isEmpty this) -> empty?). jolt-seq is method-first.
(define %r-jolt-empty? jolt-empty?)
(set! jolt-empty? (lambda (coll) (if (jrec? coll) (jolt-nil? (jolt-seq coll)) (%r-jolt-empty? coll))))
(define %r-jolt-peek jolt-peek)
(set! jolt-peek (lambda (coll)
(cond ((jrec-cl coll "peek") => (lambda (m) (jolt-invoke m coll)))
@ -357,6 +369,10 @@
;; holding a mutable cursor over (seq coll); (.hasNext it)/(.next it) walk it.
;; hiccup/compiler's run! loop iterates collections this way.
(define-record-type jiterator (fields (mutable cur)) (nongenerative jolt-iterator-v1))
;; (seq an-iterator) / (iterator-seq it): a jiterator wraps the remaining seq in
;; cur, so seq just yields it — clojure.test's (iterator-seq (.iterator coll)).
(let ((prev-seq jolt-seq))
(set! jolt-seq (lambda (x) (if (jiterator? x) (jiterator-cur x) (prev-seq x)))))
;; A Chez condition's message string (for Throwable .getMessage/.toString): the
;; &message text plus any &irritants, or display-condition output as a fallback.
(define (condition->message-string c)

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

File diff suppressed because one or more lines are too long

560
host/chez/seed/prelude.ss
View file

File diff suppressed because one or more lines are too long

96
jolt-core/clojure/core/30-macros.clj
View file

@ -323,35 +323,39 @@
;; inline impls register for dispatch but are NOT extenders of the
;; protocol (the JVM compiles them into the class) — register-inline-method,
;; not extend-type.
;; Several bodies for one method name are distinct arities (a type that
;; implements clojure.lang.Indexed has (nth [_ i]) AND (nth [_ i x])):
;; group them into one multi-arity fn so dispatch picks the clause by arg
;; count, instead of the last clause clobbering the rest.
impl (fn [proto specs]
(loop [ss (seq specs) methods {} order []]
(if (empty? ss)
`(do (register-inline-protocol! ~(name tname) ~(name proto))
~@(map (fn [mname]
`(register-inline-method ~(name tname) ~(name proto) ~mname
(fn ~@(get methods mname))))
order))
(let [spec (first ss)
mname (name (first spec))
argv (nth spec 1)
;; build one method clause (argv + field-bound body) from a method spec.
;; The clause is DATA, not a syntax-quote: a body that is itself a syntax-
;; quote would have its ~unquotes consumed a level early if re-spliced.
mk-clause (fn [spec]
(let [argv (nth spec 1)
inst (first argv)
binds (vec (mapcat (fn [f] [f `(get ~inst ~(keyword (name f)))]) fields))
mbody (map (fn [bf] (rewrite-set inst bf)) (drop 2 spec))
;; build the clause as DATA, not via a syntax-quote: a body
;; that is itself a syntax-quote (`(= ~ocr ~l)) would have its
;; ~unquotes consumed a level early if re-spliced through one.
clause (list argv (list* 'let binds mbody))]
(recur (rest ss)
(assoc methods mname (conj (get methods mname []) clause))
(if (contains? methods mname) order (conj order mname)))))))]
mbody (map (fn [bf] (rewrite-set inst bf)) (drop 2 spec))]
(list argv (list* 'let binds mbody))))
groups (group-by-head body)
;; merge clauses by method NAME across ALL protocols into one multi-arity
;; fn, so a name appearing in two interfaces with different arities
;; (data.priority-map's seq is in Seqable [this] AND Sorted [this asc])
;; dispatches by arg count instead of one registration shadowing the other.
;; (Within one protocol, distinct arities like Indexed's nth merge the same
;; way.) Each (protocol, name) registers the merged fn, so dispatch by name
;; and satisfies? by protocol both hold.
by-name (reduce (fn [m spec]
(let [nm (name (first spec))]
(assoc m nm (conj (get m nm []) (mk-clause spec)))))
{} (mapcat rest groups))]
`(do
(def ~tname (make-deftype-ctor (quote ~tname) [~@field-kws] [~@field-tags] [~@field-muts]))
(def ~arrow ~tname)
~@(map (fn [g] (impl (first g) (rest g))) (group-by-head body))
~@(mapcat (fn [g]
(let [proto (first g)
names (distinct (map (fn [spec] (name (first spec))) (rest g)))]
(cons `(register-inline-protocol! ~(name tname) ~(name proto))
(map (fn [nm]
`(register-inline-method ~(name tname) ~(name proto) ~nm
(fn ~@(get by-name nm))))
names))))
groups)
~tname)))
;; The protocol value is built by make-protocol (a fn call) rather than an embedded
@ -491,35 +495,35 @@
;; inline impls register for dispatch but are NOT extenders of the
;; protocol (the JVM compiles them into the class) — register-inline-method,
;; not extend-type.
;; group multi-arity method bodies into one fn (see deftype's impl).
impl (fn [proto specs]
(loop [ss (seq specs) methods {} order []]
(if (empty? ss)
`(do (register-inline-protocol! ~(name name-sym) ~(name proto))
~@(map (fn [mname]
`(register-inline-method ~(name name-sym) ~(name proto) ~mname
(fn ~@(get methods mname))))
order))
(let [spec (first ss)
mname (name (first spec))
argv (nth spec 1)
;; one clause from a spec; `this` is hinted with the record type so the
;; inference reads its fields bare-index. Clause as DATA (see deftype).
mk-clause (fn [spec]
(let [argv (nth spec 1)
inst (first argv)
;; hint `this` with the record type so the inference types it
;; and its field reads bare-index instead of the runtime guard.
hinted (assoc argv 0 (vary-meta inst assoc :tag (name name-sym)))
binds (vec (mapcat (fn [f] [f `(get ~inst ~(keyword (name f)))]) fields))
;; clause as DATA (see deftype): a syntax-quote body must not
;; be re-spliced through another syntax-quote.
clause (list hinted (list* 'let binds (drop 2 spec)))]
(recur (rest ss)
(assoc methods mname (conj (get methods mname []) clause))
(if (contains? methods mname) order (conj order mname)))))))]
binds (vec (mapcat (fn [f] [f `(get ~inst ~(keyword (name f)))]) fields))]
(list hinted (list* 'let binds (drop 2 spec)))))
groups (group-by-head body)
;; merge clauses by name across protocols into one multi-arity fn (see
;; deftype's by-name).
by-name (reduce (fn [m spec]
(let [nm (name (first spec))]
(assoc m nm (conj (get m nm []) (mk-clause spec)))))
{} (mapcat rest groups))]
`(do
;; deftype already defines ->name (= the ctor); no (name. …) interop needed,
;; so defrecord compiles too. map->name builds via that ctor.
(deftype ~name-sym ~fields)
(def ~mapf (fn* [~m] (~arrow ~@(map (fn [f] `(get ~m ~(keyword (name f)))) fields))))
~@(map (fn [g] (impl (first g) (rest g))) (group-by-head body)))))
~@(mapcat (fn [g]
(let [proto (first g)
names (distinct (map (fn [spec] (name (first spec))) (rest g)))]
(cons `(register-inline-protocol! ~(name name-sym) ~(name proto))
(map (fn [nm]
`(register-inline-method ~(name name-sym) ~(name proto) ~nm
(fn ~@(get by-name nm))))
names))))
groups))))
;; --- laziness --------------------------------------------------------------
;; lazy-seq / lazy-cat moved to the 00-syntax tier: the seq/coll tiers (10-seq,

5
test/chez/corpus.edn
View file

@ -6,6 +6,11 @@
{:suite "fn / pre-post" :label ":pre + :post pass" :expected "5" :actual "(do (defn ppf [x] {:pre [(pos? x)] :post [(= % x)]} x) (ppf 5))"}
{:suite "fn / pre-post" :label ":pre failure throws" :expected ":blocked" :actual "(do (defn ppg [x] {:pre [(pos? x)]} x) (try (ppg -1) (catch Throwable _ :blocked)))"}
{:suite "deftype / map-like dispatch" :label "dissoc + keys via IPersistentMap/Seqable methods" :expected "[:b]" :actual "(do (deftype MapT [m] clojure.lang.Seqable (seq [_] (seq m)) clojure.lang.IPersistentMap (without [_ k] (->MapT (dissoc m k))) (assoc [_ k v] (->MapT (assoc m k v)))) (vec (keys (dissoc (->MapT {:a 1 :b 2}) :a))))"}
{:suite "delay / exception memoization" :label "throwing body runs once, stays realized, re-throws" :expected "[1 true]" :actual "(let [n (atom 0) d (delay (swap! n inc) (throw (ex-info \"e\" {})))] (dotimes [_ 3] (try (deref d) (catch Throwable _ nil))) [(deref n) (realized? d)])"}
{:suite "queue / pop" :label "pop of empty PersistentQueue returns empty" :expected "nil" :actual "(seq (pop clojure.lang.PersistentQueue/EMPTY))"}
{:suite "interop / iterator-seq" :label "iterator-seq over .iterator" :expected "[:a :b]" :actual "(vec (iterator-seq (.iterator [:a :b])))"}
{:suite "deftype / IPersistentStack" :label "peek/pop dispatch" :expected "[1 [2 3]]" :actual "(do (deftype Stk [v] clojure.lang.IPersistentStack (peek [_] (first v)) (pop [_] (->Stk (rest v)))) [(peek (->Stk [1 2 3])) (vec (.v (pop (->Stk [1 2 3]))))])"}
{:suite "deftype / equiv" :label "(= deftype other) uses equiv method" :expected "true" :actual "(do (deftype EqT [m] clojure.lang.IPersistentCollection (equiv [_ o] (= o m)) clojure.lang.Seqable (seq [_] (seq m))) (= (->EqT {:a 1}) {:a 1}))"}
{:suite "interop / Class.forName" :label "unknown class throws ClassNotFoundException" :expected ":nf" :actual "(try (Class/forName \"no.such.Klass\") (catch ClassNotFoundException _ :nf))"}
{:suite "interop / Class.forName" :label "known class resolves" :expected "\"java.lang.String\"" :actual "(.getName (Class/forName \"java.lang.String\"))"}
{:suite "clojure.string / replace" :label "char match and replacement" :expected "\"a-b-c\"" :actual "(clojure.string/replace \"a/b/c\" \\/ \\-)"}