Run core.memoize's test suite on jolt
Shaking out clojure.core.memoize (207 assertions, 0 fail) cleared several
general gaps:
- deref/@ on a deftype or reify implementing clojure.lang.IDeref dispatches to
its deref method (RetryingDelay / make-derefable).
- deftype mutable fields (^:unsynchronized-mutable / ^:volatile-mutable) are
read live: a set! within a method is observed by a later read in the same
invocation, not the entry-time capture. Needed for double-checked locking.
Immutable fields stay let-bound. Field reads rewrite to (.-field inst) with
lexical-shadow tracking.
- def metadata values are evaluated, like Clojure: ^{:k (f)} stores (f)'s
result and ^{:af some-fn} the fn. :tag stays a literal hint.
- try dispatches catch clauses by class in order via the exception supertype
hierarchy; a non-matching value re-throws, an untyped host condition is caught
by a RuntimeException/Exception/Throwable clause. Previously the last clause
won and the class was ignored.
- locking takes a real per-object monitor (recursive Chez mutex) now that
futures/agents/threads share one heap; it was a no-op.
- supers/ancestors reflect a small modeled JVM interface hierarchy, so
(ancestors (class f)) yields Runnable/Callable (core.memoize's arg check).
- AssertionError / Error constructors.
JOLT_FEATURES is gone from the docs: it isn't read anywhere on Chez, and the
reader already includes :clj in its default feature set. RFC 0002's
{:jolt :default} design was reverted in the reader; docs now match the code.
Raises the SCI floor 205 -> 210.
This commit is contained in:
Yogthos
parent
3dde290f1a
commit
d21ab77e7e
18 changed files with 1179 additions and 939 deletions
|
|
@ -311,7 +311,12 @@
|
|||
|
||||
(defn ancestors
|
||||
([tag] (ancestors (deref global-hierarchy) tag))
|
||||
([h tag] (not-empty (get (get h :ancestors) tag))))
|
||||
([h tag]
|
||||
;; the user hierarchy plus any modeled JVM ancestry (jolt.host/class-ancestors)
|
||||
;; so (ancestors (class x)) answers like the JVM for the common interfaces.
|
||||
(let [hier (get (get h :ancestors) tag)
|
||||
host (jolt.host/class-ancestors tag)]
|
||||
(not-empty (if host (into (or hier #{}) host) hier)))))
|
||||
|
||||
(defn descendants
|
||||
([tag] (descendants (deref global-hierarchy) tag))
|
||||
|
|
|
|||
|
|
@ -344,8 +344,12 @@
|
|||
(defn numerator [x] (throw (ex-info "numerator requires a ratio (Jolt has no ratios)" {})))
|
||||
(defn denominator [x] (throw (ex-info "denominator requires a ratio (Jolt has no ratios)" {})))
|
||||
|
||||
;; No class hierarchy on this host.
|
||||
(defn supers [x] #{})
|
||||
;; jolt has no reflection, but a few common JVM interfaces carry a modeled
|
||||
;; ancestry (jolt.host/class-supers) so reflective checks like
|
||||
;; (ancestors (class f)) answer like the JVM.
|
||||
(defn supers [x]
|
||||
(let [s (jolt.host/class-supers x)]
|
||||
(if s (set s) #{})))
|
||||
|
||||
;; Like Clojure's munge: rewrite dashes to underscores, preserving the argument's
|
||||
;; type — a symbol munges to a symbol, anything else to a string. (jolt only
|
||||
|
|
|
|||
|
|
@ -69,10 +69,10 @@
|
|||
`(instance-check ~t ~x)
|
||||
`(instance-check (quote ~t) ~x)))
|
||||
|
||||
;; Single-threaded host: evaluate the monitor expr (for its effects, matching
|
||||
;; Clojure's evaluation order) and the body — no lock to take.
|
||||
;; Take x's monitor for the duration of body (futures/agents/threads share one
|
||||
;; heap, so this is a real per-object lock), releasing on any exit.
|
||||
(defmacro locking [x & body]
|
||||
`(do ~x ~@body))
|
||||
`(jolt.host/with-monitor ~x (fn* [] ~@body)))
|
||||
|
||||
;; defonce: define name only if it isn't already bound to a non-nil root;
|
||||
;; returns the existing var untouched otherwise.
|
||||
|
|
@ -310,16 +310,61 @@
|
|||
;; in-place field write the analyzer compiles to jolt-set-field!.
|
||||
mutable-syms (map first (filter second (map vector fields field-muts)))
|
||||
mutable? (fn [s] (boolean (some (fn [m] (= m s)) mutable-syms)))
|
||||
rewrite-set (fn rw [inst form]
|
||||
(cond
|
||||
(and (seq? form) (seq form) (symbol? (first form))
|
||||
(= "set!" (name (first form)))
|
||||
(symbol? (second form)) (mutable? (second form)))
|
||||
(list 'set! (list (symbol (str ".-" (name (second form)))) inst)
|
||||
(rw inst (nth form 2)))
|
||||
(seq? form) (map (fn [x] (rw inst x)) form)
|
||||
(vector? form) (mapv (fn [x] (rw inst x)) form)
|
||||
:else form))
|
||||
;; rewrite a method body: (set! mut-field v) -> an in-place (.-field inst)
|
||||
;; write, and a READ of a mutable field -> (.-field inst) so it observes the
|
||||
;; live value after a set! (the double-checked-locking idiom re-reads a field
|
||||
;; after taking a lock). Immutable fields stay let-bound (captured once is
|
||||
;; correct and cheaper). Tracks lexical shadowing through let/loop/fn/letfn so
|
||||
;; a same-named local wins over a field.
|
||||
rewrite-body
|
||||
(fn rw [inst shadowed form]
|
||||
(cond
|
||||
(and (seq? form) (seq form) (symbol? (first form))
|
||||
(= "set!" (name (first form)))
|
||||
(symbol? (second form)) (mutable? (second form))
|
||||
(not (contains? shadowed (second form))))
|
||||
(list 'set! (list (symbol (str ".-" (name (second form)))) inst)
|
||||
(rw inst shadowed (nth form 2)))
|
||||
;; let/loop-style vector-binding forms: rewrite inits, then shadow the
|
||||
;; bound names in the body.
|
||||
(and (seq? form) (seq form) (symbol? (first form))
|
||||
(contains? #{"let" "let*" "loop" "binding" "when-let" "if-let"
|
||||
"when-some" "if-some"} (name (first form)))
|
||||
(vector? (second form)))
|
||||
(let [bv (second form) n (count bv)
|
||||
bv' (loop [i 0 acc []]
|
||||
(if (< i n)
|
||||
(recur (+ i 2)
|
||||
(let [a (conj acc (nth bv i))]
|
||||
(if (< (inc i) n) (conj a (rw inst shadowed (nth bv (inc i)))) a)))
|
||||
acc))
|
||||
sh (loop [i 0 acc shadowed]
|
||||
(if (< i n)
|
||||
(recur (+ i 2) (if (symbol? (nth bv i)) (conj acc (nth bv i)) acc))
|
||||
acc))]
|
||||
(cons (first form) (cons bv' (map (fn [x] (rw inst sh x)) (drop 2 form)))))
|
||||
;; fn/fn*: shadow each arity's params in its body.
|
||||
(and (seq? form) (seq form) (symbol? (first form))
|
||||
(contains? #{"fn" "fn*"} (name (first form))))
|
||||
(let [head (first form) tail (rest form)
|
||||
named? (and (seq tail) (symbol? (first tail)))
|
||||
fname (when named? (first tail))
|
||||
arts (if named? (rest tail) tail)
|
||||
psyms (fn [pv] (loop [p (seq pv) acc shadowed]
|
||||
(if p
|
||||
(recur (next p)
|
||||
(if (and (symbol? (first p)) (not= (name (first p)) "&"))
|
||||
(conj acc (first p)) acc))
|
||||
acc)))
|
||||
do-art (fn [ar] (cons (first ar) (map (fn [x] (rw inst (psyms (first ar)) x)) (rest ar))))
|
||||
arts' (if (vector? (first arts)) (do-art arts) (map do-art arts))]
|
||||
(concat (list head) (when named? (list fname)) arts'))
|
||||
;; a bare read of a mutable field -> live field access
|
||||
(and (symbol? form) (mutable? form) (not (contains? shadowed form)))
|
||||
(list (symbol (str ".-" (name form))) inst)
|
||||
(seq? form) (map (fn [x] (rw inst shadowed x)) form)
|
||||
(vector? form) (mapv (fn [x] (rw inst shadowed x)) form)
|
||||
:else form))
|
||||
;; 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.
|
||||
|
|
@ -329,8 +374,11 @@
|
|||
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))]
|
||||
;; let-bind only immutable fields; mutable ones are read live
|
||||
;; via rewrite-body so a set! within the method is observed.
|
||||
binds (vec (mapcat (fn [f] [f `(get ~inst ~(keyword (name f)))])
|
||||
(filter (fn [f] (not (mutable? f))) fields)))
|
||||
mbody (map (fn [bf] (rewrite-body 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
|
||||
|
|
|
|||
|
|
@ -215,11 +215,14 @@
|
|||
rest-items))
|
||||
:else (uncompilable "fn: bad params"))))
|
||||
|
||||
;; class names that catch everything (the JVM root types); a (catch Throwable e …)
|
||||
;; clause matches any thrown value unconditionally.
|
||||
(def ^:private catch-all-names #{"Throwable" "java.lang.Throwable" "Object" "java.lang.Object"})
|
||||
|
||||
(defn- analyze-try [ctx items env]
|
||||
(let [clauses (rest items)
|
||||
body (atom [])
|
||||
catch-sym (atom nil)
|
||||
catch-body (atom nil)
|
||||
catches (atom []) ; ordered vector of (catch class binding body*) clauses
|
||||
finally-body (atom nil)]
|
||||
(doseq [c clauses]
|
||||
(let [head (when (form-list? c) (first (vec (form-elements c))))
|
||||
|
|
@ -233,22 +236,43 @@
|
|||
;; form-sym-name crash on a non-symbol.
|
||||
(when (or (< (count cl) 3) (not (form-sym? (nth cl 2))))
|
||||
(throw "Unable to parse catch clause; expected (catch class binding body*)"))
|
||||
(reset! catch-sym (form-sym-name (nth cl 2)))
|
||||
(reset! catch-body (drop 3 cl)))
|
||||
(swap! catches conj cl))
|
||||
(= hname "finally")
|
||||
(reset! finally-body (rest (vec (form-elements c))))
|
||||
:else (swap! body conj c))))
|
||||
;; Add :catch-sym/:catch-body/:finally ONLY when present (same discipline as
|
||||
;; the arity :rest key above). Assoc'ing them nil-when-absent would give the
|
||||
;; node a nil-valued key, which makes it a phm in jolt's map representation
|
||||
;; and forces the back end to densify it (norm-node) before reading :op — the
|
||||
;; map-nil-representation trap, also avoided for def/fn/arity nodes. The
|
||||
;; back end reads each key with a nil-safe (node :k) and gates on it, so an
|
||||
;; absent key is indistinguishable from a present-nil one.
|
||||
;; Multiple catch clauses dispatch on the thrown value's class, in order. Lower
|
||||
;; them to ONE guard binding a fresh local, then a nested-if chain testing each
|
||||
;; clause's class with (instance? C e) — which respects the exception supertype
|
||||
;; hierarchy — plus __catch-broad? for an untyped host condition. No match
|
||||
;; re-throws. (The earlier single-catch IR ignored the class and caught
|
||||
;; everything; this gives real per-class dispatch.) :catch-sym/:catch-body/
|
||||
;; :finally are added only when present — an absent key must stay absent (a
|
||||
;; nil-valued key would make the node a phm and force back-end densification).
|
||||
(let [n {:op :try :body (analyze-seq ctx @body env)}
|
||||
n (if @catch-body
|
||||
(assoc n :catch-sym @catch-sym
|
||||
:catch-body (analyze-seq ctx @catch-body (add-locals env [@catch-sym])))
|
||||
n (if (seq @catches)
|
||||
(let [evar-name (gen-name "catch")
|
||||
evar (symbol evar-name)
|
||||
dispatch
|
||||
(reduce
|
||||
(fn [else cl]
|
||||
(let [cform (nth cl 1)
|
||||
bindsym (nth cl 2)
|
||||
bodyf (drop 3 cl)
|
||||
letform (cons 'let (cons (vector bindsym evar) bodyf))
|
||||
fullname (when (form-sym? cform) (form-sym-name cform))
|
||||
catch-all? (or (not (form-sym? cform))
|
||||
(contains? catch-all-names fullname))]
|
||||
(if catch-all?
|
||||
letform
|
||||
(list 'if (list 'or
|
||||
(list 'instance? cform evar)
|
||||
(list '__catch-broad? fullname evar))
|
||||
letform else))))
|
||||
(list 'throw evar)
|
||||
(reverse @catches))]
|
||||
(assoc n :catch-sym evar-name
|
||||
:catch-body (analyze-seq ctx (list dispatch)
|
||||
(add-locals env [evar-name]))))
|
||||
n)
|
||||
n (if @finally-body
|
||||
(assoc n :finally (analyze-seq ctx @finally-body env))
|
||||
|
|
@ -284,6 +308,22 @@
|
|||
(defn- field-head? [nm]
|
||||
(and (> (count nm) 2) (= ".-" (subs nm 0 2))))
|
||||
|
||||
;; Clojure evaluates def metadata values as expressions: ^{:k (f)} stores the
|
||||
;; result of (f), ^{:a some-fn} stores the fn value. Build an IR map that evaluates
|
||||
;; each value at def time. :tag keeps the resolved class-name string (jolt models a
|
||||
;; type hint as its class name, not a runtime expression). nil when there's no
|
||||
;; metadata, so a plain def keeps the cheap static path.
|
||||
(defn- def-meta-expr [ctx base env]
|
||||
(when (pos? (count base))
|
||||
(map-node (mapv (fn [p]
|
||||
(let [k (first p) v (second p)]
|
||||
;; :tag stays a literal (a resolved class-name string or a
|
||||
;; primitive-hint symbol like `double`) — quote it rather
|
||||
;; than evaluate it. Everything else is evaluated.
|
||||
[(const k)
|
||||
(if (= k :tag) (quote-node v) (analyze ctx v env))]))
|
||||
(seq base)))))
|
||||
|
||||
(defn- analyze-def [ctx items env]
|
||||
(let [name-sym (nth items 1)]
|
||||
;; ^{:map} metadata reads as (def (with-meta name m) v): the metadata is a
|
||||
|
|
@ -316,7 +356,9 @@
|
|||
node-meta (if has-doc (assoc base-meta :doc (nth items 2)) base-meta)]
|
||||
(host-intern! ctx cur nm)
|
||||
;; a ^double/^long return hint on the name applies to all arities of the fn.
|
||||
(def-node cur nm (with-ret-nhint (analyze ctx val-form env) (tag->nkind tag)) node-meta)))))
|
||||
(let [node (def-node cur nm (with-ret-nhint (analyze ctx val-form env) (tag->nkind tag)) node-meta)
|
||||
me (def-meta-expr ctx node-meta env)]
|
||||
(if me (assoc node :meta-expr me) node))))))
|
||||
|
||||
;; (set! (.-field obj) v) mutates a deftype instance field in place; (set! *var* v)
|
||||
;; sets the var's innermost thread binding, else its root. A local target (jolt
|
||||
|
|
|
|||
|
|
@ -302,6 +302,14 @@
|
|||
;; A def's :meta is a jolt map value. Non-empty? (a plain def carries {}).
|
||||
(defn- jmeta-nonempty? [m] (and (map? m) (pos? (count m))))
|
||||
|
||||
;; The meta argument to def-var-with-meta!. When the analyzer attached a
|
||||
;; :meta-expr (metadata with values to evaluate, e.g. ^{:a some-fn}), emit it as a
|
||||
;; runtime expression; otherwise the static :meta map as quoted data.
|
||||
(defn- emit-def-meta [node]
|
||||
(if (:meta-expr node)
|
||||
(emit (:meta-expr node))
|
||||
(emit-quoted (:meta node))))
|
||||
|
||||
(defn- emit-binding [b]
|
||||
(str "(" (munge-name (nth b 0)) " " (emit (nth b 1)) ")"))
|
||||
|
||||
|
|
@ -629,7 +637,7 @@
|
|||
(str "(declare-var! " (chez-str-lit (:ns node)) " " (chez-str-lit (:name node)) ")")
|
||||
(jmeta-nonempty? (:meta node))
|
||||
(str "(def-var-with-meta! " (chez-str-lit (:ns node)) " " (chez-str-lit (:name node)) " "
|
||||
(emit (:init node)) " " (emit-quoted (:meta node)) ")")
|
||||
(emit (:init node)) " " (emit-def-meta node) ")")
|
||||
:else
|
||||
(str "(def-var! " (chez-str-lit (:ns node)) " " (chez-str-lit (:name node)) " "
|
||||
(emit (:init node)) ")"))
|
||||
|
|
@ -660,7 +668,7 @@
|
|||
(let [init (emit (:init node))]
|
||||
(if (jmeta-nonempty? (:meta node))
|
||||
(str "(begin (define " b " " init ") (def-var-with-meta! "
|
||||
(chez-str-lit ns) " " (chez-str-lit nm) " " b " " (emit-quoted (:meta node)) "))")
|
||||
(chez-str-lit ns) " " (chez-str-lit nm) " " b " " (emit-def-meta node) "))")
|
||||
(str "(begin (define " b " " init ") (def-var! "
|
||||
(chez-str-lit ns) " " (chez-str-lit nm) " " b "))"))))
|
||||
:else (emit node)))
|
||||
|
|
|
|||
|
|
@ -118,7 +118,10 @@
|
|||
(= op :recur) (assoc node :args (mapv f (get node :args)))
|
||||
(= op :fn) (assoc node :arities (mapv (fn [a] (assoc a :body (f (get a :body))))
|
||||
(get node :arities)))
|
||||
(= op :def) (assoc node :init (f (get node :init)))
|
||||
(= op :def) (let [n (assoc node :init (f (get node :init)))]
|
||||
(if (get node :meta-expr)
|
||||
(assoc n :meta-expr (f (get node :meta-expr)))
|
||||
n))
|
||||
(= op :host-call) (assoc node :target (f (get node :target))
|
||||
:args (mapv f (get node :args)))
|
||||
(= op :host-new) (assoc node :args (mapv f (get node :args)))
|
||||
|
|
@ -159,7 +162,8 @@
|
|||
(= op :loop) (f (reduce (fn [a b] (f a (nth b 1))) acc (get node :bindings)) (get node :body))
|
||||
(= op :recur) (reduce f acc (get node :args))
|
||||
(= op :fn) (reduce (fn [a ar] (f a (get ar :body))) acc (get node :arities))
|
||||
(= op :def) (if (get node :init) (f acc (get node :init)) acc)
|
||||
(= op :def) (let [a (if (get node :init) (f acc (get node :init)) acc)]
|
||||
(if (get node :meta-expr) (f a (get node :meta-expr)) a))
|
||||
(= op :host-call) (reduce f (f acc (get node :target)) (get node :args))
|
||||
(= op :host-new) (reduce f acc (get node :args))
|
||||
(= op :try)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue