coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Post-10d: JIT measurement infrastructure + compiler fixes

Browse Source 
Measurement:
- JIT hit/miss/skip counters in sx_runtime.ml (jit_try_call)
- VM instruction counter enabled in run loop
- jit-enable, vm-counters, vm-counters-reset epoch commands
- Test runner --jit flag for opt-in JIT measurement
- Results (132 tests): 5.8% VM hit, 56% evaluator self-calls, 38% anon

Fixes:
- Move compile-provide, compile-scope, compile-guard,
  compile-guard-clauses inside define-library begin block
  (were orphaned outside, causing "Undefined symbol" JIT failures)
- Add deref primitive (signal unwrap with tracking)
- Add deref compiler dispatch
- Fix compile-expr for scope forms to handle non-keyword args

CEK pruning assessment: evaluator self-calls (56%) can't be pruned —
the CEK must evaluate itself. Real pruning requires self-hosting
compiler (Phase 2+). The VM correctly handles user code that
JIT-compiles. 2776/2776 tests pass.

Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
This commit is contained in:
giles
2026-04-05 14:32:48 +00:00
parent a74c983615
commit fb30351be2
6 changed files with 266 additions and 129 deletions
Download Patch File Download Diff File Expand all files Collapse all files

53
hosts/ocaml/bin/run_tests.ml
View File

@@ -1455,17 +1455,68 @@ let run_spec_tests env test_files =
let () =
let args = Array.to_list Sys.argv |> List.tl in
let foundation_only = List.mem "--foundation" args in
let jit_enabled = List.mem "--jit" args in
let test_files = List.filter (fun a -> not (String.length a > 0 && a.[0] = '-')) args in
(* Always run foundation tests *)
run_foundation_tests ();
if not foundation_only then begin
Printf.printf "\n=== SX Spec Tests (CEK Evaluator) ===\n%!";
Printf.printf "\n=== SX Spec Tests (CEK Evaluator + JIT) ===\n%!";
let env = make_test_env () in
(* Load compiler and enable JIT (opt-in via --jit flag) *)
if jit_enabled then begin
let globals = Hashtbl.create 512 in
let rec env_to_globals e =
Hashtbl.iter (fun id v ->
let name = Sx_types.unintern id in
if not (Hashtbl.mem globals name) then
Hashtbl.replace globals name v) e.Sx_types.bindings;
match e.Sx_types.parent with Some p -> env_to_globals p | None -> ()
in
env_to_globals env;
(try
let compiler_path = if Sys.file_exists "lib/compiler.sx" then "lib/compiler.sx"
else "../../lib/compiler.sx" in
let ic = open_in compiler_path in
let src = really_input_string ic (in_channel_length ic) in
close_in ic; let _ = src in
let exprs = Sx_parser.parse_all src in
List.iter (fun e -> ignore (Sx_ref.eval_expr e (Env env))) exprs;
env_to_globals env;
Sx_runtime._jit_try_call_fn := Some (fun f args ->
match f with
| Lambda l ->
(match l.l_compiled with
| Some cl when not (Sx_vm.is_jit_failed cl) ->
(try Some (Sx_vm.call_closure cl args cl.vm_env_ref)
with _ -> None)
| Some _ -> None
| None ->
if l.l_name = None then None
else begin
l.l_compiled <- Some Sx_vm.jit_failed_sentinel;
match Sx_vm.jit_compile_lambda l globals with
| Some cl -> l.l_compiled <- Some cl;
(try Some (Sx_vm.call_closure cl args cl.vm_env_ref) with _ -> None)
| None -> None
end)
| _ -> None);
Printf.printf "[jit] Compiler loaded, JIT enabled\n%!"
with e ->
Printf.printf "[jit] Compiler not loaded: %s\n%!" (Printexc.to_string e));
end;
Sx_runtime.jit_reset_counters ();
run_spec_tests env test_files
end;
(* JIT statistics *)
let jh = !(Sx_runtime._jit_hit) and jm = !(Sx_runtime._jit_miss) and js = !(Sx_runtime._jit_skip) in
let total = jh + jm + js in
if total > 0 then
Printf.printf "\n[jit] calls=%d hit=%d (%.1f%%) miss=%d skip=%d\n"
total jh (100.0 *. float_of_int jh /. float_of_int (max 1 total)) jm js;
(* Summary *)
Printf.printf "\n%s\n" (String.make 60 '=');
Printf.printf "Results: %d passed, %d failed\n" !pass_count !fail_count;

21
hosts/ocaml/bin/sx_server.ml
View File

@@ -1399,6 +1399,27 @@ let rec dispatch env cmd =
(* ---- Debugging / introspection commands ---- *)
| List [Symbol "jit-enable"] ->
register_jit_hook env;
send_ok_value (String "jit enabled")
| List [Symbol "vm-counters"] ->
let d = Hashtbl.create 8 in
Hashtbl.replace d "vm_insns" (Number (float_of_int !(Sx_vm._vm_insn_count)));
Hashtbl.replace d "vm_calls" (Number (float_of_int !(Sx_vm._vm_call_count)));
Hashtbl.replace d "vm_cek_fallbacks" (Number (float_of_int !(Sx_vm._vm_cek_count)));
Hashtbl.replace d "comp_jit" (Number (float_of_int !(Sx_vm._vm_comp_jit_count)));
Hashtbl.replace d "comp_cek" (Number (float_of_int !(Sx_vm._vm_comp_cek_count)));
Hashtbl.replace d "jit_hit" (Number (float_of_int !(Sx_runtime._jit_hit)));
Hashtbl.replace d "jit_miss" (Number (float_of_int !(Sx_runtime._jit_miss)));
Hashtbl.replace d "jit_skip" (Number (float_of_int !(Sx_runtime._jit_skip)));
send_ok_value (Dict d)
| List [Symbol "vm-counters-reset"] ->
Sx_vm.vm_reset_counters ();
Sx_runtime.jit_reset_counters ();
send_ok_value (String "reset")
| List [Symbol "vm-trace"; String src] ->
(* Compile and trace-execute an SX expression, returning step-by-step
trace entries with opcode names, stack snapshots, and frame depth. *)

14
hosts/ocaml/lib/sx_primitives.ml
View File

@@ -1393,6 +1393,20 @@ let () =
end else Nil
| _ -> Nil);
(* deref — unwrap a signal value with reactive dependency tracking.
If value is a Signal, returns s_value and registers in tracking context.
Otherwise returns value as-is. *)
register "deref" (fun args ->
match args with
| [Signal sig'] ->
if !_tracking_active then begin
if not (List.memq (Signal sig') !_tracking_deps) then
_tracking_deps := Signal sig' :: !_tracking_deps
end;
sig'.s_value
| [v] -> v
| _ -> Nil);
(* bind — create a tracked computation. Takes a body-fn (lambda).
Starts tracking, evaluates body, collects deps, subscribes.
On dep change: unsubscribes, re-evaluates, re-subscribes.

10
hosts/ocaml/lib/sx_runtime.ml
View File

@@ -470,13 +470,17 @@ let mutable_list () = ListRef (ref [])
(* JIT try-call — ref set by sx_server.ml after compiler loads.
Returns Nil (no JIT) or the result value. Spec calls this. *)
let _jit_try_call_fn : (value -> value list -> value option) option ref = ref None
let _jit_hit = ref 0
let _jit_miss = ref 0
let _jit_skip = ref 0
let jit_reset_counters () = _jit_hit := 0; _jit_miss := 0; _jit_skip := 0
let jit_try_call f args =
match !_jit_try_call_fn with
| None -> Nil
| None -> incr _jit_skip; Nil
| Some hook ->
match f with
| Lambda l when l.l_name <> None ->
let arg_list = match args with List a | ListRef { contents = a } -> a | _ -> [] in
(match hook f arg_list with Some result -> result | None -> Nil)
| _ -> Nil
(match hook f arg_list with Some result -> incr _jit_hit; result | None -> incr _jit_miss; Nil)
| _ -> incr _jit_skip; Nil

2
hosts/ocaml/lib/sx_vm.ml
View File

@@ -204,6 +204,7 @@ let jit_compile_comp ~name ~params ~has_children ~body ~closure globals =
Returns the result value, or raises VmSuspended if CEK suspends.
Saves the suspended CEK state in vm.pending_cek for later resume. *)
let cek_call_or_suspend vm f args =
incr _vm_cek_count;
let a = match args with Nil -> [] | List l -> l | _ -> [args] in
let state = Sx_ref.continue_with_call f (List a) (Env (Sx_types.make_env ())) (List a) (List []) in
let final = Sx_ref.cek_step_loop state in
@@ -358,6 +359,7 @@ and run vm =
let saved_ip = frame.ip in
let op = bc.(frame.ip) in
frame.ip <- frame.ip + 1;
incr _vm_insn_count;
(try match op with
(* ---- Constants ---- *)
| 1 (* OP_CONST *) ->

295
lib/compiler.sx
View File

@@ -359,6 +359,12 @@
(emit-op em 52)
(emit-u16 em (pool-add (get em "pool") "scope-emitted"))
(emit-byte em 1))
(= name "deref")
(do
(compile-expr em (first args) scope false)
(emit-op em 52)
(emit-u16 em (pool-add (get em "pool") "deref"))
(emit-byte em 1))
(= name "perform")
(let
()
@@ -964,6 +970,170 @@
tail?
(do (emit-op em 49) (emit-byte em (len args)))
(do (emit-op em 48) (emit-byte em (len args)))))))))
(define
compile-provide
(fn
(em args scope tail?)
(let
((first-arg (first args))
(name
(cond
(= (type-of first-arg) "keyword")
(keyword-name first-arg)
(= (type-of first-arg) "string")
first-arg
:else (symbol-name first-arg)))
(val-expr (nth args 1))
(body (slice args 2))
(name-idx (pool-add (get em "pool") name)))
(emit-op em 1)
(emit-u16 em name-idx)
(compile-expr em val-expr scope false)
(emit-op em 52)
(emit-u16 em (pool-add (get em "pool") "scope-push!"))
(emit-byte em 2)
(emit-op em 5)
(if
(empty? body)
(emit-op em 2)
(compile-begin em body scope false))
(emit-op em 1)
(emit-u16 em name-idx)
(emit-op em 52)
(emit-u16 em (pool-add (get em "pool") "scope-pop!"))
(emit-byte em 1)
(emit-op em 5))))
(define
compile-scope
(fn
(em args scope tail?)
(let
((first-arg (first args))
(name
(if
(= (type-of first-arg) "keyword")
(keyword-name first-arg)
(symbol-name first-arg)))
(rest-args (rest args))
(name-idx (pool-add (get em "pool") name)))
(if
(and
(>= (len rest-args) 2)
(= (type-of (first rest-args)) "keyword")
(= (keyword-name (first rest-args)) "value"))
(let
((val-expr (nth rest-args 1)) (body (slice rest-args 2)))
(emit-op em 1)
(emit-u16 em name-idx)
(compile-expr em val-expr scope false)
(emit-op em 52)
(emit-u16 em (pool-add (get em "pool") "scope-push!"))
(emit-byte em 2)
(emit-op em 5)
(if
(empty? body)
(emit-op em 2)
(compile-begin em body scope false))
(emit-op em 1)
(emit-u16 em name-idx)
(emit-op em 52)
(emit-u16 em (pool-add (get em "pool") "scope-pop!"))
(emit-byte em 1)
(emit-op em 5))
(let
((body rest-args))
(emit-op em 1)
(emit-u16 em name-idx)
(emit-op em 2)
(emit-op em 52)
(emit-u16 em (pool-add (get em "pool") "scope-push!"))
(emit-byte em 2)
(emit-op em 5)
(if
(empty? body)
(emit-op em 2)
(compile-begin em body scope false))
(emit-op em 1)
(emit-u16 em name-idx)
(emit-op em 52)
(emit-u16 em (pool-add (get em "pool") "scope-pop!"))
(emit-byte em 1)
(emit-op em 5))))))
(define
compile-guard
(fn
(em args scope tail?)
(let
((guard-clause (first args))
(body (rest args))
(guard-scope (make-scope scope)))
(let
((var-name (symbol-name (first guard-clause)))
(clauses (rest guard-clause))
(var-slot (scope-define-local guard-scope var-name)))
(emit-op em 35)
(let
((handler-offset (current-offset em)))
(emit-i16 em 0)
(compile-begin em body guard-scope false)
(emit-op em 36)
(emit-op em 32)
(let
((done-jump (current-offset em)))
(emit-i16 em 0)
(patch-i16
em
handler-offset
(- (current-offset em) (+ handler-offset 2)))
(emit-op em 17)
(emit-byte em var-slot)
(emit-op em 5)
(compile-guard-clauses em clauses guard-scope var-slot tail?)
(patch-i16
em
done-jump
(- (current-offset em) (+ done-jump 2)))))))))
(define
compile-guard-clauses
(fn
(em clauses scope var-slot tail?)
(if
(empty? clauses)
(do (emit-op em 16) (emit-byte em var-slot) (emit-op em 37))
(let
((clause (first clauses))
(rest-clauses (rest clauses))
(test (first clause))
(body (rest clause)))
(if
(or
(and
(= (type-of test) "keyword")
(= (keyword-name test) "else"))
(= test true))
(compile-begin em body scope tail?)
(do
(compile-expr em test scope false)
(emit-op em 33)
(let
((skip (current-offset em)))
(emit-i16 em 0)
(compile-begin em body scope tail?)
(emit-op em 32)
(let
((end-jump (current-offset em)))
(emit-i16 em 0)
(patch-i16 em skip (- (current-offset em) (+ skip 2)))
(compile-guard-clauses
em
rest-clauses
scope
var-slot
tail?)
(patch-i16
em
end-jump
(- (current-offset em) (+ end-jump 2)))))))))))
(define
compile
(fn
@@ -989,129 +1159,4 @@
{:constants (get (get em "pool") "entries") :bytecode (get em "bytecode")}))))) ;; end define-library
;; Re-export to global namespace for backward compatibility
(define
compile-provide
(fn
(em args scope tail?)
(let
((first-arg (first args))
(name
(cond
(= (type-of first-arg) "keyword")
(keyword-name first-arg)
(= (type-of first-arg) "string")
first-arg
:else (symbol-name first-arg)))
(val-expr (nth args 1))
(body (slice args 2))
(name-idx (pool-add (get em "pool") name)))
(emit-op em 1)
(emit-u16 em name-idx)
(compile-expr em val-expr scope false)
(emit-op em 52)
(emit-u16 em (pool-add (get em "pool") "scope-push!"))
(emit-byte em 2)
(emit-op em 5)
(if (empty? body) (emit-op em 2) (compile-begin em body scope false))
(emit-op em 1)
(emit-u16 em name-idx)
(emit-op em 52)
(emit-u16 em (pool-add (get em "pool") "scope-pop!"))
(emit-byte em 1)
(emit-op em 5))))
(define
compile-scope
(fn
(em args scope tail?)
(let
((first-arg (first args))
(name
(if
(= (type-of first-arg) "keyword")
(keyword-name first-arg)
(symbol-name first-arg)))
(rest-args (rest args))
(name-idx (pool-add (get em "pool") name)))
(if
(and
(>= (len rest-args) 2)
(= (type-of (first rest-args)) "keyword")
(= (keyword-name (first rest-args)) "value"))
(let
((val-expr (nth rest-args 1)) (body (slice rest-args 2)))
(emit-op em 1)
(emit-u16 em name-idx)
(compile-expr em val-expr scope false)
(emit-op em 52)
(emit-u16 em (pool-add (get em "pool") "scope-push!"))
(emit-byte em 2)
(emit-op em 5)
(if
(empty? body)
(emit-op em 2)
(compile-begin em body scope false))
(emit-op em 1)
(emit-u16 em name-idx)
(emit-op em 52)
(emit-u16 em (pool-add (get em "pool") "scope-pop!"))
(emit-byte em 1)
(emit-op em 5))
(let
((body rest-args))
(emit-op em 1)
(emit-u16 em name-idx)
(emit-op em 2)
(emit-op em 52)
(emit-u16 em (pool-add (get em "pool") "scope-push!"))
(emit-byte em 2)
(emit-op em 5)
(if
(empty? body)
(emit-op em 2)
(compile-begin em body scope false))
(emit-op em 1)
(emit-u16 em name-idx)
(emit-op em 52)
(emit-u16 em (pool-add (get em "pool") "scope-pop!"))
(emit-byte em 1)
(emit-op em 5))))))
(define
compile-guard-clauses
(fn
(em clauses scope var-slot tail?)
(if
(empty? clauses)
(do (emit-op em 16) (emit-byte em var-slot) (emit-op em 37))
(let
((clause (first clauses))
(rest-clauses (rest clauses))
(test (first clause))
(body (rest clause)))
(if
(or
(and
(= (type-of test) "keyword")
(= (keyword-name test) "else"))
(= test true))
(compile-begin em body scope tail?)
(do
(compile-expr em test scope false)
(emit-op em 33)
(let
((skip (current-offset em)))
(emit-i16 em 0)
(compile-begin em body scope tail?)
(emit-op em 32)
(let
((end-jump (current-offset em)))
(emit-i16 em 0)
(patch-i16 em skip (- (current-offset em) (+ skip 2)))
(compile-guard-clauses em rest-clauses scope var-slot tail?)
(patch-i16
em
end-jump
(- (current-offset em) (+ end-jump 2)))))))))))
(import (sx compiler))