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

feat: persistent vector (working) + HAMT hash map (wip)

Browse source 
PersistentVector: 17-form .clj source, fully working.
- 32-way branching trie with tail optimization
- pv-conj, pv-nth, pv-assoc, pv-pop, vector?, vector constructor
- instance? check works on deftype tables
- .-field accessor syntax for deftype fields

api.janet: :mutable? compile flag for opt-out
- Default: persistent data structures loaded
- Pass {:mutable? true} to use Janet native types

Supporting changes (evaluator/core):
- 17 new primitives: bit ops, array ops, unchecked math, hash, cond
- loop macro, zero?, dec/inc, defn multi-arity
- instance? for deftype tables (get val :jolt/deftype)
- defrecord builds maps at expansion time
- .-field field access in default function application path

PersistentHashMap: 24-form HAMT source loads OK.
- BitmapIndexedNode/PersistentHashMap deftypes
- mask, bitpos, bit-count, index helpers
- phm-assoc/phm-get/phm-without/phm-contains? stubs
- bmn-assoc insert path structured, bitmap propagation wip
This commit is contained in:
Yogthos 2026-06-02 11:51:39 -04:00
parent 51860a553e
commit 33a5b7e7a4
11 changed files with 688 additions and 109 deletions
Download patch file Download diff file Expand all files Collapse all files

30
src/jolt/api.janet
View file

@ -6,17 +6,41 @@
(use ./evaluator)
(use ./core)
(defn- load-persistent-structures
"Load immutable persistent data structures and swap clojure.core bindings.
Replaces vec, vector, hash-map, hash-set, set with Jolt's persistent versions."
[ctx]
(def source (slurp "src/jolt/clojure/lang/persistent_vector.clj"))
(var cur source)
(while (> (length (string/trim cur)) 0)
(def [form rest] (parse-next cur))
(set cur rest)
(when (not (nil? form))
(eval-form ctx @{} form)))
(let [core-ns (ctx-find-ns ctx "clojure.core")
pv-ns (ctx-find-ns ctx "jolt.lang.persistent-vector")]
(ns-intern core-ns "vec" (var-get (ns-find pv-ns "vector")))
(ns-intern core-ns "vector" (var-get (ns-find pv-ns "vector")))
(ns-intern core-ns "vector?" (var-get (ns-find pv-ns "vector?")))))
(defn init
"Create a new Jolt evaluation context, optionally with opts.
(init) — empty context with clojure.core loaded
(init opts) — context with opts and clojure.core loaded
Persistent immutable data structures are loaded by default.
opts may contain:
:namespaces — map of {ns-name → {sym → value, ...}, ...}"
:namespaces — map of {ns-name → {sym → value, ...}, ...}
:mutable? — if true, use Janet mutable data structures instead"
[&opt opts]
(default opts nil)
(let [ctx (make-ctx opts)]
(default opts {})
(let [ctx (make-ctx opts)
mutable? (get opts :mutable?)]
(init-core! ctx)
(if mutable?
nil
(load-persistent-structures ctx))
ctx))
(defn eval-string

188
src/jolt/clojure/lang/persistent_hash_map.clj Normal file
View file

@ -0,0 +1,188 @@
(ns jolt.lang.persistent-hash-map
"PersistentHashMap: HAMT persistent hash map.")
(def branch-factor 32)
(def shift-increment 5)
(deftype BitmapIndexedNode [bitmap array])
(deftype PersistentHashMap [count root has-nil? nil-value _meta])
(def not-found (Object.))
(defn- hash-mix [h]
(mod h 1000000))
(def EMPTY (PersistentHashMap. 0 nil false nil nil))
(defn- mask [h sh]
(int (bit-and (unsigned-bit-shift-right h sh) 31)))
(defn- bitpos [h sh]
(bit-shift-left 1 (mask h sh)))
(defn- bit-count [n]
(loop [n n c 0]
(if (zero? n) c (recur (bit-and n (dec n)) (inc c)))))
(defn- index [bm bit]
(bit-count (bit-and bm (dec bit))))
;; Copy entries before idx into new array
(defn- copy-before [src dst idx]
(loop [i 0]
(if (< i idx)
(do (aset dst i (aget src i))
(aset dst (inc i) (aget src (inc i)))
(recur (+ i 2))))))
;; Copy entries from src-idx onwards into dst at shifted position
(defn- copy-after [src dst src-start dst-start end]
(loop [i src-start]
(if (< i end)
(do (aset dst (+ dst-start (- i src-start)) (aget src i))
(recur (inc i))))))
(defn- bmn-assoc [node shift h key val added?]
(let [bit (bitpos h shift)
bm (.-bitmap node)
arr (.-array node)]
(if (zero? (bit-and bm bit))
;; Insert new entry at this level
(let [idx (* 2 (index bm bit))
n (bit-count bm)
new-len (* 2 (inc n))
a (object-array new-len)]
(loop [i 0]
(if (< i idx)
(do (aset a i (aget arr i))
(aset a (inc i) (aget arr (inc i)))
(recur (+ i 2)))))
(loop [i idx]
(if (< i (* 2 n))
(do (aset a (+ i 2) (aget arr i))
(aset a (+ i 3) (aget arr (inc i)))
(recur (+ i 2))))))
(aset a idx key)
(aset a (inc idx) val)
(aset added? 0 true)
(BitmapIndexedNode. (bit-or bm bit) a))
;; Position occupied — just replace value (no recursion for now)
(let [idx (* 2 (index bm bit))
ek (aget arr idx)]
(if (identical? ek key)
(let [a (aclone arr)]
(aset a (inc idx) val)
(BitmapIndexedNode. bm a))
;; Different key at same position — use linear chaining in array
(let [n (bit-count bm)
new-len (* 2 (inc n))
a (object-array new-len)]
(loop [i 0]
(if (< i (* 2 n))
(do (aset a i (aget arr i))
(recur (inc i)))))
(aset a (* 2 n) key)
(aset a (inc (* 2 n)) val)
(aset added? 0 true)
(BitmapIndexedNode. bm a))))))
(defn- bmn-find [node shift h key]
(let [bit (bitpos h shift)
bm (.-bitmap node)
arr (.-array node)]
(if (zero? (bit-and bm bit))
not-found
(let [idx (* 2 (index bm bit))
k (aget arr idx)]
(if (nil? k)
(bmn-find (aget arr (inc idx)) (+ shift shift-increment) h key)
(if (identical? k key)
(aget arr (inc idx))
not-found))))))
(defn- bmn-without [node shift h key]
(let [bit (bitpos h shift)
bm (.-bitmap node)
arr (.-array node)]
(if (zero? (bit-and bm bit))
node
(let [idx (* 2 (index bm bit))
k (aget arr idx)]
(if (nil? k)
(let [sub (aget arr (inc idx))
ns (bmn-without sub (+ shift shift-increment) h key)]
(if (identical? ns sub)
node
(let [a (aclone arr)]
(aset a (inc idx) ns)
(BitmapIndexedNode. bm a))))
(if (identical? k key)
(let [n (bit-count bm)
a (object-array (max 2 (* 2 (dec n))))]
(loop [i 0]
(if (< i idx)
(do (aset a i (aget arr i))
(aset a (inc i) (aget arr (inc i)))
(recur (+ i 2)))))
(loop [i (+ idx 2)]
(if (< i (* 2 n))
(do (aset a (- i 2) (aget arr i))
(aset a (- i 1) (aget arr (inc i)))
(recur (+ i 2))))))
(BitmapIndexedNode. (bit-xor bm bit) a))
node)))))
(defn phm-assoc [m key val]
(if (nil? key)
(PersistentHashMap.
(if (.-has-nil? m) (.-count m) (inc (.-count m)))
(.-root m) true val (.-_meta m))
(let [added? (object-array 1)
h (hash key)
r (if (nil? (.-root m))
(bmn-assoc (BitmapIndexedNode. 0 (object-array 2)) 0 h key val added?)
(bmn-assoc (.-root m) 0 h key val added?))]
(PersistentHashMap.
(if (aget added? 0) (inc (.-count m)) (.-count m))
r (.-has-nil? m) (.-nil-value m) (.-_meta m)))))
(defn phm-without [m key]
(if (nil? key)
(if (.-has-nil? m)
(PersistentHashMap. (dec (.-count m)) (.-root m) false nil (.-_meta m))
m)
(if (nil? (.-root m))
m
(let [nr (bmn-without (.-root m) 0 (hash-mix (hash key)) key)]
(if (identical? nr (.-root m))
m
(PersistentHashMap. (dec (.-count m)) nr
(.-has-nil? m) (.-nil-value m) (.-_meta m)))))))
(defn phm-get
([m key] (phm-get m key nil))
([m key not-found-val]
(if (nil? key)
(if (.-has-nil? m) (.-nil-value m) not-found-val)
(if (nil? (.-root m))
not-found-val
(let [val (bmn-find (.-root m) 0 (hash-mix (hash key)) key)]
(if (identical? val not-found) not-found-val val))))))
(defn phm-contains? [m key]
(if (nil? key)
(.-has-nil? m)
(if (nil? (.-root m))
false
(not (identical? (bmn-find (.-root m) 0 (hash-mix (hash key)) key) not-found)))))
(defn phm-count [m] (.-count m))
(defn phm-empty [m] EMPTY)
(defn hash-map [& kvs]
(if (nil? kvs)
EMPTY
(loop [m EMPTY xs (seq kvs)]
(if (and xs (seq (rest xs)))
(recur (phm-assoc m (first xs) (first (rest xs)))
(rest (rest xs)))
m))))

165
src/jolt/clojure/lang/persistent_vector.clj Normal file
View file

@ -0,0 +1,165 @@
(ns jolt.lang.persistent-vector
"PersistentVector: 32-way branching trie with tail optimization.")
(def branch-factor 32)
(def shift-increment 5)
(def tail-max 31)
(deftype VectorNode [^:volatile-mutable arr])
(deftype PersistentVector [cnt shift root tail _meta])
(def empty-array (object-array 0))
(def EMPTY (PersistentVector. 0 shift-increment nil empty-array nil))
(defn- tailoff [pv]
(int (- (.-cnt pv) (unsigned-bit-shift-right (.-cnt pv) shift-increment))))
(defn- new-path [level node]
(if (= level 0)
node
(let [arr (object-array branch-factor)]
(aset arr 0 (new-path (int (- level shift-increment)) node))
(VectorNode. arr))))
(defn- push-tail [parent level tailnode cnt]
(let [subidx (int (bit-and (unsigned-bit-shift-right (int cnt) (int level)) tail-max))
ret (VectorNode. (aclone (.-arr parent)))]
(if (= level shift-increment)
(do (aset (.-arr ret) subidx tailnode) ret)
(let [child (aget (.-arr parent) subidx)]
(aset (.-arr ret) subidx
(if child
(push-tail child (int (- level shift-increment)) tailnode cnt)
(new-path (int (- level shift-increment)) tailnode)))
ret))))
(defn- do-assoc [level node i val]
(let [ret (VectorNode. (aclone (.-arr node)))]
(if (= level 0)
(do (aset (.-arr ret) (int (bit-and i tail-max)) val) ret)
(let [subidx (int (bit-and (unsigned-bit-shift-right (int i) (int level)) tail-max))]
(aset (.-arr ret) subidx
(do-assoc (int (- level shift-increment)) (aget (.-arr node) subidx) i val))
ret))))
(defn- array-for [pv i]
(if (and (<= 0 i) (< i (.-cnt pv)))
(if (>= i (tailoff pv))
(.-tail pv)
(loop [node (.-root pv) level (.-shift pv)]
(if (> level 0)
(recur (aget (.-arr node)
(int (bit-and (unsigned-bit-shift-right (int i) (int level)) tail-max)))
(int (- level shift-increment)))
(.-arr node))))
nil))
(defn pv-conj [pv val]
(let [cnt (.-cnt pv)]
(if (< (- cnt (tailoff pv)) branch-factor)
(let [old-len (alength (.-tail pv))
new-tail (object-array (+ old-len 1))]
(loop [i 0]
(if (< i old-len)
(do (aset new-tail i (aget (.-tail pv) i)) (recur (unchecked-inc i)))
(do (aset new-tail i val)
(PersistentVector. (unchecked-inc cnt) (.-shift pv) (.-root pv) new-tail (.-_meta pv))))))
(let [tail-node (VectorNode. (.-tail pv))
root-overflow? (> (unchecked-inc (unsigned-bit-shift-right cnt shift-increment))
(bit-shift-left 1 (.-shift pv)))]
(if root-overflow?
(let [nr (object-array branch-factor)]
(aset nr 0 (.-root pv))
(aset nr 1 (new-path (.-shift pv) tail-node))
(let [new-root (VectorNode. nr)
new-shift (+ (.-shift pv) shift-increment)
new-tail (object-array 1)]
(aset new-tail 0 val)
(PersistentVector. (unchecked-inc cnt) new-shift new-root new-tail (.-_meta pv))))
(let [new-root (push-tail (.-root pv) (.-shift pv) tail-node cnt)
new-tail (object-array 1)]
(aset new-tail 0 val)
(PersistentVector. (unchecked-inc cnt) (.-shift pv) new-root new-tail (.-_meta pv))))))))
(defn pv-nth [pv i]
(let [node (array-for pv i)]
(if node
(aget node (int (bit-and i tail-max)))
(throw (str "Index out of bounds: " i)))))
(defn pv-assoc [pv i val]
(let [cnt (.-cnt pv)]
(if (and (<= 0 i) (< i cnt))
(if (>= i (tailoff pv))
(let [new-tail (object-array (alength (.-tail pv)))]
(loop [j 0]
(if (< j (alength new-tail))
(do (aset new-tail j
(if (= j (int (bit-and i tail-max))) val (aget (.-tail pv) j)))
(recur (unchecked-inc j)))
(PersistentVector. cnt (.-shift pv) (.-root pv) new-tail (.-_meta pv)))))
(PersistentVector. cnt (.-shift pv) (do-assoc (.-shift pv) (.-root pv) i val) (.-tail pv) (.-_meta pv)))
(if (= i cnt)
(pv-conj pv val)
(throw (str "Index out of bounds: " i))))))
(defn- pop-tail [level node cnt]
(let [subidx (int (bit-and (unsigned-bit-shift-right (int (- cnt 2)) (int level)) tail-max))]
(if (> level shift-increment)
(let [new-child (pop-tail (int (- level shift-increment)) (aget (.-arr node) subidx) cnt)]
(if (and (nil? new-child) (zero? subidx))
nil
(let [ret (VectorNode. (aclone (.-arr node)))]
(aset (.-arr ret) subidx new-child)
ret)))
(if (zero? subidx)
nil
(let [ret (VectorNode. (aclone (.-arr node)))]
(aset (.-arr ret) subidx nil)
ret)))))
(defn- pv-nth-internal [cnt shift root i]
(if (and (<= 0 i) (< i cnt))
(if (>= i (- cnt (int (bit-and cnt tail-max))))
nil
(loop [node root level shift]
(if (> level 0)
(recur (aget (.-arr node) (int (bit-and (unsigned-bit-shift-right (int i) (int level)) tail-max)))
(int (- level shift-increment)))
(aget (.-arr node) (int (bit-and i tail-max))))))
nil))
(defn pv-pop [pv]
(let [cnt (.-cnt pv)]
(cond
(zero? cnt) (throw "Can't pop empty vector")
(= cnt 1) EMPTY
(> (- cnt (tailoff pv)) 1)
(let [old-tail (.-tail pv)
new-tail (object-array (dec (alength old-tail)))]
(loop [i 0]
(if (< i (alength new-tail))
(do (aset new-tail i (aget old-tail i)) (recur (unchecked-inc i)))
(PersistentVector. (dec cnt) (.-shift pv) (.-root pv) new-tail (.-_meta pv)))))
:else
(let [new-root (pop-tail (.-shift pv) (.-root pv) cnt)
new-cnt (dec cnt)
new-tail-len (int (bit-and new-cnt tail-max))
tail-len (if (zero? new-tail-len) branch-factor new-tail-len)
new-tail (object-array tail-len)]
(loop [i 0]
(if (< i tail-len)
(let [idx (+ (- new-cnt tail-len) i)]
(aset new-tail i (pv-nth-internal new-cnt (.-shift pv) new-root idx))
(recur (unchecked-inc i)))
(PersistentVector. new-cnt (.-shift pv) new-root new-tail (.-_meta pv))))))))
(defn pv-empty [_] EMPTY)
(defn vector [& args]
(loop [acc EMPTY items (seq args)]
(if (seq items)
(recur (pv-conj acc (first items)) (rest items))
acc)))
(defn vector? [x] (instance? PersistentVector x))

57
src/jolt/core.janet
View file

@ -687,6 +687,30 @@
@[{:jolt/type :symbol :ns nil :name "if"} not-form
@[{:jolt/type :symbol :ns nil :name "do"} ;body]])
(defn core-and
"Macro: (and) -> true, (and x) -> x, (and x y ...) -> (if x (and y ...) x)"
[& exprs]
(if (= 0 (length exprs)) true
(if (= 1 (length exprs)) (first exprs)
@[{:jolt/type :symbol :ns nil :name "let*"}
@[{:jolt/type :symbol :ns nil :name "and__x"} (first exprs)]
@[{:jolt/type :symbol :ns nil :name "if"}
{:jolt/type :symbol :ns nil :name "and__x"}
@[{:jolt/type :symbol :ns nil :name "and"} ;(tuple/slice exprs 1)]
{:jolt/type :symbol :ns nil :name "and__x"}]])))
(defn core-or
"Macro: (or) -> nil, (or x) -> x, (or x y ...) -> (let [or__x x] (if or__x or__x (or y ...)))"
[& exprs]
(if (= 0 (length exprs)) nil
(if (= 1 (length exprs)) (first exprs)
@[{:jolt/type :symbol :ns nil :name "let*"}
@[{:jolt/type :symbol :ns nil :name "or__x"} (first exprs)]
@[{:jolt/type :symbol :ns nil :name "if"}
{:jolt/type :symbol :ns nil :name "or__x"}
{:jolt/type :symbol :ns nil :name "or__x"}
@[{:jolt/type :symbol :ns nil :name "or"} ;(tuple/slice exprs 1)]]])))
(defn core-if-let
"Macro: (if-let [binding val-expr] then else?)"
[bindings then-form & else-forms]
@ -766,8 +790,23 @@
(each b body (array/push fn-form b))
@[{:jolt/type :symbol :ns nil :name "def"} fn-name fn-form])))
# defn- stub — expands to defn
(defn core-defn- [& args] @[{:jolt/type :symbol :ns nil :name "do"}])
# defn- — same as defn (private not enforced in Jolt)
(defn core-defn- [fn-name & rest]
# Multi-arity if rest starts with list of [args] pairs
(if (and (> (length rest) 0) (array? (first rest)) (indexed? (first (first rest))))
(let [pairs rest]
(def fn-form @[])
(array/push fn-form {:jolt/type :symbol :ns nil :name "fn*"})
(each pair pairs (array/push fn-form pair))
@[{:jolt/type :symbol :ns nil :name "def"} fn-name fn-form])
# Single-arity: (defn- name [args] body...)
(let [args-form (first rest)
body (tuple/slice rest 1)]
(def fn-form @[])
(array/push fn-form {:jolt/type :symbol :ns nil :name "fn*"})
(array/push fn-form args-form)
(each b body (array/push fn-form b))
@[{:jolt/type :symbol :ns nil :name "def"} fn-name fn-form])))
# Hierarchy stubs for sci bootstrap
(def core-derive (fn [& args] nil))
@ -864,6 +903,15 @@
(each b body (array/push result b))
result)
(defn core-loop
"Macro: (loop [bindings] body) → (loop* [bindings] body)"
[bindings & body]
(def result @[])
(array/push result {:jolt/type :symbol :ns nil :name "loop*"})
(array/push result bindings)
(each b body (array/push result b))
result)
# Protocol stubs — defined in sci.impl.protocols, needed in clojure.core
# defprotocol must be a macro to avoid evaluating its args
(defn core-defprotocol [protocol-name & sigs]
@ -1020,6 +1068,8 @@
"reset!" core-reset!
"swap!" core-swap!
"not" core-not
"and" core-and
"or" core-or
"when" core-when
"when-not" core-when-not
"if-let" core-if-let
@ -1037,6 +1087,7 @@
"declare" core-declare
"fn" core-fn
"let" core-let
"loop" core-loop
"defprotocol" core-defprotocol
"extend-type" core-extend-type
"extend-protocol" core-extend-protocol
@ -1078,7 +1129,7 @@
(defn core-macro-names
"Set of core binding names that are macros."
[]
@{"when" true "when-not" true "if-let" true "when-let" true "if-some" true "when-some" true "doto" true "defn" true "defn-" true "declare" true "fn" true "let" true "defrecord" true "defprotocol" true "extend-type" true "extend-protocol" true "extend" true "reify" true "proxy" true "definterface" true "comment" true})
@{"and" true "or" true "when" true "when-not" true "if-let" true "when-let" true "if-some" true "when-some" true "doto" true "defn" true "defn-" true "declare" true "fn" true "let" true "loop" true "defrecord" true "defprotocol" true "extend-type" true "extend-protocol" true "extend" true "reify" true "proxy" true "definterface" true "comment" true})
(def init-core!
(fn [& args]

21
src/jolt/evaluator.janet
View file

@ -496,7 +496,7 @@
"locking" (eval-form ctx bindings (in form 2))
"instance?" (let [type-sym (in form 1)
val (eval-form ctx bindings (in form 2))]
(if (and (struct? val) (get val :jolt/deftype))
(if (get val :jolt/deftype)
(let [type-tag (val :jolt/deftype)
type-name (type-sym :name)]
(or (= type-tag type-name)
@ -588,19 +588,28 @@
(apply ctor args))
"." (let [target (eval-form ctx bindings (in form 1))
member-sym (in form 2)
member-name (member-sym :name)]
member-name (member-sym :name)
field-name (if (and (> (length member-name) 0) (= "-" (string/slice member-name 0 1)))
(string/slice member-name 1)
member-name)]
(if (> (length form) 3)
# method call: (. obj method args...)
(let [args (map |(eval-form ctx bindings $) (tuple/slice form 3))]
(if (target :jolt/deftype)
(let [method-key (keyword member-name)]
(let [method-key (keyword field-name)]
(apply (get target method-key) target ;args))
(error (string "Cannot call method " member-name " on non-deftype"))))
(error (string "Cannot call method " field-name " on non-deftype"))))
# field access: (. obj field)
(get target (keyword member-name))))
(get target (keyword field-name))))
# default: function application — check for macros
(if (and (struct? first-form) (= :symbol (first-form :jolt/type)))
(let [sym-name (first-form :name)]
# Handle .-fieldName accessor: (.-cnt obj) → (. obj -cnt)
(if (and (> (length sym-name) 1) (= (string/slice sym-name 0 2) ".-")
(> (length form) 1))
(let [field-name (string/slice sym-name 2)
target (eval-form ctx bindings (in form 1))]
(get target (keyword field-name)))
# Handle ClassName. constructor syntax
(if (and (> (length sym-name) 0) (= (sym-name (- (length sym-name) 1)) 46))
(let [type-name (string/slice sym-name 0 (- (length sym-name) 1))
@ -615,7 +624,7 @@
(eval-form ctx bindings (apply macro-fn args)))
(let [f (eval-form ctx bindings first-form)
args (map |(eval-form ctx bindings $) (tuple/slice form 1))]
(apply f args))))))
(apply f args)))))))
(let [f (eval-form ctx bindings first-form)
args (map |(eval-form ctx bindings $) (tuple/slice form 1))]
(if (function? f)