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

Merge branch 'loops/sx-vm-extensions' into scratch/host-jit

Browse Source 
# Conflicts:
#	hosts/ocaml/bin/sx_server.ml
#	lib/erlang/runtime.sx
This commit is contained in:
giles
2026-06-28 18:57:17 +00:00
parent e6a1180d50 fed58b2814
commit 17c7b90834
18 changed files with 564 additions and 461 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@@ -4168,6 +4168,38 @@ let () =
) Sx_types.jit_cache_queue;
Queue.clear Sx_types.jit_cache_queue;
Nil);
register "jit-exclude!" (fun args ->
(* Mark function names as interpret-only (never JIT-compiled). A guest
interpreter calls this for its continuation-using dispatch core.
Accepts string/symbol names; a trailing "*" makes it a namespace prefix
(e.g. "er-*" excludes every function whose name starts with "er-") —
the robust way to declare a whole guest interpreter core. *)
List.iter (fun a ->
match a with
| String n | Symbol n ->
let len = String.length n in
if len > 0 && n.[len - 1] = '*' then begin
let prefix = String.sub n 0 (len - 1) in
if not (List.mem prefix !Sx_types.jit_excluded_prefixes) then
Sx_types.jit_excluded_prefixes := prefix :: !Sx_types.jit_excluded_prefixes
end else
Hashtbl.replace Sx_types.jit_excluded n ()
| _ -> ()) args;
Nil);
register "jit-excluded?" (fun args ->
match args with
| [String n] | [Symbol n] -> Bool (Sx_types.jit_name_excluded n)
| _ -> Bool false);
register "jit-exclude-callers-of!" (fun args ->
(* Register call/cc-establishing forms (e.g. cl-restart-case). Any function
whose bytecode references one of these is itself interpret-only — JIT
would force the form into a nested cek-run where its continuation can't
escape. A guest declares its condition-system / escaping forms here. *)
List.iter (fun a ->
match a with
| String n | Symbol n -> Hashtbl.replace Sx_types.jit_excluded_caller_names n ()
| _ -> ()) args;
Nil);
register "jit-reset-counters!" (fun _args ->
Sx_types.jit_compiled_count := 0;
Sx_types.jit_skipped_count := 0;

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

@@ -17,11 +17,19 @@ let rec _fast_eq a b =
| Number x, Number y -> x = y
| Integer x, Number y -> float_of_int x = y
| Number x, Integer y -> x = float_of_int y
(* Exact rationals — must match the "=" primitive (safe_eq). Cross-multiply
for rational/rational; coerce for rational/int and rational/float. *)
| Rational (an, ad), Rational (bn, bd) -> an * bd = bn * ad
| Rational (n, d), Integer y -> n = y * d
| Integer x, Rational (n, d) -> x * d = n
| Rational (n, d), Number y -> float_of_int n /. float_of_int d = y
| Number x, Rational (n, d) -> x = float_of_int n /. float_of_int d
| Bool x, Bool y -> x = y
| Nil, Nil -> true
| Symbol x, Symbol y -> x = y
| Keyword x, Keyword y -> x = y
| List la, List lb ->
| (List la | ListRef { contents = la }),
(List lb | ListRef { contents = lb }) ->
(try List.for_all2 _fast_eq la lb with Invalid_argument _ -> false)
| _ -> false

46
hosts/ocaml/lib/sx_types.ml
View File

@@ -470,6 +470,52 @@ let jit_compiled_count = ref 0
let jit_skipped_count = ref 0
let jit_threshold_skipped_count = ref 0
(** Runtime, data-driven JIT exclusion set. Names added here are never
JIT-compiled — they run on the CEK interpreter instead.
This is how a guest interpreter declares its *interpret-only* functions:
those that capture or invoke first-class continuations (e.g. Smalltalk's
[call/cc]-based non-local return [^expr], or block escape). The stack VM
cannot transfer control through a CEK continuation, so a JIT-compiled
frame on the OCaml/VM stack between a [call/cc] and its [(k v)] invocation
would either fail at runtime or (worse) re-run with duplicated side
effects. Marking the dispatch core interpret-only keeps those functions on
the CEK while pure helpers still JIT.
Populated from SX via the [jit-exclude!] primitive (see sx_primitives).
Consulted in [Sx_vm.jit_compile_lambda], so it covers BOTH JIT entry
points: the CEK call hook and the in-VM tiered-compilation path. *)
let jit_excluded : (string, unit) Hashtbl.t = Hashtbl.create 64
(** Namespace-prefix exclusions. A guest interpreter declares its whole
function namespace interpret-only with one entry (e.g. ["er-"], ["scm-"]),
which is far more robust than enumerating every function — a name-list
misses functions in extra files (the erlang VM dispatcher, etc.) and
silently regresses. Set via [jit-exclude!] with a trailing ["*"]
(e.g. [(jit-exclude! "er-*")]). Checked via [jit_name_excluded]. *)
let jit_excluded_prefixes : string list ref = ref []
(** True if [name] is excluded from JIT — by exact name or by namespace prefix. *)
let jit_name_excluded name =
Hashtbl.mem jit_excluded name
|| List.exists (fun p ->
String.length name >= String.length p
&& String.sub name 0 (String.length p) = p) !jit_excluded_prefixes
(** Names of functions that ESTABLISH an escaping continuation via call/cc
(e.g. Common-Lisp's [cl-restart-case] / [cl-handler-case] — the condition
system). Any SX function that *calls* one of these is itself unsafe to JIT:
JIT-compiling the caller forces the call/cc-wrapping form to run in a nested
cek-run, where invoking the captured continuation runs-to-completion-and-
returns instead of escaping — so a restart/non-local exit silently fails
and the body falls through (observed as result accumulation / no-abort).
These callers are NOT a fixed namespace (they are arbitrary user/test code),
so they cannot be prefix-excluded. Instead a guest declares its escaping
forms here (via [jit-exclude-callers-of!]) and [jit_compile_lambda] skips
any function whose constant pool references one of them. *)
let jit_excluded_caller_names : (string, unit) Hashtbl.t = Hashtbl.create 16
(** {2 JIT cache LRU eviction — Phase 2}
Once a lambda crosses the threshold, its [l_compiled] slot is filled.

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

@@ -808,14 +808,31 @@ and run vm =
let b = pop vm and a = pop vm in
push vm (match a, b with
| Integer x, Integer y when y <> 0 && x mod y = 0 -> Integer (x / y)
| Integer x, Integer y -> Number (float_of_int x /. float_of_int y)
(* Non-divisible Integer/Integer must delegate to the "/" primitive:
it returns an exact Rational (e.g. 1/2), matching CEK semantics.
Inlining float division here (0.5) diverges from the interpreter
and breaks numeric equality against rational results. *)
| Number x, Number y -> Number (x /. y)
| Integer x, Number y -> Number (float_of_int x /. y)
| Number x, Integer y -> Number (x /. float_of_int y)
| _ -> (Hashtbl.find Sx_primitives.primitives "/") [a; b])
| 164 (* OP_EQ *) ->
let b = pop vm and a = pop vm in
push vm (Bool (Sx_runtime._fast_eq a b))
(* Trivial scalar cases inline; everything else (Rational, Dict,
Record, Vector, ListRef, nested lists) delegates to the "="
primitive so VM equality matches CEK exactly. _fast_eq is a
stripped-down subset and must not be the source of truth here. *)
push vm (match a, b with
| Integer x, Integer y -> Bool (x = y)
| Number x, Number y -> Bool (x = y)
| Integer x, Number y -> Bool (float_of_int x = y)
| Number x, Integer y -> Bool (x = float_of_int y)
| String x, String y -> Bool (x = y)
| Bool x, Bool y -> Bool (x = y)
| Symbol x, Symbol y -> Bool (x = y)
| Keyword x, Keyword y -> Bool (x = y)
| Nil, Nil -> Bool true
| _ -> (Hashtbl.find Sx_primitives.primitives "=") [a; b])
| 165 (* OP_LT *) ->
let b = pop vm and a = pop vm in
push vm (match a, b with
@@ -1072,7 +1089,7 @@ let _jit_is_broken_name n =
Operand-size logic mirrors [opcode_operand_size] (which is defined
later, in the disassembly section); inlined here so this helper can
sit before [jit_compile_lambda] in the file. *)
let bytecode_uses_extension_opcodes (bc : int array) (consts : value array) =
let bytecode_find_opcode (pred : int -> bool) (bc : int array) (consts : value array) =
let core_operand_size = function
| 1 | 20 | 21 | 64 | 65 | 128 -> 2 (* u16 *)
| 16 | 17 | 18 | 19 | 48 | 49 | 144 -> 1 (* u8 *)
@@ -1085,7 +1102,7 @@ let bytecode_uses_extension_opcodes (bc : int array) (consts : value array) =
let found = ref false in
while not !found && !ip < len do
let op = bc.(!ip) in
if op >= 200 then found := true
if pred op then found := true
else begin
ip := !ip + 1;
let extra = match op with
@@ -1112,6 +1129,49 @@ let bytecode_uses_extension_opcodes (bc : int array) (consts : value array) =
done;
!found
let bytecode_uses_extension_opcodes bc consts =
bytecode_find_opcode (fun op -> op >= 200) bc consts
(** True if [code] — or any closure nested in its constant pool — installs an
exception handler (OP_PUSH_HANDLER = 35), i.e. contains a `guard` /
`handler-bind` / dream-catch form. The VM's PUSH_HANDLER only intercepts a
VM-level RAISE (opcode 37); it does NOT catch the OCaml [Eval_error] that
the `error` primitive throws from inside a CALL/CALL_PRIM in a callee
frame. So a JIT-compiled guard silently fails to catch thrown errors (they
escape across the JIT frame).
The scan is RECURSIVE: a curried higher-order function (e.g. Dream's
`dream-catch-with = (fn (on-error) (fn (next) (fn (req) (guard ...))))`)
has no PUSH_HANDLER in its own body — the guard lives in a nested
`OP_CLOSURE` whose code sits in the constant pool. JIT-compiling the outer
function would mint that inner guard as a VmClosure with the broken VM
handler. Descending into nested closure codes catches this, so the whole
closure family runs on the CEK (whose guard catches correctly). Covers
dream-catch-with, host wrap-errors, and every guard user centrally. *)
let rec code_uses_handler code =
bytecode_find_opcode (fun op -> op = 35) code.vc_bytecode code.vc_constants
|| Array.exists (fun c ->
match c with
| Dict d when Hashtbl.mem d "bytecode" || Hashtbl.mem d "vc-bytecode" ->
(try code_uses_handler (code_from_value c) with _ -> false)
| _ -> false) code.vc_constants
(** True if [code] — or any nested closure code — references (in its constant
pool, as a GLOBAL_GET/CALL name) a function registered in
[Sx_types.jit_excluded_caller_names] (a call/cc-establishing form like
Common-Lisp's cl-restart-case/cl-handler-case). Such a caller must run on
the CEK so the continuation captured inside the called form can escape.
The constant-pool string IS the referenced symbol name, so membership is a
direct lookup; recurse into nested closure codes. Skipped entirely (no
Hashtbl walk) when no escaping forms are registered. *)
let rec code_refs_escaping_caller code =
Array.exists (fun c ->
match c with
| String s -> Hashtbl.mem Sx_types.jit_excluded_caller_names s
| Dict d when Hashtbl.mem d "bytecode" || Hashtbl.mem d "vc-bytecode" ->
(try code_refs_escaping_caller (code_from_value c) with _ -> false)
| _ -> false) code.vc_constants
let jit_compile_lambda (l : lambda) globals =
let fn_name = match l.l_name with Some n -> n | None -> "<anon>" in
if !_jit_compiling then (
@@ -1127,6 +1187,13 @@ let jit_compile_lambda (l : lambda) globals =
None
) else if _jit_is_broken_name fn_name then (
None
) else if Sx_types.jit_name_excluded fn_name then (
(* Guest-declared interpret-only function (continuation-using dispatch
core, or a whole namespace via prefix). Run on the CEK; the stack VM
can't escape through a CEK continuation and may miscompile deep AST
recursion into a non-terminating loop. See Sx_types.jit_excluded /
jit_excluded_prefixes. *)
None
) else
try
_jit_compiling := true;
@@ -1183,6 +1250,20 @@ let jit_compile_lambda (l : lambda) globals =
Printf.eprintf "[jit] SKIP %s: bytecode uses extension opcodes (interpret-only in v1)\n%!"
fn_name;
None
end else if code_uses_handler code then begin
(* guard / handler-bind (possibly in a nested closure): VM
PUSH_HANDLER doesn't catch the `error` primitive's OCaml
exception across frames — run on the CEK. *)
Printf.eprintf "[jit] SKIP %s: installs an exception handler (guard) — interpret-only\n%!"
fn_name;
None
end else if Hashtbl.length Sx_types.jit_excluded_caller_names > 0
&& code_refs_escaping_caller code then begin
(* Calls a call/cc-establishing form (e.g. cl-restart-case): must
run on the CEK so the captured continuation can escape. *)
Printf.eprintf "[jit] SKIP %s: calls a call/cc-establishing form — interpret-only\n%!"
fn_name;
None
end else
Some { vm_code = code; vm_upvalues = [||];
vm_name = l.l_name; vm_env_ref = effective_globals; vm_closure_env = Some l.l_closure }