3 Commits

Author SHA1 Message Date
0da39de68a kernel: Phase 3 $vau/$lambda/wrap/unwrap + 34 tests [shapes-reflective]
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 27s
User-defined operatives via $vau; applicatives via $lambda (wrap ∘ $vau).
wrap/unwrap as Kernel-level applicatives. kernel-call-operative forks
on :impl (primitive) vs :body (user) tag. kernel-base-env wires the
four combiners + operative?/applicative? predicates. Env-param sentinel
`_` / `#ignore` → :knl-ignore (skip dyn-env bind). Flat parameter list
only; destructuring later. Headline test: custom applicative + custom
operative composed from user code.
2026-05-11 07:43:45 +00:00
7e57e0b215 kernel: Phase 2 evaluator — lookup-and-combine + 36 tests [shapes-reflective]
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 43s
kernel-eval/kernel-combine dispatch on tagged values: operatives see
un-evaluated args + dynamic env; applicatives evaluate args then recurse.
No hardcoded special forms — $if/$quote tested as ordinary operatives
built on the fly. Pure-SX env representation
{:knl-tag :env :bindings DICT :parent P}, surfaced as a candidate
lib/guest/reflective/env.sx API since SX make-env is HTTP-mode only.
2026-05-10 20:50:42 +00:00
cbba642d7f kernel: Phase 1 parser — s-expr reader + 54 tests [consumes-lex]
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 49s
R-1RK lexical syntax: numbers, strings, symbols, #t/#f, (), nested lists,
; comments. Strings wrap as {:knl-string ...} to distinguish from symbols
(bare SX strings). Reader macros deferred to Phase 6 per plan.
Consumes lib/guest/lex.sx character predicates.
2026-05-10 20:42:53 +00:00
13 changed files with 1367 additions and 300 deletions

View File

@@ -1279,7 +1279,7 @@ let run_foundation_tests () =
assert_true "sx_truthy \"\"" (Bool (sx_truthy (String "")));
assert_eq "not truthy nil" (Bool false) (Bool (sx_truthy Nil));
assert_eq "not truthy false" (Bool false) (Bool (sx_truthy (Bool false)));
let l = { l_params = ["x"]; l_body = Symbol "x"; l_closure = Sx_types.make_env (); l_name = None; l_compiled = None; l_call_count = 0 } in
let l = { l_params = ["x"]; l_body = Symbol "x"; l_closure = Sx_types.make_env (); l_name = None; l_compiled = None } in
assert_true "is_lambda" (Bool (Sx_types.is_lambda (Lambda l)));
ignore (Sx_types.set_lambda_name (Lambda l) "my-fn");
assert_eq "lambda name mutated" (String "my-fn") (lambda_name (Lambda l))

View File

@@ -4109,25 +4109,4 @@ let () =
| k :: v :: rest -> ignore (env_bind child (value_to_string k) v); add_bindings rest
| [_] -> raise (Eval_error "env-extend: odd number of key-val pairs") in
add_bindings pairs;
Env child);
(* JIT cache control & observability — backed by refs in sx_types.ml to
avoid creating a sx_primitives → sx_vm dependency cycle. sx_vm reads
these refs to decide when to JIT. *)
register "jit-stats" (fun _args ->
let d = Hashtbl.create 8 in
Hashtbl.replace d "threshold" (Number (float_of_int !Sx_types.jit_threshold));
Hashtbl.replace d "compiled" (Number (float_of_int !Sx_types.jit_compiled_count));
Hashtbl.replace d "compile-failed" (Number (float_of_int !Sx_types.jit_skipped_count));
Hashtbl.replace d "below-threshold" (Number (float_of_int !Sx_types.jit_threshold_skipped_count));
Dict d);
register "jit-set-threshold!" (fun args ->
match args with
| [Number n] -> Sx_types.jit_threshold := int_of_float n; Nil
| [Integer n] -> Sx_types.jit_threshold := n; Nil
| _ -> raise (Eval_error "jit-set-threshold!: (n) where n is integer"));
register "jit-reset-counters!" (fun _args ->
Sx_types.jit_compiled_count := 0;
Sx_types.jit_skipped_count := 0;
Sx_types.jit_threshold_skipped_count := 0;
Nil)
Env child)

View File

@@ -138,7 +138,6 @@ and lambda = {
l_closure : env;
mutable l_name : string option;
mutable l_compiled : vm_closure option; (** Lazy JIT cache *)
mutable l_call_count : int; (** Tiered-compilation counter — JIT after threshold calls *)
}
and component = {
@@ -450,20 +449,7 @@ let make_lambda params body closure =
| List items -> List.map value_to_string items
| _ -> value_to_string_list params
in
Lambda { l_params = ps; l_body = body; l_closure = unwrap_env_val closure; l_name = None; l_compiled = None; l_call_count = 0 }
(** {1 JIT cache control}
Tiered compilation: only JIT a lambda after it's been called [jit_threshold]
times. This filters out one-shot lambdas (test harness, dynamic eval, REPLs)
so they never enter the JIT cache. Counters are exposed to SX as [(jit-stats)].
These live here (in sx_types) rather than sx_vm so [sx_primitives] can read
them without creating a sx_primitives → sx_vm dependency cycle. *)
let jit_threshold = ref 4
let jit_compiled_count = ref 0
let jit_skipped_count = ref 0
let jit_threshold_skipped_count = ref 0
Lambda { l_params = ps; l_body = body; l_closure = unwrap_env_val closure; l_name = None; l_compiled = None }
let make_component name params has_children body closure affinity =
let n = value_to_string name in

View File

@@ -57,9 +57,6 @@ let () = Sx_types._convert_vm_suspension := (fun exn ->
let jit_compile_ref : (lambda -> (string, value) Hashtbl.t -> vm_closure option) ref =
ref (fun _ _ -> None)
(* JIT threshold and counters live in Sx_types so primitives can read them
without creating a sx_primitives → sx_vm dependency cycle. *)
(** Sentinel closure indicating JIT compilation was attempted and failed.
Prevents retrying compilation on every call. *)
let jit_failed_sentinel = {
@@ -367,21 +364,13 @@ and vm_call vm f args =
| None ->
if l.l_name <> None
then begin
l.l_call_count <- l.l_call_count + 1;
if l.l_call_count >= !Sx_types.jit_threshold then begin
l.l_compiled <- Some jit_failed_sentinel;
match !jit_compile_ref l vm.globals with
| Some cl ->
incr Sx_types.jit_compiled_count;
l.l_compiled <- Some cl;
push_closure_frame vm cl args
| None ->
incr Sx_types.jit_skipped_count;
push vm (cek_call_or_suspend vm f (List args))
end else begin
incr Sx_types.jit_threshold_skipped_count;
l.l_compiled <- Some jit_failed_sentinel;
match !jit_compile_ref l vm.globals with
| Some cl ->
l.l_compiled <- Some cl;
push_closure_frame vm cl args
| None ->
push vm (cek_call_or_suspend vm f (List args))
end
end
else
push vm (cek_call_or_suspend vm f (List args)))

216
lib/kernel/eval.sx Normal file
View File

@@ -0,0 +1,216 @@
;; lib/kernel/eval.sx — Kernel evaluator.
;;
;; The evaluator is `lookup-and-combine`: there are no hardcoded special
;; forms. Even $if / $define! / $lambda are ordinary operatives bound in
;; the standard environment (Phase 4). This file builds the dispatch
;; machinery and the operative/applicative tagged-value protocol.
;;
;; Tagged values
;; -------------
;; {:knl-tag :env :bindings DICT :parent PARENT-OR-NIL}
;; A first-class Kernel environment. Bindings is a mutable SX dict
;; keyed by symbol name; parent walks up the lookup chain.
;;
;; {:knl-tag :operative :impl FN}
;; Primitive operative. FN receives (args dyn-env) — args are the
;; UN-evaluated argument expressions, dyn-env is the calling env.
;;
;; {:knl-tag :operative :params P :env-param EP :body B :static-env SE}
;; User-defined operative (built by $vau). Same tag; dispatch in
;; kernel-call-operative forks on which keys are present.
;;
;; {:knl-tag :applicative :underlying OP}
;; An applicative wraps an operative. Calls evaluate args first,
;; then forward to the underlying operative.
;;
;; The env-param of a user operative may be the sentinel :knl-ignore,
;; in which case the dynamic env is not bound.
;;
;; Public API
;; (kernel-eval EXPR ENV) — primary entry
;; (kernel-combine COMBINER ARGS DYN-ENV)
;; (kernel-call-operative OP ARGS DYN-ENV)
;; (kernel-bind-params! ENV PARAMS ARGS)
;; (kernel-make-env) / (kernel-extend-env P)
;; (kernel-env-bind! E N V) / (kernel-env-lookup E N)
;; (kernel-env-has? E N) / (kernel-env? V)
;; (kernel-make-primitive-operative IMPL)
;; (kernel-make-primitive-applicative IMPL)
;; (kernel-make-user-operative PARAMS EPARAM BODY STATIC-ENV)
;; (kernel-wrap OP) / (kernel-unwrap APP)
;; (kernel-operative? V) / (kernel-applicative? V) / (kernel-combiner? V)
;;
;; Consumes: lib/kernel/parser.sx (kernel-string?, kernel-string-value)
;; ── Environments — first-class, pure-SX (binding dict + parent) ──
(define kernel-env? (fn (v) (and (dict? v) (= (get v :knl-tag) :env))))
(define kernel-make-env (fn () {:parent nil :knl-tag :env :bindings {}}))
(define kernel-extend-env (fn (parent) {:parent parent :knl-tag :env :bindings {}}))
(define
kernel-env-bind!
(fn (env name val) (dict-set! (get env :bindings) name val) val))
(define
kernel-env-has?
(fn
(env name)
(cond
((nil? env) false)
((not (kernel-env? env)) false)
((dict-has? (get env :bindings) name) true)
(:else (kernel-env-has? (get env :parent) name)))))
(define
kernel-env-lookup
(fn
(env name)
(cond
((nil? env) (error (str "kernel-eval: unbound symbol: " name)))
((not (kernel-env? env))
(error (str "kernel-eval: corrupt env: " env)))
((dict-has? (get env :bindings) name) (get (get env :bindings) name))
(:else (kernel-env-lookup (get env :parent) name)))))
;; ── Tagged-value constructors and predicates ─────────────────────
(define kernel-make-primitive-operative (fn (impl) {:impl impl :knl-tag :operative}))
(define
kernel-make-user-operative
(fn (params eparam body static-env) {:knl-tag :operative :static-env static-env :params params :body body :env-param eparam}))
(define
kernel-operative?
(fn (v) (and (dict? v) (= (get v :knl-tag) :operative))))
(define
kernel-applicative?
(fn (v) (and (dict? v) (= (get v :knl-tag) :applicative))))
(define
kernel-combiner?
(fn (v) (or (kernel-operative? v) (kernel-applicative? v))))
(define
kernel-wrap
(fn
(op)
(cond
((kernel-operative? op) {:knl-tag :applicative :underlying op})
(:else (error "kernel-wrap: argument must be an operative")))))
(define
kernel-unwrap
(fn
(app)
(cond
((kernel-applicative? app) (get app :underlying))
(:else (error "kernel-unwrap: argument must be an applicative")))))
(define
kernel-make-primitive-applicative
(fn
(impl)
(kernel-wrap
(kernel-make-primitive-operative (fn (args dyn-env) (impl args))))))
;; ── The evaluator ────────────────────────────────────────────────
(define
kernel-eval
(fn
(expr env)
(cond
((number? expr) expr)
((boolean? expr) expr)
((nil? expr) expr)
((kernel-string? expr) (kernel-string-value expr))
((string? expr) (kernel-env-lookup env expr))
((list? expr)
(cond
((= (length expr) 0) expr)
(:else
(let
((combiner (kernel-eval (first expr) env))
(args (rest expr)))
(kernel-combine combiner args env)))))
(:else (error (str "kernel-eval: unknown form: " expr))))))
(define
kernel-combine
(fn
(combiner args dyn-env)
(cond
((kernel-operative? combiner)
(kernel-call-operative combiner args dyn-env))
((kernel-applicative? combiner)
(kernel-combine
(get combiner :underlying)
(kernel-eval-args args dyn-env)
dyn-env))
(:else (error (str "kernel-eval: not a combiner: " combiner))))))
;; Operatives may be primitive (:impl is a host fn) or user-defined
;; (carry :params / :env-param / :body / :static-env). The dispatch
;; fork is here so kernel-combine stays small.
(define
kernel-call-operative
(fn
(op args dyn-env)
(cond
((dict-has? op :impl) ((get op :impl) args dyn-env))
((dict-has? op :body)
(let
((local (kernel-extend-env (get op :static-env))))
(kernel-bind-params! local (get op :params) args)
(let
((eparam (get op :env-param)))
(when
(not (= eparam :knl-ignore))
(kernel-env-bind! local eparam dyn-env)))
(kernel-eval (get op :body) local)))
(:else (error "kernel-call-operative: malformed operative")))))
;; Phase 3 supports a flat parameter list only — destructuring later.
(define
kernel-bind-params!
(fn
(env params args)
(cond
((or (nil? params) (= (length params) 0))
(cond
((or (nil? args) (= (length args) 0)) nil)
(:else (error "kernel-call: too many arguments"))))
((or (nil? args) (= (length args) 0))
(error "kernel-call: too few arguments"))
(:else
(begin
(kernel-env-bind! env (first params) (first args))
(kernel-bind-params! env (rest params) (rest args)))))))
(define
kernel-eval-args
(fn
(args env)
(cond
((or (nil? args) (= (length args) 0)) (list))
(:else
(cons
(kernel-eval (first args) env)
(kernel-eval-args (rest args) env))))))
(define
kernel-eval-program
(fn
(forms env)
(cond
((or (nil? forms) (= (length forms) 0)) nil)
((= (length forms) 1) (kernel-eval (first forms) env))
(:else
(begin
(kernel-eval (first forms) env)
(kernel-eval-program (rest forms) env))))))

240
lib/kernel/parser.sx Normal file
View File

@@ -0,0 +1,240 @@
;; lib/kernel/parser.sx — Kernel s-expression reader.
;;
;; Reads R-1RK lexical syntax: numbers, strings, symbols, booleans (#t/#f),
;; the empty list (), nested lists, and ; line comments. Reader macros
;; (' ` , ,@) deferred to Phase 6 per the plan.
;;
;; Public AST shape:
;; number → SX number
;; #t / #f → SX true / false
;; () → SX empty list (Kernel's nil — the empty list)
;; "..." → {:knl-string "..."} wrapped to distinguish from symbols
;; foo → "foo" bare SX string is a Kernel symbol
;; (a b c) → SX list of forms
;;
;; Public API:
;; (kernel-parse SRC) — first form; errors on extra trailing input
;; (kernel-parse-all SRC) — all top-level forms, as SX list
;; (kernel-string? V) — recognise wrapped string literal
;; (kernel-string-value V) — extract the underlying string
;;
;; Consumes: lib/guest/lex.sx (lex-digit?, lex-whitespace?)
(define kernel-string-make (fn (s) {:knl-string s}))
(define
kernel-string?
(fn (v) (and (dict? v) (string? (get v :knl-string)))))
(define kernel-string-value (fn (v) (get v :knl-string)))
;; Atom delimiters: characters that end a symbol or numeric token.
(define
knl-delim?
(fn
(c)
(or
(nil? c)
(lex-whitespace? c)
(= c "(")
(= c ")")
(= c "\"")
(= c ";"))))
;; Numeric grammar: [+-]? (digit+ ('.' digit+)? | '.' digit+) ([eE][+-]?digit+)?
(define
knl-numeric?
(fn
(s)
(let
((n (string-length s)))
(cond
((= n 0) false)
(:else
(let
((c0 (substring s 0 1)))
(let
((start (if (or (= c0 "+") (= c0 "-")) 1 0)))
(knl-num-body? s start n))))))))
(define
knl-num-body?
(fn
(s start n)
(cond
((>= start n) false)
((= (substring s start (+ start 1)) ".")
(knl-num-need-digits? s (+ start 1) n false))
((lex-digit? (substring s start (+ start 1)))
(knl-num-int-tail? s (+ start 1) n))
(:else false))))
(define
knl-num-int-tail?
(fn
(s i n)
(cond
((>= i n) true)
((lex-digit? (substring s i (+ i 1)))
(knl-num-int-tail? s (+ i 1) n))
((= (substring s i (+ i 1)) ".")
(knl-num-need-digits? s (+ i 1) n true))
((or (= (substring s i (+ i 1)) "e") (= (substring s i (+ i 1)) "E"))
(knl-num-exp-sign? s (+ i 1) n))
(:else false))))
(define
knl-num-need-digits?
(fn
(s i n had-int)
(cond
((>= i n) had-int)
((lex-digit? (substring s i (+ i 1)))
(knl-num-frac-tail? s (+ i 1) n))
(:else false))))
(define
knl-num-frac-tail?
(fn
(s i n)
(cond
((>= i n) true)
((lex-digit? (substring s i (+ i 1)))
(knl-num-frac-tail? s (+ i 1) n))
((or (= (substring s i (+ i 1)) "e") (= (substring s i (+ i 1)) "E"))
(knl-num-exp-sign? s (+ i 1) n))
(:else false))))
(define
knl-num-exp-sign?
(fn
(s i n)
(cond
((>= i n) false)
((or (= (substring s i (+ i 1)) "+") (= (substring s i (+ i 1)) "-"))
(knl-num-exp-digits? s (+ i 1) n false))
(:else (knl-num-exp-digits? s i n false)))))
(define
knl-num-exp-digits?
(fn
(s i n had)
(cond
((>= i n) had)
((lex-digit? (substring s i (+ i 1)))
(knl-num-exp-digits? s (+ i 1) n true))
(:else false))))
;; Reader: a closure over (src, pos). Exposes :read-form and :read-all.
(define
knl-make-reader
(fn
(src)
(let
((pos 0) (n (string-length src)))
(define
at
(fn () (if (< pos n) (substring src pos (+ pos 1)) nil)))
(define adv (fn () (set! pos (+ pos 1))))
(define
skip-line
(fn () (when (and (at) (not (= (at) "\n"))) (adv) (skip-line))))
(define
skip-ws
(fn
()
(cond
((nil? (at)) nil)
((lex-whitespace? (at)) (do (adv) (skip-ws)))
((= (at) ";") (do (adv) (skip-line) (skip-ws)))
(:else nil))))
(define
read-string-body
(fn
(acc)
(cond
((nil? (at)) (error "kernel-parse: unterminated string"))
((= (at) "\"") (do (adv) acc))
((= (at) "\\")
(do
(adv)
(let
((c (at)))
(when (nil? c) (error "kernel-parse: trailing backslash"))
(adv)
(read-string-body
(str
acc
(cond
((= c "n") "\n")
((= c "t") "\t")
((= c "r") "\r")
((= c "\"") "\"")
((= c "\\") "\\")
(:else c)))))))
(:else
(let ((c (at))) (adv) (read-string-body (str acc c)))))))
(define
read-atom-body
(fn
(acc)
(cond
((knl-delim? (at)) acc)
(:else (let ((c (at))) (adv) (read-atom-body (str acc c)))))))
(define
classify-atom
(fn
(s)
(cond
((= s "#t") true)
((= s "#f") false)
((knl-numeric? s) (string->number s))
(:else s))))
(define
read-form
(fn
()
(skip-ws)
(cond
((nil? (at)) :knl-eof)
((= (at) ")") (error "kernel-parse: unexpected ')'"))
((= (at) "(") (do (adv) (read-list (list))))
((= (at) "\"")
(do (adv) (kernel-string-make (read-string-body ""))))
(:else (classify-atom (read-atom-body ""))))))
(define
read-list
(fn
(acc)
(skip-ws)
(cond
((nil? (at)) (error "kernel-parse: unterminated list"))
((= (at) ")") (do (adv) acc))
(:else (read-list (append acc (list (read-form))))))))
(define
read-all
(fn
(acc)
(skip-ws)
(if (nil? (at)) acc (read-all (append acc (list (read-form)))))))
{:read-form read-form :read-all read-all})))
(define
kernel-parse-all
(fn (src) ((get (knl-make-reader src) :read-all) (list))))
(define
kernel-parse
(fn
(src)
(let
((r (knl-make-reader src)))
(let
((form ((get r :read-form))))
(cond
((= form :knl-eof) (error "kernel-parse: empty input"))
(:else
(let
((next ((get r :read-form))))
(if
(= next :knl-eof)
form
(error "kernel-parse: trailing input after first form")))))))))

167
lib/kernel/runtime.sx Normal file
View File

@@ -0,0 +1,167 @@
;; lib/kernel/runtime.sx — the operativeapplicative substrate.
;;
;; Builds the first user-visible operatives so Kernel programs can
;; construct their own combiners:
;;
;; $vau — primitive operative that returns a user operative
;; $lambda — primitive operative; sugar for (wrap ($vau …))
;; wrap — primitive applicative; wraps an operative
;; unwrap — primitive applicative; extracts the underlying op
;;
;; In Kernel, $lambda is *defined* in terms of $vau and wrap:
;; ($define! $lambda
;; ($vau (formals . body) #ignore
;; (wrap (eval (list $vau formals #ignore (cons $sequence body)) env))))
;; Phase 3 supplies it natively (single-expression body) so tests can
;; build applicatives without a working $define!/$sequence yet. The
;; native-then-portable migration is a Phase 4 concern.
;;
;; The env-param sentinel
;; ----------------------
;; A user operative records an `:env-param` slot. If the source said
;; `#ignore`, the slot holds the keyword :knl-ignore and kernel-call-
;; operative skips binding the dynamic env. The parser doesn't recognise
;; `#ignore` yet (Phase 1 covered #t/#f only); guests must spell it
;; `_` for now — the spelling-to-sentinel conversion lives here in
;; knl-eparam-sentinel.
;;
;; Public API
;; (kernel-base-env) — fresh env with $vau, $lambda, wrap, unwrap
;;
;; Consumes: lib/kernel/eval.sx (everything tagged kernel-*).
(define
knl-eparam-sentinel
(fn
(sym)
(cond
((= sym "_") :knl-ignore)
((= sym "#ignore") :knl-ignore)
(:else sym))))
;; Validate that a formals list is a plain list of symbol names.
(define
knl-formals-ok?
(fn
(formals)
(cond
((not (list? formals)) false)
((= (length formals) 0) true)
((string? (first formals)) (knl-formals-ok? (rest formals)))
(:else false))))
;; ── $vau ─────────────────────────────────────────────────────────
;; ($vau FORMALS ENV-PARAM BODY) → user operative.
;;
;; FORMALS — unevaluated list of parameter symbols.
;; ENV-PARAM — symbol (or `_` / `#ignore`).
;; BODY — single expression (Phase 3 limitation; $sequence later).
;;
;; The returned operative closes over the env where $vau was invoked.
(define
kernel-vau-impl
(fn
(args dyn-env)
(cond
((not (= (length args) 3))
(error "$vau: expects (formals env-param body)"))
(:else
(let
((formals (first args))
(eparam-raw (nth args 1))
(body (nth args 2)))
(cond
((not (knl-formals-ok? formals))
(error "$vau: formals must be a list of symbols"))
((not (string? eparam-raw))
(error "$vau: env-param must be a symbol"))
(:else
(kernel-make-user-operative
formals
(knl-eparam-sentinel eparam-raw)
body
dyn-env))))))))
(define
kernel-vau-operative
(kernel-make-primitive-operative kernel-vau-impl))
;; ── $lambda ──────────────────────────────────────────────────────
;; ($lambda FORMALS BODY) → user applicative.
;;
;; Equivalent to (wrap ($vau FORMALS #ignore BODY)) — args are evaluated
;; before the operative body runs, and the operative ignores the dynamic
;; environment.
(define
kernel-lambda-impl
(fn
(args dyn-env)
(cond
((not (= (length args) 2))
(error "$lambda: expects (formals body)"))
(:else
(let
((formals (first args)) (body (nth args 1)))
(cond
((not (knl-formals-ok? formals))
(error "$lambda: formals must be a list of symbols"))
(:else
(kernel-wrap
(kernel-make-user-operative formals :knl-ignore body dyn-env)))))))))
(define
kernel-lambda-operative
(kernel-make-primitive-operative kernel-lambda-impl))
;; ── wrap / unwrap as Kernel applicatives ─────────────────────────
(define
kernel-wrap-applicative
(kernel-make-primitive-applicative
(fn
(args)
(cond
((not (= (length args) 1))
(error "wrap: expects exactly 1 argument"))
(:else (kernel-wrap (first args)))))))
(define
kernel-unwrap-applicative
(kernel-make-primitive-applicative
(fn
(args)
(cond
((not (= (length args) 1))
(error "unwrap: expects exactly 1 argument"))
(:else (kernel-unwrap (first args)))))))
;; Convenience predicates as applicatives too — tests want them.
(define
kernel-operative?-applicative
(kernel-make-primitive-applicative
(fn (args) (kernel-operative? (first args)))))
(define
kernel-applicative?-applicative
(kernel-make-primitive-applicative
(fn (args) (kernel-applicative? (first args)))))
;; ── Base environment ─────────────────────────────────────────────
;; A fresh env with the Phase 3 combiners bound. Standard env (Phase 4)
;; will extend this with $if, $define!, arithmetic, list ops, etc.
(define
kernel-base-env
(fn
()
(let
((env (kernel-make-env)))
(kernel-env-bind! env "$vau" kernel-vau-operative)
(kernel-env-bind! env "$lambda" kernel-lambda-operative)
(kernel-env-bind! env "wrap" kernel-wrap-applicative)
(kernel-env-bind! env "unwrap" kernel-unwrap-applicative)
(kernel-env-bind! env "operative?" kernel-operative?-applicative)
(kernel-env-bind! env "applicative?" kernel-applicative?-applicative)
env)))

270
lib/kernel/tests/eval.sx Normal file
View File

@@ -0,0 +1,270 @@
;; lib/kernel/tests/eval.sx — exercises lib/kernel/eval.sx.
;;
;; Phase 2 covers literal evaluation, symbol lookup, and combiner
;; dispatch (operative vs applicative). Standard-environment operatives
;; ($if, $define!, $lambda, …) arrive in Phase 4, so tests build a
;; minimal env on the fly and verify the dispatch contract directly.
(define ke-test-pass 0)
(define ke-test-fail 0)
(define ke-test-fails (list))
(define
ke-test
(fn
(name actual expected)
(if
(= actual expected)
(set! ke-test-pass (+ ke-test-pass 1))
(begin
(set! ke-test-fail (+ ke-test-fail 1))
(append! ke-test-fails {:name name :actual actual :expected expected})))))
;; ── helpers ──────────────────────────────────────────────────────
(define ke-eval-src (fn (src env) (kernel-eval (kernel-parse src) env)))
(define
ke-make-test-env
(fn
()
(let
((env (kernel-make-env)))
(kernel-env-bind!
env
"+"
(kernel-make-primitive-applicative
(fn (args) (+ (first args) (nth args 1)))))
(kernel-env-bind!
env
"list"
(kernel-make-primitive-applicative (fn (args) args)))
(kernel-env-bind!
env
"$quote"
(kernel-make-primitive-operative (fn (args dyn-env) (first args))))
(kernel-env-bind!
env
"$if"
(kernel-make-primitive-operative
(fn
(args dyn-env)
(if
(kernel-eval (first args) dyn-env)
(kernel-eval (nth args 1) dyn-env)
(kernel-eval (nth args 2) dyn-env)))))
env)))
;; ── literal evaluation ───────────────────────────────────────────
(ke-test "lit: number" (ke-eval-src "42" (kernel-make-env)) 42)
(ke-test "lit: zero" (ke-eval-src "0" (kernel-make-env)) 0)
(ke-test "lit: float" (ke-eval-src "3.14" (kernel-make-env)) 3.14)
(ke-test "lit: true" (ke-eval-src "#t" (kernel-make-env)) true)
(ke-test "lit: false" (ke-eval-src "#f" (kernel-make-env)) false)
(ke-test "lit: string" (ke-eval-src "\"hello\"" (kernel-make-env)) "hello")
(ke-test "lit: empty list" (ke-eval-src "()" (kernel-make-env)) (list))
;; ── symbol lookup ────────────────────────────────────────────────
(ke-test
"sym: bound to number"
(let
((env (kernel-make-env)))
(kernel-env-bind! env "x" 100)
(ke-eval-src "x" env))
100)
(ke-test
"sym: bound to string"
(let
((env (kernel-make-env)))
(kernel-env-bind! env "name" "kernel")
(ke-eval-src "name" env))
"kernel")
(ke-test
"sym: parent-chain lookup"
(let
((p (kernel-make-env)))
(kernel-env-bind! p "outer" 1)
(let
((c (kernel-extend-env p)))
(kernel-env-bind! c "inner" 2)
(+ (ke-eval-src "outer" c) (ke-eval-src "inner" c))))
3)
(ke-test
"sym: child shadows parent"
(let
((p (kernel-make-env)))
(kernel-env-bind! p "x" 1)
(let
((c (kernel-extend-env p)))
(kernel-env-bind! c "x" 2)
(ke-eval-src "x" c)))
2)
(ke-test
"env-has?: present"
(let
((env (kernel-make-env)))
(kernel-env-bind! env "x" 1)
(kernel-env-has? env "x"))
true)
(ke-test
"env-has?: missing"
(kernel-env-has? (kernel-make-env) "nope")
false)
;; ── tagged-value predicates ─────────────────────────────────────
(ke-test
"tag: operative?"
(kernel-operative? (kernel-make-primitive-operative (fn (a e) nil)))
true)
(ke-test
"tag: applicative?"
(kernel-applicative? (kernel-make-primitive-applicative (fn (a) nil)))
true)
(ke-test
"tag: combiner? operative"
(kernel-combiner? (kernel-make-primitive-operative (fn (a e) nil)))
true)
(ke-test
"tag: combiner? applicative"
(kernel-combiner? (kernel-make-primitive-applicative (fn (a) nil)))
true)
(ke-test "tag: combiner? number" (kernel-combiner? 42) false)
(ke-test "tag: number is not operative" (kernel-operative? 42) false)
;; ── wrap / unwrap ────────────────────────────────────────────────
(ke-test
"wrap+unwrap roundtrip"
(let
((op (kernel-make-primitive-operative (fn (a e) :sentinel))))
(= (kernel-unwrap (kernel-wrap op)) op))
true)
(ke-test
"wrap produces applicative"
(kernel-applicative?
(kernel-wrap (kernel-make-primitive-operative (fn (a e) nil))))
true)
(ke-test
"unwrap of primitive-applicative is operative"
(kernel-operative?
(kernel-unwrap (kernel-make-primitive-applicative (fn (a) nil))))
true)
;; ── combiner dispatch — applicatives evaluate their args ─────────
(ke-test
"applicative: simple call"
(ke-eval-src "(+ 2 3)" (ke-make-test-env))
5)
(ke-test
"applicative: nested"
(ke-eval-src "(+ (+ 1 2) (+ 3 4))" (ke-make-test-env))
10)
(ke-test
"applicative: receives evaluated args"
(let
((env (ke-make-test-env)))
(kernel-env-bind! env "x" 10)
(kernel-env-bind! env "y" 20)
(ke-eval-src "(+ x y)" env))
30)
(ke-test
"applicative: list builds an SX list of values"
(let
((env (ke-make-test-env)))
(kernel-env-bind! env "a" 1)
(kernel-env-bind! env "b" 2)
(ke-eval-src "(list a b 99)" env))
(list 1 2 99))
;; ── combiner dispatch — operatives DO NOT evaluate their args ───
(ke-test
"operative: $quote returns symbol unevaluated"
(ke-eval-src "($quote foo)" (ke-make-test-env))
"foo")
(ke-test
"operative: $quote returns list unevaluated"
(ke-eval-src "($quote (+ 1 2))" (ke-make-test-env))
(list "+" 1 2))
(ke-test
"operative: $if true branch"
(ke-eval-src "($if #t 1 2)" (ke-make-test-env))
1)
(ke-test
"operative: $if false branch"
(ke-eval-src "($if #f 1 2)" (ke-make-test-env))
2)
(ke-test
"operative: $if doesn't eval untaken branch"
(ke-eval-src "($if #t 99 unbound)" (ke-make-test-env))
99)
(ke-test
"operative: $if takes dynamic env for branches"
(let
((env (ke-make-test-env)))
(kernel-env-bind! env "x" 7)
(ke-eval-src "($if #t x 0)" env))
7)
;; ── operative built ON-THE-FLY can inspect raw expressions ──────
(ke-test
"operative: sees raw symbol head"
(let
((env (kernel-make-env)))
(kernel-env-bind!
env
"head"
(kernel-make-primitive-operative (fn (args dyn-env) (first args))))
(ke-eval-src "(head (+ 1 2))" env))
(list "+" 1 2))
(ke-test
"operative: sees dynamic env"
(let
((env (kernel-make-env)))
(kernel-env-bind! env "x" 999)
(kernel-env-bind!
env
"$probe"
(kernel-make-primitive-operative
(fn (args dyn-env) (kernel-env-lookup dyn-env "x"))))
(ke-eval-src "($probe ignored)" env))
999)
;; ── error cases ──────────────────────────────────────────────────
(ke-test
"error: unbound symbol"
(guard
(e (true :raised))
(kernel-eval (kernel-parse "nope") (kernel-make-env)))
:raised)
(ke-test
"error: combine non-combiner"
(guard
(e (true :raised))
(let
((env (kernel-make-env)))
(kernel-env-bind! env "x" 42)
(kernel-eval (kernel-parse "(x 1)") env)))
:raised)
(define ke-tests-run! (fn () {:total (+ ke-test-pass ke-test-fail) :passed ke-test-pass :failed ke-test-fail :fails ke-test-fails}))

134
lib/kernel/tests/parse.sx Normal file
View File

@@ -0,0 +1,134 @@
;; lib/kernel/tests/parse.sx — exercises lib/kernel/parser.sx.
(define knl-test-pass 0)
(define knl-test-fail 0)
(define knl-test-fails (list))
(define
knl-test
(fn
(name actual expected)
(if
(= actual expected)
(set! knl-test-pass (+ knl-test-pass 1))
(begin
(set! knl-test-fail (+ knl-test-fail 1))
(append! knl-test-fails {:name name :actual actual :expected expected})))))
;; ── atoms: numbers ────────────────────────────────────────────────
(knl-test "num: integer" (kernel-parse "42") 42)
(knl-test "num: zero" (kernel-parse "0") 0)
(knl-test "num: negative integer" (kernel-parse "-7") -7)
(knl-test "num: positive sign" (kernel-parse "+5") 5)
(knl-test "num: float" (kernel-parse "3.14") 3.14)
(knl-test "num: negative float" (kernel-parse "-2.5") -2.5)
(knl-test "num: leading dot" (kernel-parse ".5") 0.5)
(knl-test "num: exponent" (kernel-parse "1e3") 1000)
(knl-test "num: exponent with sign" (kernel-parse "2.5e-1") 0.25)
(knl-test "num: capital E exponent" (kernel-parse "1E2") 100)
;; ── atoms: booleans ───────────────────────────────────────────────
(knl-test "bool: true" (kernel-parse "#t") true)
(knl-test "bool: false" (kernel-parse "#f") false)
;; ── atoms: empty list (Kernel nil) ────────────────────────────────
(knl-test "nil: ()" (kernel-parse "()") (list))
(knl-test "nil: (= () (list))" (= (kernel-parse "()") (list)) true)
;; ── atoms: symbols ────────────────────────────────────────────────
(knl-test "sym: word" (kernel-parse "foo") "foo")
(knl-test "sym: hyphenated" (kernel-parse "foo-bar") "foo-bar")
(knl-test "sym: dollar-bang" (kernel-parse "$define!") "$define!")
(knl-test "sym: question" (kernel-parse "null?") "null?")
(knl-test "sym: lt-eq" (kernel-parse "<=") "<=")
(knl-test "sym: bare plus" (kernel-parse "+") "+")
(knl-test "sym: bare minus" (kernel-parse "-") "-")
(knl-test "sym: plus-letter" (kernel-parse "+a") "+a")
(knl-test "sym: arrow" (kernel-parse "->") "->")
(knl-test "sym: dot-prefixed" (kernel-parse ".foo") ".foo")
;; ── atoms: strings ────────────────────────────────────────────────
(knl-test "str: empty" (kernel-string-value (kernel-parse "\"\"")) "")
(knl-test
"str: hello"
(kernel-string-value (kernel-parse "\"hello\""))
"hello")
(knl-test "str: predicate" (kernel-string? (kernel-parse "\"x\"")) true)
(knl-test "str: not symbol" (kernel-string? (kernel-parse "x")) false)
(knl-test
"str: escape newline"
(kernel-string-value (kernel-parse "\"a\\nb\""))
"a\nb")
(knl-test
"str: escape tab"
(kernel-string-value (kernel-parse "\"a\\tb\""))
"a\tb")
(knl-test
"str: escape quote"
(kernel-string-value (kernel-parse "\"a\\\"b\""))
"a\"b")
(knl-test
"str: escape backslash"
(kernel-string-value (kernel-parse "\"a\\\\b\""))
"a\\b")
;; ── lists ─────────────────────────────────────────────────────────
(knl-test "list: flat" (kernel-parse "(a b c)") (list "a" "b" "c"))
(knl-test
"list: nested"
(kernel-parse "(a (b c) d)")
(list "a" (list "b" "c") "d"))
(knl-test
"list: deeply nested"
(kernel-parse "(((x)))")
(list (list (list "x"))))
(knl-test
"list: mixed atoms"
(kernel-parse "(1 #t foo)")
(list 1 true "foo"))
(knl-test
"list: empty inside"
(kernel-parse "(a () b)")
(list "a" (list) "b"))
;; ── whitespace + comments ─────────────────────────────────────────
(knl-test "ws: leading" (kernel-parse " 42") 42)
(knl-test "ws: trailing" (kernel-parse "42 ") 42)
(knl-test "ws: tabs/newlines" (kernel-parse "\n\t 42 \n") 42)
(knl-test "comment: line" (kernel-parse "; nope\n42") 42)
(knl-test "comment: trailing" (kernel-parse "42 ; tail") 42)
(knl-test
"comment: inside list"
(kernel-parse "(a ; mid\n b)")
(list "a" "b"))
;; ── parse-all ─────────────────────────────────────────────────────
(knl-test "all: empty input" (kernel-parse-all "") (list))
(knl-test "all: only whitespace" (kernel-parse-all " ") (list))
(knl-test "all: only comment" (kernel-parse-all "; nope") (list))
(knl-test
"all: three forms"
(kernel-parse-all "1 2 3")
(list 1 2 3))
(knl-test
"all: mixed"
(kernel-parse-all "($if #t 1 2) foo")
(list (list "$if" true 1 2) "foo"))
;; ── classic Kernel programs (smoke) ───────────────────────────────
(knl-test
"klisp: vau form"
(kernel-parse "($vau (x e) e (eval x e))")
(list "$vau" (list "x" "e") "e" (list "eval" "x" "e")))
(knl-test
"klisp: define lambda"
(kernel-parse "($define! sq ($lambda (x) (* x x)))")
(list "$define!" "sq" (list "$lambda" (list "x") (list "*" "x" "x"))))
;; ── round-trip identity for primitive symbols ─────────────────────
(knl-test "identity: $vau" (kernel-parse "$vau") "$vau")
(knl-test "identity: $lambda" (kernel-parse "$lambda") "$lambda")
(knl-test "identity: wrap" (kernel-parse "wrap") "wrap")
(knl-test "identity: unwrap" (kernel-parse "unwrap") "unwrap")
(define knl-tests-run! (fn () {:total (+ knl-test-pass knl-test-fail) :passed knl-test-pass :failed knl-test-fail :fails knl-test-fails}))

289
lib/kernel/tests/vau.sx Normal file
View File

@@ -0,0 +1,289 @@
;; lib/kernel/tests/vau.sx — exercises lib/kernel/runtime.sx.
;;
;; Verifies the Phase 3 promise: user-defined operatives and applicatives
;; constructible from inside the language. Tests build a Kernel
;; base-env, bind a few helper applicatives (+, *, list, =, $if), and
;; run programs that construct and use custom combiners.
(define kv-test-pass 0)
(define kv-test-fail 0)
(define kv-test-fails (list))
(define
kv-test
(fn
(name actual expected)
(if
(= actual expected)
(set! kv-test-pass (+ kv-test-pass 1))
(begin
(set! kv-test-fail (+ kv-test-fail 1))
(append! kv-test-fails {:name name :actual actual :expected expected})))))
(define kv-eval-src (fn (src env) (kernel-eval (kernel-parse src) env)))
(define
kv-make-env
(fn
()
(let
((env (kernel-base-env)))
(kernel-env-bind!
env
"+"
(kernel-make-primitive-applicative
(fn (args) (+ (first args) (nth args 1)))))
(kernel-env-bind!
env
"*"
(kernel-make-primitive-applicative
(fn (args) (* (first args) (nth args 1)))))
(kernel-env-bind!
env
"-"
(kernel-make-primitive-applicative
(fn (args) (- (first args) (nth args 1)))))
(kernel-env-bind!
env
"="
(kernel-make-primitive-applicative
(fn (args) (= (first args) (nth args 1)))))
(kernel-env-bind!
env
"list"
(kernel-make-primitive-applicative (fn (args) args)))
(kernel-env-bind!
env
"cons"
(kernel-make-primitive-applicative
(fn (args) (cons (first args) (nth args 1)))))
(kernel-env-bind!
env
"$quote"
(kernel-make-primitive-operative (fn (args dyn-env) (first args))))
(kernel-env-bind!
env
"$if"
(kernel-make-primitive-operative
(fn
(args dyn-env)
(if
(kernel-eval (first args) dyn-env)
(kernel-eval (nth args 1) dyn-env)
(kernel-eval (nth args 2) dyn-env)))))
env)))
;; ── $vau: builds an operative ───────────────────────────────────
(kv-test
"vau: identity returns first arg unevaluated"
(kv-eval-src "(($vau (a) _ a) hello)" (kv-make-env))
"hello")
(kv-test
"vau: returns args as raw expressions"
(kv-eval-src "(($vau (a b) _ (list a b)) (+ 1 2) (+ 3 4))" (kv-make-env))
(list (list "+" 1 2) (list "+" 3 4)))
(kv-test
"vau: env-param is a kernel env"
(kernel-env? (kv-eval-src "(($vau () e e))" (kv-make-env)))
true)
(kv-test
"vau: returns operative"
(kernel-operative? (kv-eval-src "($vau (x) _ x)" (kv-make-env)))
true)
(kv-test
"vau: returns operative not applicative"
(kernel-applicative? (kv-eval-src "($vau (x) _ x)" (kv-make-env)))
false)
(kv-test
"vau: zero-arg body"
(kv-eval-src "(($vau () _ 42))" (kv-make-env))
42)
(kv-test
"vau: static-env closure captured"
(let
((outer (kv-make-env)))
(kernel-env-bind! outer "captured" 17)
(let
((op (kv-eval-src "($vau () _ captured)" outer))
(caller (kv-make-env)))
(kernel-env-bind! caller "captured" 99)
(kernel-combine op (list) caller)))
17)
(kv-test
"vau: env-param exposes caller's dynamic env"
(let
((outer (kv-make-env)))
(kernel-env-bind! outer "x" 1)
(let
((op (kv-eval-src "($vau () e e)" outer)) (caller (kv-make-env)))
(kernel-env-bind! caller "x" 2)
(let
((e-val (kernel-combine op (list) caller)))
(kernel-env-lookup e-val "x"))))
2)
;; ── $lambda: applicatives evaluate their args ───────────────────
(kv-test
"lambda: identity"
(kv-eval-src "(($lambda (x) x) 42)" (kv-make-env))
42)
(kv-test
"lambda: addition"
(kv-eval-src "(($lambda (x y) (+ x y)) 3 4)" (kv-make-env))
7)
(kv-test
"lambda: args are evaluated before bind"
(kv-eval-src "(($lambda (x) x) (+ 2 3))" (kv-make-env))
5)
(kv-test
"lambda: zero args"
(kv-eval-src "(($lambda () 99))" (kv-make-env))
99)
(kv-test
"lambda: returns applicative"
(kernel-applicative? (kv-eval-src "($lambda (x) x)" (kv-make-env)))
true)
(kv-test
"lambda: returns applicative not operative"
(kernel-operative? (kv-eval-src "($lambda (x) x)" (kv-make-env)))
false)
(kv-test
"lambda: higher-order"
(kv-eval-src "(($lambda (f) (f 10)) ($lambda (x) (+ x 1)))" (kv-make-env))
11)
;; ── wrap / unwrap as user-callable applicatives ─────────────────
(kv-test
"wrap: makes applicative from operative"
(kernel-applicative? (kv-eval-src "(wrap ($vau (x) _ x))" (kv-make-env)))
true)
(kv-test
"wrap: result evaluates its arg"
(kv-eval-src "((wrap ($vau (x) _ x)) (+ 1 2))" (kv-make-env))
3)
(kv-test
"unwrap: extracts operative from applicative"
(kernel-operative? (kv-eval-src "(unwrap ($lambda (x) x))" (kv-make-env)))
true)
(kv-test
"wrap/unwrap roundtrip preserves identity"
(kv-eval-src
"(($lambda (op) (= op (unwrap (wrap op)))) ($vau (x) _ x))"
(kv-make-env))
true)
;; ── operative? / applicative? as user-visible predicates ────────
(kv-test
"operative? on vau result"
(kv-eval-src "(operative? ($vau (x) _ x))" (kv-make-env))
true)
(kv-test
"operative? on lambda result"
(kv-eval-src "(operative? ($lambda (x) x))" (kv-make-env))
false)
(kv-test
"applicative? on lambda result"
(kv-eval-src "(applicative? ($lambda (x) x))" (kv-make-env))
true)
(kv-test
"applicative? on vau result"
(kv-eval-src "(applicative? ($vau (x) _ x))" (kv-make-env))
false)
(kv-test
"operative? on number"
(kv-eval-src "(operative? 42)" (kv-make-env))
false)
;; ── Build BOTH layers from user code ────────────────────────────
;; The headline Phase 3 test: defining an operative on top of an
;; applicative defined on top of a vau.
(kv-test
"custom: applicative + operative compose"
(let
((env (kv-make-env)))
(kernel-env-bind! env "square" (kv-eval-src "($lambda (x) (* x x))" env))
(kv-eval-src "(square 4)" env))
16)
(kv-test "custom: operative captures argument syntax"
;; ($capture x) returns the raw expression `x`, regardless of value.
(let ((env (kv-make-env)))
(kernel-env-bind! env "$capture"
(kv-eval-src "($vau (form) _ form)" env))
(kv-eval-src "($capture (+ 1 2))" env))
(list "+" 1 2))
(kv-test "custom: applicative re-wraps an operative"
;; Build a captured operative, then wrap it into an applicative that
;; evaluates args before re-entry. This exercises wrap+$vau composed.
(let ((env (kv-make-env)))
(kernel-env-bind! env "id-app"
(kv-eval-src "(wrap ($vau (x) _ x))" env))
(kv-eval-src "(id-app (+ 10 20))" env))
30)
;; ── Error cases ──────────────────────────────────────────────────
(kv-test
"vau: rejects non-list formals"
(guard (e (true :raised)) (kv-eval-src "($vau x _ x)" (kv-make-env)))
:raised)
(kv-test
"vau: rejects non-symbol formal"
(guard (e (true :raised)) (kv-eval-src "($vau (1) _ x)" (kv-make-env)))
:raised)
(kv-test
"vau: rejects non-symbol env-param"
(guard (e (true :raised)) (kv-eval-src "($vau (x) 7 x)" (kv-make-env)))
:raised)
(kv-test
"vau: too few args at call site"
(guard
(e (true :raised))
(kv-eval-src "(($vau (x y) _ x) 1)" (kv-make-env)))
:raised)
(kv-test
"vau: too many args at call site"
(guard
(e (true :raised))
(kv-eval-src "(($vau (x) _ x) 1 2)" (kv-make-env)))
:raised)
(kv-test
"wrap: rejects non-operative"
(guard (e (true :raised)) (kv-eval-src "(wrap 42)" (kv-make-env)))
:raised)
(kv-test
"unwrap: rejects non-applicative"
(guard (e (true :raised)) (kv-eval-src "(unwrap 42)" (kv-make-env)))
:raised)
(define kv-tests-run! (fn () {:total (+ kv-test-pass kv-test-fail) :passed kv-test-pass :failed kv-test-fail :fails kv-test-fails}))

View File

@@ -164,22 +164,13 @@ gets the same API for free.
## Rollout
**Phase 1: Tiered compilation — IMPLEMENTED (commit b9d63112)**
- `l_call_count : int` field on lambda type (sx_types.ml)
- ✅ Counter increment + threshold check in cek_call_or_suspend Lambda case (sx_vm.ml)
- ✅ Module-level refs in sx_types: `jit_threshold` (default 4), `jit_compiled_count`,
`jit_skipped_count`, `jit_threshold_skipped_count`. Refs live in sx_types so
sx_primitives can read them without creating an import cycle.
- ✅ Primitives: `jit-stats`, `jit-set-threshold!`, `jit-reset-counters!` (sx_primitives.ml)
- Verified: 4771/1111 OCaml run_tests, identical to baseline — no regressions.
**WASM rollout note:** The native binary has Phase 1 active. The browser
WASM (`shared/static/wasm/sx_browser.bc.js`) needs to be rebuilt, but the
new build uses a different value-wrapping ABI ({_type, __sx_handle} for
numbers) incompatible with the current test runner (`tests/hs-run-filtered.js`).
For now the test tree pins the pre-rewrite WASM. Resolving the ABI gap
is a separate task — either update the test runner to unwrap, or expose
a value-marshalling helper from the kernel.
**Phase 1: Tiered compilation (1-2 days)**
- Add `l_call_count` to lambda type
- Wire counter increment in `cek_call_or_suspend`
- Add `jit-set-threshold!` primitive
- Default threshold = 1 (no change in behavior)
- Bump default to 4 once test suite confirms stability
- Verify: HS conformance full-suite run completes without JIT saturation
**Phase 2: LRU cache (3-5 days)**
- Extract `Lambda.l_compiled` into central `sx_jit_cache.ml`

View File

@@ -56,23 +56,23 @@ The whole interesting thing: there are no special forms hardcoded in the evaluat
## Roadmap
### Phase 1 — Parser
- [ ] S-expression reader with the standard atoms (number, string, symbol, boolean, nil) and lists.
- [x] S-expression reader with the standard atoms (number, string, symbol, boolean, nil) and lists.
- [ ] Reader macros optional; defer to Phase 6.
- [ ] Tests in `lib/kernel/tests/parse.sx`.
- [x] Tests in `lib/kernel/tests/parse.sx`.
### Phase 2 — Core evaluator with first-class environments
- [ ] `kernel-eval expr env` — primary entry, walks AST, threads env as a value.
- [ ] Symbol lookup → environment value (using SX env-as-value primitives).
- [ ] List → look up head, dispatch on tag (applicative vs operative).
- [ ] No hardcoded special forms — even `if`/`define`/`lambda` are env-bound.
- [ ] Tests in `lib/kernel/tests/eval.sx`.
- [x] `kernel-eval expr env` — primary entry, walks AST, threads env as a value.
- [x] Symbol lookup → environment value (using SX env-as-value primitives).
- [x] List → look up head, dispatch on tag (applicative vs operative).
- [x] No hardcoded special forms — even `if`/`define`/`lambda` are env-bound.
- [x] Tests in `lib/kernel/tests/eval.sx`.
### Phase 3 — `$vau` / `$lambda` / `wrap` / `unwrap`
- [ ] Operative tagged value: `{:type :operative :params :env-param :body :static-env}`.
- [ ] Applicative tagged value wraps an operative + the "evaluate args first" contract.
- [ ] `$vau` builds operatives; `$lambda` is `wrap``$vau`.
- [ ] `wrap` / `unwrap` round-trip cleanly.
- [ ] Tests: define a custom operative, define a custom applicative on top of it.
- [x] Operative tagged value: `{:type :operative :params :env-param :body :static-env}`.
- [x] Applicative tagged value wraps an operative + the "evaluate args first" contract.
- [x] `$vau` builds operatives; `$lambda` is `wrap``$vau`.
- [x] `wrap` / `unwrap` round-trip cleanly.
- [x] Tests: define a custom operative, define a custom applicative on top of it.
### Phase 4 — Standard environment
- [ ] Standard env construction: bind `$if`, `$define!`, `$lambda`, `$vau`, `wrap`, `unwrap`, `eval`, `make-environment`, `get-current-environment`, plus arithmetic and list primitives.
@@ -100,6 +100,25 @@ The whole interesting thing: there are no special forms hardcoded in the evaluat
**May propose:** `lib/guest/reflective/` sub-layer — environment manipulation, evaluator-as-value, applicative/operative dispatch protocols.
**Proposed `lib/guest/reflective/combiner.sx` API** (from Phase 3 chiselling — pending second consumer):
- `(refl-make-primitive-operative IMPL)` — IMPL receives `(args dyn-env)`, args unevaluated.
- `(refl-make-user-operative PARAMS EPARAM BODY STATIC-ENV)` — for $vau-like constructors. The EPARAM sentinel for "ignore dyn-env" is a fixed keyword (`:refl-ignore` in the proposal).
- `(refl-wrap OP)` / `(refl-unwrap APP)` — round-trip pair.
- `(refl-operative? V)` / `(refl-applicative? V)` / `(refl-combiner? V)`.
- `(refl-call-combiner COMBINER ARGS DYN-ENV)` — the dispatch fork. Pairs with `refl-eval` from the evaluator kit.
- Representation: `{:refl-tag :operative :impl FN}` or `{:refl-tag :operative :params P :env-param EP :body B :static-env SE}`; applicatives are `{:refl-tag :applicative :underlying OP}`. The dispatch decision lives in one fork: presence of `:impl` is primitive, presence of `:body` is user-defined.
- Driving insight: every reflective Lisp must distinguish "eval my args first" from "hand me the syntax". The tag protocol is identical across Kernel, CL fexprs, vau-style Schemes, possibly Forth's IMMEDIATE words.
**Proposed `lib/guest/reflective/env.sx` API** (from Phase 2 chiselling — pending second consumer per the two-consumer rule):
- `(refl-make-env)` / `(refl-extend-env PARENT)` — fresh / chained envs, plain SX dicts so they're easy to introspect.
- `(refl-env? V)` — predicate.
- `(refl-env-bind! ENV NAME VAL)` — local bind; parent is untouched.
- `(refl-env-has? ENV NAME)` — recursive presence check.
- `(refl-env-lookup ENV NAME)` — recursive lookup, raises on miss.
- Representation: `{:refl-tag :env :bindings DICT :parent ENV-OR-NIL}`. Pure-SX dicts so any guest can serialize, diff, snapshot, or rewind environments without help from the host.
The motivation is that SX's host `make-env` family is registered only in HTTP/site-mode platform setup, so a guest that needs first-class envs in CLI / test contexts has to roll its own anyway. A shared kit means the next reflective consumer (CL macro evaluator? metacircular Scheme?) doesn't need to redo the work.
**What it teaches:** whether SX's recent env-as-value direction generalises to "evaluator-as-value." If Kernel implements cleanly in <2000 lines, env-as-value is real. If it requires substrate fixes at every turn, env-as-value was incomplete and the substrate is telling us what's missing.
## References
@@ -108,7 +127,10 @@ The whole interesting thing: there are no special forms hardcoded in the evaluat
- Klisp implementation (Andres Navarro) — pragmatic reference.
## Progress log
_(awaiting Phase 1 — depends on stable env-as-value substrate state)_
- 2026-05-11 — Phase 3 operatives landed. `lib/kernel/runtime.sx` adds `$vau` (primitive operative that returns a user operative), `$lambda` (sugar for `wrap ∘ $vau`), `wrap` and `unwrap` (Kernel-level applicatives), plus `operative?` and `applicative?` predicates. `kernel-base-env` wires them all into a fresh env. `kernel-eval.sx` now dispatches in `kernel-call-operative` between primitive ops (carry `:impl`) and user ops (carry `:params :env-param :body :static-env`). Parameter binding is a flat list — destructuring/`&rest` deferred. Env-param sentinel: spell `_` or `#ignore``:knl-ignore`, which skips the dyn-env bind. 34 tests in `tests/vau.sx`, including the headline custom-operative + custom-applicative composition. chisel: shapes-reflective. Two further reflective-API candidates surfaced: (a) the operative/applicative tag protocol — `make-primitive-operative`, `make-user-operative`, `wrap`, `unwrap` are general for any Lisp-of-fexprs; (b) the call-dispatch fork (primitive vs user) is a *single decision* that every reflective evaluator hits. Both shape go into the proposed `lib/guest/reflective/combiner.sx` candidate.
- 2026-05-10 — Phase 2 evaluator landed. `lib/kernel/eval.sx` is `lookup-and-combine`: zero hardcoded special forms. `kernel-eval EXPR ENV` dispatches on shape — literals self-evaluate, Kernel strings unwrap, symbols lookup, lists evaluate head and combine. `kernel-combine` distinguishes operatives (impl receives un-evaluated args + dynamic env) from applicatives (eval args, recurse into underlying op). `kernel-wrap`/`kernel-unwrap` round-trip cleanly. 36 tests verify literal evaluation, symbol lookup with parent-chain shadowing, tagged-value predicates, and the operative-vs-applicative contract (notably `$if` only evaluates the chosen branch, `$quote` returns its arg unevaluated). chisel: shapes-reflective. Substrate gap surfaced: SX's `make-env` / `env-bind!` family is only registered in HTTP/site mode (`http_setup_platform_constructors`), not in CLI epoch mode used for tests. So Kernel envs are modelled in pure SX as `{:knl-tag :env :bindings DICT :parent P}` — a binding-dict + parent-pointer + recursive lookup walk. This is exactly the `lib/guest/reflective/env.sx` candidate API: any reflective language needs first-class env values that can be extended, queried, and walked. Recording the shape (constructor, extend, bind!, has?, lookup) here for the eventual Phase 7 extraction.
- 2026-05-10 — Phase 1 parser landed. `lib/kernel/parser.sx` reads R-1RK lexical syntax: numbers (int/float/exp), strings (with escapes), symbols (permissive — anything non-delimiting), booleans `#t`/`#f`, the empty list `()`, nested lists, and `;` line comments. Reader macros (`'` `,` `,@`) deferred per plan. AST: numbers/booleans/lists pass through; strings are wrapped as `{:knl-string …}` to distinguish from symbols which are bare SX strings. 54 tests in `lib/kernel/tests/parse.sx` pass via `sx_server.exe` epoch protocol. chisel: consumes-lex (uses `lex-digit?` and `lex-whitespace?` from `lib/guest/lex.sx` — pratt deliberately not consumed because Kernel is plain s-expressions, no precedence climbing).
## Blockers
_(none yet — main risk is substrate gap discovery during Phase 2)_

View File

@@ -1,216 +0,0 @@
# miniKanren-on-SX: deferred work
The main plan (`plans/minikanren-on-sx.md`) carries Phases 17 through the
naive-tabling milestone. This file collects the four pieces left on the
shelf, with enough scope and design notes to drive a follow-up loop.
Branch convention: keep the same `loops/minikanren` worktree; commit and
push to `origin/loops/minikanren`. Squash-merge to `architecture` only
when each numbered piece is shipped + tests green.
Cumulative test count snapshot at squash-merge: **644** across
**71 test files**. Every change below should grow the number, not break
existing tests.
## The four pieces
### Piece A — Phase 7 SLG (cyclic patho, mutual recursion, fixed-point iteration)
**Problem.** Naive tabling drains the answer stream eagerly, then caches.
Recursive tabled calls with the SAME ground key see an empty cache (the
in-progress entry never exists), so they recurse and the host
overflows. Fibonacci works only because each recursive call has a
*different* key; cyclic `patho` and any genuinely self-recursive tabled
predicate diverge.
**Approach** — a small subset of SLG / OLDT resolution, enough to handle
the demos in the brief.
1. **In-progress sentinel.** When a tabled call `T(args)` starts, store
`(:in-progress nil)` under its key. Recursive calls into `T(args)`
from inside its own computation see the sentinel and return only
the answers accumulated so far (initially empty).
2. **Answer accumulator.** As each new answer is found, push it into
the cache entry: `(:in-progress accumulated-answers)`. After a
cycling caller returns, the outer continuation can re-consult the
updated cache.
3. **Fixed-point iteration.** The driver repeatedly re-runs the goal
until no new answers appear in a full pass, then transitions the
cache from `:in-progress` to `:done`.
4. **Subgoal table.** Track (subgoal, last-seen-cache-version) per
subscriber so each consumer only re-reads what it hasn't seen.
**Suggested artefacts.**
- `lib/minikanren/tabling-slg.sx` — new module with `table-slg-2`
(parallel to `table-2` from naive tabling). Keep `table-2` working
unchanged so Fibonacci/Ackermann don't regress.
- `lib/minikanren/tests/cyclic-graph-tabled.sx` — the canonical demo:
two-cycle `patho` from a→b→a→b plus a→b→c. With SLG, `(run* q
(tab-patho :a :c q))` returns the single shortest path, not divergence.
- `lib/minikanren/tests/mutual-recursion.sx` — even/odd via mutual
recursion (`even-o n``odd-o (n-1)`), tabled at both names.
**Reference reading.**
- TRS chapter on tabling.
- "Tabled Logic Programming" — Sagonas & Swift (the XSB / SLG paper).
- core.logic's `tabled` macro for an SX-dialect-friendly precedent.
**Risk.** This is the brief's "research-grade complexity, not a
one-iteration item". Plan for 46 commits: in-progress sentinel,
answer accumulator, fixed-point driver, then one demo per commit.
### Piece B — Phase 6 polish: bounds-consistency for `fd-plus` / `fd-times`
**Problem.** Current `fd-plus-prop` and `fd-times-prop` propagate only
when two of three operands walk to ground numbers. When all three are
domain-bounded vars, the propagator returns `s` unchanged — search has
to label down to ground before any narrowing happens.
**Approach** — narrow domains via interval reasoning even when no operand
is ground.
For `(fd-plus x y z)` with bounded x, y, z:
- `x ∈ [z.min y.max .. z.max y.min]`
- `y ∈ [z.min x.max .. z.max x.min]`
- `z ∈ [x.min + y.min .. x.max + y.max]`
For `(fd-times x y z)`: same shape, but with multiplication; need to
handle sign cases (negative domain ranges) and the divisor-when-not-zero
constraint already in place.
**Suggested artefacts.**
- Patch `fd-plus-prop` and `fd-times-prop` in `lib/minikanren/clpfd.sx`
with new `:else` branches that compute new domain bounds and call
`fd-set-domain` for each var.
- New tests in `lib/minikanren/tests/clpfd-plus.sx` /
`clpfd-times.sx` exercising the all-domain case: two domain-bounded
vars in the body of a goal, with no labelling, after which their
domains have narrowed.
- A demo: cryptarithmetic puzzle (see Piece D) using bounds
consistency to avoid labelling explosion.
**Risk.** Low. The math is well-known; just careful min/max arithmetic
and watch for edge cases (empty domain after narrowing).
### Piece C — `=/=` disequality with constraint store
**Problem.** `nafc` is sound only on ground args; `fd-neq` only on FD
domains. There is no general-purpose Prolog-style structural
disequality `=/=` that works on logic terms.
**Approach.** Generalise the FD constraint store to a uniform
"constraint store" that carries:
- domain map (existing)
- *pending disequalities* — a list of `(u v)` pairs that must remain
non-unifiable under any future extension.
After every `==` / `mk-unify`, re-check each pending disequality:
- If `(u v)` are now unifiable, fail.
- If they're now structurally distinct (no shared substitution can
unify), drop from the store (the constraint is satisfied).
- Otherwise leave in store.
**Where it bites.** The kernel currently uses `mk-unify` everywhere.
Either:
1. Replace `mk-unify` with a constraint-aware wrapper everywhere
(intrusive, but principled).
2. Keep `mk-unify` for goals that don't use `=/=`, and provide a
parallel `==-cs` / `=/=-cs` pair plus an alternative `run*-cs`
driver that fires the constraint check after each binding.
Option 2 mirrors the `fd-fire-store` pattern and stays out of the
common path.
**Suggested artefacts.**
- `lib/minikanren/diseq.sx` — disequality store on top of the
existing `_fd` reserved key (re-using the constraint list, just
with disequality-shaped closures instead of FD propagators).
- `=/=` goal that posts a disequality and immediately checks it.
- `=/=-test` integration: rewrite a few Phase 5 puzzles using `=/=`
instead of `nafc + ==`.
- Tests covering: ground-pair fail, partial-pair satisfied later by
binding, partial-pair *contradicted* later by binding.
**Risk.** Medium. The hard cases are *eventual* unifiability — a
disequality `(=/= (cons a 1) (cons 2 b))` should hold until both `a`
gets bound to `2` and `b` gets bound to `1`. Implementations like
core.logic's encode this as a list of "violating bindings" the
disequality remembers.
### Piece D — Bigger CLP(FD) demos: send-more-money + Sudoku 4×4
**Problem.** The current N-queens demo only verifies the constraint
chain end-to-end. The brief's full Phase 6 list includes
"send-more-money, N-queens with CLP(FD), map coloring,
cryptarithmetic" — most of which exercise *more* than just `fd-neq +
fd-distinct`.
**Approach.** Two concrete puzzles that both stress
bounds-consistency (Piece B) once it lands:
#### send-more-money
```
S E N D
+ M O R E
---------
M O N E Y
```
8 distinct digits ∈ {0..9}, S ≠ 0, M ≠ 0. Encoded as a sum-of-digits
equation using `fd-plus` + carry chains.
Without Piece B (bounds-consistency), the search labels every digit
combination upfront — slow but tractable on a fast machine. With
Piece B, the impossible high-digit cases prune early.
Test: a single solution `(9 5 6 7 1 0 8 2)`.
#### Sudoku 4×4
Easier than 9×9 but exercises the full pattern:
- 16 cells, each ∈ {1..4}
- 4 rows, 4 cols, 4 2×2 boxes — 12 `fd-distinct` constraints
- Some cells fixed as clues
A small solver should handle 4×4 in well under a second once
bounds-consistency narrows columns / boxes after each label step.
**Suggested artefacts.**
- `lib/minikanren/tests/send-more-money.sx` — single-solution test.
- `lib/minikanren/tests/sudoku-4x4.sx` — at least three cluesets:
unique solution, multiple solutions, no solution.
- Optional: `lib/minikanren/sudoku.sx` with a parameterised
`sudoku-n` for both 4×4 and a 9×9 stress test.
**Risk.** Lowmedium for 4×4 + send-more-money once Piece B lands.
9×9 Sudoku is a stretch; treat it as a stretch goal once the smaller
demos are green.
## Suggested ordering
1. **Piece B first** (bounds-consistency for `fd-plus` / `fd-times`).
Self-contained, low-risk, and unlocks Piece D's harder puzzles.
2. **Piece D** (the two demos). Validates Piece B with concrete
puzzles. Doubles as the brief's missing canary tests.
3. **Piece C** (`=/=`). Independent track; once shipped, refactor the
pet/diff puzzles in Phase 5 to use it instead of nafc.
4. **Piece A** (SLG tabling). Last because it's the highest-risk
piece; do it when the rest of the library is stable so regressions
are easy to spot.
## Operating ground rules (carry over from the original brief)
- **Scope:** `lib/minikanren/**` and the two plan files (this one and
the original).
- **Commit cadence:** one feature per commit. Short factual messages
(`mk: piece B — bounds-consistency for fd-plus`).
- **Plan updates:** tick boxes here as pieces land; mirror status in
`plans/minikanren-on-sx.md` Roadmap.
- **Test discipline:** every commit ends with the cumulative count
green. No-regression rule from the original brief still applies.
- **`sx-tree` MCP only** for `.sx` edits. `sx_validate` after every
structural edit.
- **Pushing:** `origin/loops/minikanren` only. Never `main`. Squash to
`architecture` only with explicit user permission, as we did for
the v1 merge.