Merge branch 'loops/sx-vm-extensions' into scratch/host-jit
# Conflicts: # hosts/ocaml/bin/sx_server.ml # lib/erlang/runtime.sx
This commit is contained in:
@@ -263,7 +263,7 @@ let make_integration_env () =
|
|||||||
|
|
||||||
(* Type predicates — needed by adapter-sx.sx *)
|
(* Type predicates — needed by adapter-sx.sx *)
|
||||||
bind "callable?" (fun args ->
|
bind "callable?" (fun args ->
|
||||||
match args with [NativeFn _] | [Lambda _] | [Component _] | [Island _] -> Bool true | _ -> Bool false);
|
match args with [NativeFn _] | [Lambda _] | [Component _] | [Island _] | [VmClosure _] -> Bool true | _ -> Bool false);
|
||||||
bind "lambda?" (fun args -> match args with [Lambda _] -> Bool true | _ -> Bool false);
|
bind "lambda?" (fun args -> match args with [Lambda _] -> Bool true | _ -> Bool false);
|
||||||
bind "macro?" (fun args -> match args with [Macro _] -> Bool true | _ -> Bool false);
|
bind "macro?" (fun args -> match args with [Macro _] -> Bool true | _ -> Bool false);
|
||||||
bind "island?" (fun args -> match args with [Island _] -> Bool true | _ -> Bool false);
|
bind "island?" (fun args -> match args with [Island _] -> Bool true | _ -> Bool false);
|
||||||
|
|||||||
@@ -477,7 +477,7 @@ let setup_env () =
|
|||||||
bind "number?" (fun args -> match args with
|
bind "number?" (fun args -> match args with
|
||||||
| [Number _] -> Bool true | _ -> Bool false);
|
| [Number _] -> Bool true | _ -> Bool false);
|
||||||
bind "callable?" (fun args -> match args with
|
bind "callable?" (fun args -> match args with
|
||||||
| [NativeFn _ | Lambda _ | Component _ | Island _] -> Bool true | _ -> Bool false);
|
| [NativeFn _ | Lambda _ | Component _ | Island _ | VmClosure _] -> Bool true | _ -> Bool false);
|
||||||
bind "empty?" (fun args -> match args with
|
bind "empty?" (fun args -> match args with
|
||||||
| [List []] | [ListRef { contents = [] }] -> Bool true
|
| [List []] | [ListRef { contents = [] }] -> Bool true
|
||||||
| [Nil] -> Bool true | _ -> Bool false);
|
| [Nil] -> Bool true | _ -> Bool false);
|
||||||
|
|||||||
@@ -595,7 +595,7 @@ let make_test_env () =
|
|||||||
(* regex-find-all now provided by sx_primitives.ml *)
|
(* regex-find-all now provided by sx_primitives.ml *)
|
||||||
bind "callable?" (fun args ->
|
bind "callable?" (fun args ->
|
||||||
match args with
|
match args with
|
||||||
| [NativeFn _] | [Lambda _] | [Component _] | [Island _] -> Bool true
|
| [NativeFn _] | [Lambda _] | [Component _] | [Island _] | [VmClosure _] -> Bool true
|
||||||
| _ -> Bool false);
|
| _ -> Bool false);
|
||||||
bind "make-sx-expr" (fun args -> match args with [String s] -> SxExpr s | _ -> raise (Eval_error "make-sx-expr: expected string"));
|
bind "make-sx-expr" (fun args -> match args with [String s] -> SxExpr s | _ -> raise (Eval_error "make-sx-expr: expected string"));
|
||||||
bind "sx-expr-source" (fun args -> match args with [SxExpr s] -> String s | [String s] -> String s | _ -> raise (Eval_error "sx-expr-source: expected sx-expr or string"));
|
bind "sx-expr-source" (fun args -> match args with [SxExpr s] -> String s | [String s] -> String s | _ -> raise (Eval_error "sx-expr-source: expected sx-expr or string"));
|
||||||
|
|||||||
@@ -1138,7 +1138,11 @@ let setup_introspection env =
|
|||||||
bind "component?" (fun args ->
|
bind "component?" (fun args ->
|
||||||
match args with [Component _] | [Island _] -> Bool true | _ -> Bool false);
|
match args with [Component _] | [Island _] -> Bool true | _ -> Bool false);
|
||||||
bind "callable?" (fun args ->
|
bind "callable?" (fun args ->
|
||||||
match args with [NativeFn _] | [Lambda _] | [Component _] | [Island _] -> Bool true | _ -> Bool false);
|
(* VmClosure must count as callable: a JIT-compiled higher-order function
|
||||||
|
returns its inner closure as a VmClosure, and downstream code (e.g.
|
||||||
|
scheme-apply's `(callable? proc)` guard) must recognize it — it is
|
||||||
|
invocable via the normal call path. *)
|
||||||
|
match args with [NativeFn _] | [Lambda _] | [Component _] | [Island _] | [VmClosure _] -> Bool true | _ -> Bool false);
|
||||||
bind "spread?" (fun args -> match args with [Spread _] -> Bool true | _ -> Bool false);
|
bind "spread?" (fun args -> match args with [Spread _] -> Bool true | _ -> Bool false);
|
||||||
bind "continuation?" (fun args ->
|
bind "continuation?" (fun args ->
|
||||||
match args with [Continuation _] -> Bool true | [_] -> Bool false | _ -> Bool false);
|
match args with [Continuation _] -> Bool true | [_] -> Bool false | _ -> Bool false);
|
||||||
@@ -1523,6 +1527,22 @@ let sx_render_to_html expr env =
|
|||||||
|
|
||||||
let _jit_warned : (string, bool) Hashtbl.t = Hashtbl.create 16
|
let _jit_warned : (string, bool) Hashtbl.t = Hashtbl.create 16
|
||||||
|
|
||||||
|
(* Bisection aid: env-var-driven JIT filter. Lets us narrow which named
|
||||||
|
lambda the VM miscompiles without rebuilding.
|
||||||
|
SX_JIT_DENY=name1,name2 — never JIT these (substring match on exact name).
|
||||||
|
SX_JIT_ONLY=name1,name2 — JIT ONLY these (exact name); skip all others. *)
|
||||||
|
let _jit_deny_set =
|
||||||
|
match Sys.getenv_opt "SX_JIT_DENY" with
|
||||||
|
| None | Some "" -> []
|
||||||
|
| Some s -> String.split_on_char ',' s |> List.map String.trim
|
||||||
|
let _jit_only_set =
|
||||||
|
match Sys.getenv_opt "SX_JIT_ONLY" with
|
||||||
|
| None | Some "" -> []
|
||||||
|
| Some s -> String.split_on_char ',' s |> List.map String.trim
|
||||||
|
let _jit_name_allowed name =
|
||||||
|
(not (List.mem name _jit_deny_set))
|
||||||
|
&& (match _jit_only_set with [] -> true | only -> List.mem name only)
|
||||||
|
|
||||||
let rec make_vm_suspend_marker request saved_vm =
|
let rec make_vm_suspend_marker request saved_vm =
|
||||||
let d = Hashtbl.create 3 in
|
let d = Hashtbl.create 3 in
|
||||||
Hashtbl.replace d "__vm_suspended" (Bool true);
|
Hashtbl.replace d "__vm_suspended" (Bool true);
|
||||||
@@ -1541,6 +1561,8 @@ let rec make_vm_suspend_marker request saved_vm =
|
|||||||
let register_jit_hook env =
|
let register_jit_hook env =
|
||||||
Sx_runtime._jit_try_call_fn := Some (fun f args ->
|
Sx_runtime._jit_try_call_fn := Some (fun f args ->
|
||||||
match f with
|
match f with
|
||||||
|
| Lambda l when (match l.l_name with Some n -> not (_jit_name_allowed n) | None -> false) ->
|
||||||
|
None (* bisection filter excluded this name *)
|
||||||
| Lambda l ->
|
| Lambda l ->
|
||||||
(match l.l_compiled with
|
(match l.l_compiled with
|
||||||
| Some cl when not (Sx_vm.is_jit_failed cl) ->
|
| Some cl when not (Sx_vm.is_jit_failed cl) ->
|
||||||
@@ -4917,6 +4939,38 @@ let () =
|
|||||||
match args with
|
match args with
|
||||||
| expr :: _ -> String (sx_render_to_html expr env)
|
| expr :: _ -> String (sx_render_to_html expr env)
|
||||||
| _ -> raise (Eval_error "render-page: (expr)"))));
|
| _ -> raise (Eval_error "render-page: (expr)"))));
|
||||||
|
(* JIT in the epoch serving mode is OPT-IN via SX_SERVING_JIT=1.
|
||||||
|
Default OFF: this mode is the shared command channel used by every
|
||||||
|
loop's conformance runner, and enabling JIT globally regresses
|
||||||
|
continuation-based guest interpreters (Scheme/Erlang/Prolog/CL: their
|
||||||
|
eval/dispatch cores capture call/cc continuations the stack VM can't
|
||||||
|
escape, and deep AST recursion can miscompile into a non-terminating
|
||||||
|
loop). Guests that are safe declare their interpret-only namespace with
|
||||||
|
`(jit-exclude! "<ns>-*")`; until every guest is validated, the safe
|
||||||
|
default is no JIT here. Opt in (SX_SERVING_JIT=1) for validated
|
||||||
|
workloads — e.g. the content/Smalltalk page server. *)
|
||||||
|
(match Sys.getenv_opt "SX_SERVING_JIT" with
|
||||||
|
| Some ("1" | "true" | "yes" | "on") ->
|
||||||
|
(* Load the SX bytecode compiler (lib/compiler.sx) as `compile` — the
|
||||||
|
native Sx_compiler.compile is an incomplete stub (arity-0 bytecode,
|
||||||
|
params as GLOBAL_GET). http/cli/site modes already load it. *)
|
||||||
|
(_import_env := Some env;
|
||||||
|
let project_dir = try Sys.getenv "SX_PROJECT_DIR" with Not_found ->
|
||||||
|
try Sys.getenv "SX_ROOT" with Not_found ->
|
||||||
|
if Sys.file_exists "/app/spec" then "/app" else Sys.getcwd () in
|
||||||
|
let lib_base = try Sys.getenv "SX_LIB_DIR" with Not_found ->
|
||||||
|
project_dir ^ "/lib" in
|
||||||
|
let compiler_path = lib_base ^ "/compiler.sx" in
|
||||||
|
let compiler_path =
|
||||||
|
if Sys.file_exists compiler_path then compiler_path
|
||||||
|
else if Sys.file_exists "lib/compiler.sx" then "lib/compiler.sx"
|
||||||
|
else compiler_path in
|
||||||
|
try load_library_file compiler_path; rebind_host_extensions env
|
||||||
|
with exn ->
|
||||||
|
Printf.eprintf "[sx-server] WARNING: failed to load compiler.sx for JIT (%s) — JIT disabled\n%!"
|
||||||
|
(Printexc.to_string exn));
|
||||||
|
register_jit_hook env
|
||||||
|
| _ -> ());
|
||||||
send "(ready)";
|
send "(ready)";
|
||||||
(* Main command loop *)
|
(* Main command loop *)
|
||||||
try
|
try
|
||||||
|
|||||||
@@ -4168,6 +4168,38 @@ let () =
|
|||||||
) Sx_types.jit_cache_queue;
|
) Sx_types.jit_cache_queue;
|
||||||
Queue.clear Sx_types.jit_cache_queue;
|
Queue.clear Sx_types.jit_cache_queue;
|
||||||
Nil);
|
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 ->
|
register "jit-reset-counters!" (fun _args ->
|
||||||
Sx_types.jit_compiled_count := 0;
|
Sx_types.jit_compiled_count := 0;
|
||||||
Sx_types.jit_skipped_count := 0;
|
Sx_types.jit_skipped_count := 0;
|
||||||
|
|||||||
@@ -17,11 +17,19 @@ let rec _fast_eq a b =
|
|||||||
| Number x, Number y -> x = y
|
| Number x, Number y -> x = y
|
||||||
| Integer x, Number y -> float_of_int x = y
|
| Integer x, Number y -> float_of_int x = y
|
||||||
| Number x, Integer y -> x = float_of_int 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
|
| Bool x, Bool y -> x = y
|
||||||
| Nil, Nil -> true
|
| Nil, Nil -> true
|
||||||
| Symbol x, Symbol y -> x = y
|
| Symbol x, Symbol y -> x = y
|
||||||
| Keyword x, Keyword 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)
|
(try List.for_all2 _fast_eq la lb with Invalid_argument _ -> false)
|
||||||
| _ -> false
|
| _ -> false
|
||||||
|
|
||||||
|
|||||||
@@ -470,6 +470,52 @@ let jit_compiled_count = ref 0
|
|||||||
let jit_skipped_count = ref 0
|
let jit_skipped_count = ref 0
|
||||||
let jit_threshold_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}
|
(** {2 JIT cache LRU eviction — Phase 2}
|
||||||
|
|
||||||
Once a lambda crosses the threshold, its [l_compiled] slot is filled.
|
Once a lambda crosses the threshold, its [l_compiled] slot is filled.
|
||||||
|
|||||||
@@ -808,14 +808,31 @@ and run vm =
|
|||||||
let b = pop vm and a = pop vm in
|
let b = pop vm and a = pop vm in
|
||||||
push vm (match a, b with
|
push vm (match a, b with
|
||||||
| Integer x, Integer y when y <> 0 && x mod y = 0 -> Integer (x / y)
|
| 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)
|
| Number x, Number y -> Number (x /. y)
|
||||||
| Integer x, Number y -> Number (float_of_int x /. y)
|
| Integer x, Number y -> Number (float_of_int x /. y)
|
||||||
| Number x, Integer y -> Number (x /. float_of_int y)
|
| Number x, Integer y -> Number (x /. float_of_int y)
|
||||||
| _ -> (Hashtbl.find Sx_primitives.primitives "/") [a; b])
|
| _ -> (Hashtbl.find Sx_primitives.primitives "/") [a; b])
|
||||||
| 164 (* OP_EQ *) ->
|
| 164 (* OP_EQ *) ->
|
||||||
let b = pop vm and a = pop vm in
|
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 *) ->
|
| 165 (* OP_LT *) ->
|
||||||
let b = pop vm and a = pop vm in
|
let b = pop vm and a = pop vm in
|
||||||
push vm (match a, b with
|
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
|
Operand-size logic mirrors [opcode_operand_size] (which is defined
|
||||||
later, in the disassembly section); inlined here so this helper can
|
later, in the disassembly section); inlined here so this helper can
|
||||||
sit before [jit_compile_lambda] in the file. *)
|
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
|
let core_operand_size = function
|
||||||
| 1 | 20 | 21 | 64 | 65 | 128 -> 2 (* u16 *)
|
| 1 | 20 | 21 | 64 | 65 | 128 -> 2 (* u16 *)
|
||||||
| 16 | 17 | 18 | 19 | 48 | 49 | 144 -> 1 (* u8 *)
|
| 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
|
let found = ref false in
|
||||||
while not !found && !ip < len do
|
while not !found && !ip < len do
|
||||||
let op = bc.(!ip) in
|
let op = bc.(!ip) in
|
||||||
if op >= 200 then found := true
|
if pred op then found := true
|
||||||
else begin
|
else begin
|
||||||
ip := !ip + 1;
|
ip := !ip + 1;
|
||||||
let extra = match op with
|
let extra = match op with
|
||||||
@@ -1112,6 +1129,49 @@ let bytecode_uses_extension_opcodes (bc : int array) (consts : value array) =
|
|||||||
done;
|
done;
|
||||||
!found
|
!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 jit_compile_lambda (l : lambda) globals =
|
||||||
let fn_name = match l.l_name with Some n -> n | None -> "<anon>" in
|
let fn_name = match l.l_name with Some n -> n | None -> "<anon>" in
|
||||||
if !_jit_compiling then (
|
if !_jit_compiling then (
|
||||||
@@ -1127,6 +1187,13 @@ let jit_compile_lambda (l : lambda) globals =
|
|||||||
None
|
None
|
||||||
) else if _jit_is_broken_name fn_name then (
|
) else if _jit_is_broken_name fn_name then (
|
||||||
None
|
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
|
) else
|
||||||
try
|
try
|
||||||
_jit_compiling := true;
|
_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%!"
|
Printf.eprintf "[jit] SKIP %s: bytecode uses extension opcodes (interpret-only in v1)\n%!"
|
||||||
fn_name;
|
fn_name;
|
||||||
None
|
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
|
end else
|
||||||
Some { vm_code = code; vm_upvalues = [||];
|
Some { vm_code = code; vm_upvalues = [||];
|
||||||
vm_name = l.l_name; vm_env_ref = effective_globals; vm_closure_env = Some l.l_closure }
|
vm_name = l.l_name; vm_env_ref = effective_globals; vm_closure_env = Some l.l_closure }
|
||||||
|
|||||||
@@ -757,4 +757,24 @@
|
|||||||
"format-arguments" args))))
|
"format-arguments" args))))
|
||||||
(cl-restart-case
|
(cl-restart-case
|
||||||
(fn () (cl-signal-obj obj cl-handler-stack))
|
(fn () (cl-signal-obj obj cl-handler-stack))
|
||||||
(list "continue" (list) (fn () nil))))))
|
(list "continue" (list) (fn () nil))))))
|
||||||
|
;; ── JIT interpret-only boundary ───────────────────────────────────────────
|
||||||
|
;; The Common-Lisp evaluator implements block/return-from, catch/throw, and
|
||||||
|
;; the condition system via non-local control (host continuations); under JIT
|
||||||
|
;; a compiled frame can't transfer control through a CEK continuation. Exclude
|
||||||
|
;; the cl-/clos- namespaces from JIT. See Sx_types.jit_excluded_prefixes.
|
||||||
|
(jit-exclude! "cl-*" "clos-*")
|
||||||
|
|
||||||
|
;; cl-restart-case / cl-handler-case / cl-handler-bind wrap their body in
|
||||||
|
;; call/cc (restarts + non-local handler exit). Any function that CALLS one of
|
||||||
|
;; these (e.g. SX fixtures driving the condition system: parse-recover,
|
||||||
|
;; interactive-debugger) must also be interpret-only: JIT'ing such a caller
|
||||||
|
;; forces the call/cc form into a nested cek-run where the captured
|
||||||
|
;; continuation runs-to-completion-and-returns instead of escaping, so a
|
||||||
|
;; restart fails to abort and the body falls through (accumulation/no-abort).
|
||||||
|
(jit-exclude-callers-of! "cl-restart-case" "cl-handler-case" "cl-handler-bind")
|
||||||
|
;; Also the INVOKE side: cl-invoke-restart / cl-invoke-debugger / cl-signal
|
||||||
|
;; trigger the continuation escape; a JIT'd caller can't let the escape
|
||||||
|
;; propagate out of its frame (e.g. make-policy-debugger building a debugger
|
||||||
|
;; hook that invokes a restart). Mark their callers interpret-only too.
|
||||||
|
(jit-exclude-callers-of! "cl-invoke-restart" "cl-invoke-debugger" "cl-signal" "cl-error-with-debugger")
|
||||||
|
|||||||
@@ -783,11 +783,7 @@
|
|||||||
(rest-clauses
|
(rest-clauses
|
||||||
(if (> (len flat-args) 2) (slice flat-args 2) (list))))
|
(if (> (len flat-args) 2) (slice flat-args 2) (list))))
|
||||||
(if
|
(if
|
||||||
(or
|
(or (and (= (type-of test) "keyword") (= (keyword-name test) "else")) (and (= (type-of test) "symbol") (or (= (symbol-name test) "else") (= (symbol-name test) ":else"))) (= test true))
|
||||||
(and
|
|
||||||
(= (type-of test) "keyword")
|
|
||||||
(= (keyword-name test) "else"))
|
|
||||||
(= test true))
|
|
||||||
(compile-expr em body scope tail?)
|
(compile-expr em body scope tail?)
|
||||||
(do
|
(do
|
||||||
(compile-expr em test scope false)
|
(compile-expr em test scope false)
|
||||||
@@ -828,11 +824,7 @@
|
|||||||
(rest-clauses
|
(rest-clauses
|
||||||
(if (> (len clauses) 2) (slice clauses 2) (list))))
|
(if (> (len clauses) 2) (slice clauses 2) (list))))
|
||||||
(if
|
(if
|
||||||
(or
|
(or (and (= (type-of test) "keyword") (= (keyword-name test) "else")) (and (= (type-of test) "symbol") (or (= (symbol-name test) "else") (= (symbol-name test) ":else"))) (= test true))
|
||||||
(and
|
|
||||||
(= (type-of test) "keyword")
|
|
||||||
(= (keyword-name test) "else"))
|
|
||||||
(= test true))
|
|
||||||
(do (emit-op em 5) (compile-expr em body scope tail?))
|
(do (emit-op em 5) (compile-expr em body scope tail?))
|
||||||
(do
|
(do
|
||||||
(emit-op em 6)
|
(emit-op em 6)
|
||||||
@@ -1172,11 +1164,7 @@
|
|||||||
(test (first clause))
|
(test (first clause))
|
||||||
(body (rest clause)))
|
(body (rest clause)))
|
||||||
(if
|
(if
|
||||||
(or
|
(or (and (= (type-of test) "keyword") (= (keyword-name test) "else")) (and (= (type-of test) "symbol") (or (= (symbol-name test) "else") (= (symbol-name test) ":else"))) (= test true))
|
||||||
(and
|
|
||||||
(= (type-of test) "keyword")
|
|
||||||
(= (keyword-name test) "else"))
|
|
||||||
(= test true))
|
|
||||||
(compile-begin em body scope tail?)
|
(compile-begin em body scope tail?)
|
||||||
(do
|
(do
|
||||||
(compile-expr em test scope false)
|
(compile-expr em test scope false)
|
||||||
|
|||||||
@@ -853,112 +853,6 @@
|
|||||||
(define er-modules-get (fn () (nth er-modules 0)))
|
(define er-modules-get (fn () (nth er-modules 0)))
|
||||||
(define er-modules-reset! (fn () (set-nth! er-modules 0 {})))
|
(define er-modules-reset! (fn () (set-nth! er-modules 0 {})))
|
||||||
|
|
||||||
(define er-mk-module-slot
|
|
||||||
(fn (mod-env old-env version)
|
|
||||||
{:current mod-env :old old-env :version version :tag "module"}))
|
|
||||||
|
|
||||||
(define er-module-current-env (fn (slot) (get slot :current)))
|
|
||||||
(define er-module-old-env (fn (slot) (get slot :old)))
|
|
||||||
(define er-module-version (fn (slot) (get slot :version)))
|
|
||||||
|
|
||||||
;; ── FFI BIF registry (Phase 8) ───────────────────────────────────
|
|
||||||
;; Global dict from "Module/Name/Arity" key to {:module :name :arity :fn :pure?}.
|
|
||||||
;; Replaces the giant cond chain in transpile.sx#er-apply-remote-bif over time —
|
|
||||||
;; Phase 8 BIFs (crypto / cid / file / httpc / sqlite) all register here.
|
|
||||||
(define er-bif-registry (list {}))
|
|
||||||
(define er-bif-registry-get (fn () (nth er-bif-registry 0)))
|
|
||||||
(define er-bif-registry-reset! (fn () (set-nth! er-bif-registry 0 {})))
|
|
||||||
|
|
||||||
(define er-bif-key
|
|
||||||
(fn (module name arity)
|
|
||||||
(str module "/" name "/" arity)))
|
|
||||||
|
|
||||||
(define er-register-bif!
|
|
||||||
(fn (module name arity sx-fn)
|
|
||||||
(dict-set! (er-bif-registry-get) (er-bif-key module name arity)
|
|
||||||
{:module module :name name :arity arity :fn sx-fn :pure? false})
|
|
||||||
(er-mk-atom "ok")))
|
|
||||||
|
|
||||||
(define er-register-pure-bif!
|
|
||||||
(fn (module name arity sx-fn)
|
|
||||||
(dict-set! (er-bif-registry-get) (er-bif-key module name arity)
|
|
||||||
{:module module :name name :arity arity :fn sx-fn :pure? true})
|
|
||||||
(er-mk-atom "ok")))
|
|
||||||
|
|
||||||
(define er-lookup-bif
|
|
||||||
(fn (module name arity)
|
|
||||||
(let ((reg (er-bif-registry-get)) (k (er-bif-key module name arity)))
|
|
||||||
(if (dict-has? reg k) (get reg k) nil))))
|
|
||||||
|
|
||||||
(define er-list-bifs
|
|
||||||
(fn () (keys (er-bif-registry-get))))
|
|
||||||
|
|
||||||
;; ── term marshalling (Phase 8) ───────────────────────────────────
|
|
||||||
;; Bridge Erlang term values (tagged dicts) and SX-native values for
|
|
||||||
;; FFI BIFs to call out into platform primitives. Conversions:
|
|
||||||
;;
|
|
||||||
;; Erlang SX-native
|
|
||||||
;; ───────────────────────── ────────────────
|
|
||||||
;; atom {:tag "atom" :name S} ↔ symbol (make-symbol S)
|
|
||||||
;; nil {:tag "nil"} ↔ '()
|
|
||||||
;; cons {:tag "cons" :head :tail} → list of marshalled elements
|
|
||||||
;; tuple {:tag "tuple" :elements} → list of marshalled elements
|
|
||||||
;; binary {:tag "binary" :bytes} ↔ SX string
|
|
||||||
;; integer / float / boolean ↔ passthrough
|
|
||||||
;; SX string on the way back → binary
|
|
||||||
;;
|
|
||||||
;; Pids, refs, funs pass through unchanged — they have no SX-native
|
|
||||||
;; equivalent and are opaque to FFI primitives.
|
|
||||||
|
|
||||||
(define er-cons-to-sx-list
|
|
||||||
(fn (v)
|
|
||||||
(cond
|
|
||||||
(er-nil? v) (list)
|
|
||||||
(er-cons? v)
|
|
||||||
(let ((tail (er-cons-to-sx-list (get v :tail)))
|
|
||||||
(head (er-to-sx (get v :head))))
|
|
||||||
(let ((out (list head)))
|
|
||||||
(for-each
|
|
||||||
(fn (i) (append! out (nth tail i)))
|
|
||||||
(range 0 (len tail)))
|
|
||||||
out))
|
|
||||||
:else (list v))))
|
|
||||||
|
|
||||||
(define er-to-sx
|
|
||||||
(fn (v)
|
|
||||||
(cond
|
|
||||||
(er-atom? v) (make-symbol (get v :name))
|
|
||||||
(er-nil? v) (list)
|
|
||||||
(er-cons? v) (er-cons-to-sx-list v)
|
|
||||||
(er-tuple? v)
|
|
||||||
(let ((out (list)) (es (get v :elements)))
|
|
||||||
(for-each
|
|
||||||
(fn (i) (append! out (er-to-sx (nth es i))))
|
|
||||||
(range 0 (len es)))
|
|
||||||
out)
|
|
||||||
(er-binary? v) (list->string (map integer->char (get v :bytes)))
|
|
||||||
:else v)))
|
|
||||||
|
|
||||||
(define er-of-sx
|
|
||||||
(fn (v)
|
|
||||||
(let ((ty (type-of v)))
|
|
||||||
(cond
|
|
||||||
(= ty "symbol") (er-mk-atom (str v))
|
|
||||||
(= ty "string") (er-mk-binary (map char->integer (string->list v)))
|
|
||||||
(= ty "list")
|
|
||||||
(let ((out (er-mk-nil)))
|
|
||||||
(for-each
|
|
||||||
(fn (i)
|
|
||||||
(set! out
|
|
||||||
(er-mk-cons (er-of-sx (nth v (- (- (len v) 1) i))) out)))
|
|
||||||
(range 0 (len v)))
|
|
||||||
out)
|
|
||||||
(= ty "nil") (er-mk-nil)
|
|
||||||
:else v))))
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
;; Load an Erlang module declaration. Source must start with
|
;; Load an Erlang module declaration. Source must start with
|
||||||
;; `-module(Name).` and contain function definitions. Functions
|
;; `-module(Name).` and contain function definitions. Functions
|
||||||
;; sharing a name (different arities) get their clauses concatenated
|
;; sharing a name (different arities) get their clauses concatenated
|
||||||
@@ -1003,15 +897,7 @@
|
|||||||
((all-clauses (get by-name k)))
|
((all-clauses (get by-name k)))
|
||||||
(er-env-bind! mod-env k (er-mk-fun all-clauses mod-env))))
|
(er-env-bind! mod-env k (er-mk-fun all-clauses mod-env))))
|
||||||
(keys by-name))
|
(keys by-name))
|
||||||
(let ((registry (er-modules-get)))
|
(dict-set! (er-modules-get) mod-name mod-env)
|
||||||
(if (dict-has? registry mod-name)
|
|
||||||
(let ((existing-slot (get registry mod-name)))
|
|
||||||
(dict-set! registry mod-name
|
|
||||||
(er-mk-module-slot mod-env
|
|
||||||
(er-module-current-env existing-slot)
|
|
||||||
(+ (er-module-version existing-slot) 1))))
|
|
||||||
(dict-set! registry mod-name
|
|
||||||
(er-mk-module-slot mod-env nil 1))))
|
|
||||||
(er-mk-atom mod-name)))))
|
(er-mk-atom mod-name)))))
|
||||||
|
|
||||||
(define
|
(define
|
||||||
@@ -1019,7 +905,7 @@
|
|||||||
(fn
|
(fn
|
||||||
(mod name vs)
|
(mod name vs)
|
||||||
(let
|
(let
|
||||||
((mod-env (er-module-current-env (get (er-modules-get) mod))))
|
((mod-env (get (er-modules-get) mod)))
|
||||||
(if
|
(if
|
||||||
(not (dict-has? mod-env name))
|
(not (dict-has? mod-env name))
|
||||||
(raise
|
(raise
|
||||||
@@ -1303,325 +1189,24 @@
|
|||||||
:else (er-mk-atom "undefined")))
|
:else (er-mk-atom "undefined")))
|
||||||
:else (error "Erlang: ets:info: arity"))))
|
:else (error "Erlang: ets:info: arity"))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
er-apply-ets-bif
|
||||||
;; ── file module (Phase 8 FFI) ────────────────────────────────────
|
(fn
|
||||||
;; Synchronous file IO. Filenames must be SX strings (or Erlang
|
(name vs)
|
||||||
;; binaries/char-code lists coercible to strings via er-source-to-string).
|
|
||||||
;; Returns `{ok, Binary}` / `ok` on success, `{error, Reason}` on failure
|
|
||||||
;; where Reason is one of `enoent`, `eacces`, `enotdir`, `posix_error`.
|
|
||||||
|
|
||||||
(define er-classify-file-error
|
|
||||||
(fn (msg)
|
|
||||||
(let ((s (str msg)))
|
|
||||||
(cond
|
|
||||||
(string-contains? s "No such") (er-mk-atom "enoent")
|
|
||||||
(string-contains? s "Permission denied") (er-mk-atom "eacces")
|
|
||||||
(string-contains? s "Not a directory") (er-mk-atom "enotdir")
|
|
||||||
(string-contains? s "Is a directory") (er-mk-atom "eisdir")
|
|
||||||
:else (er-mk-atom "posix_error")))))
|
|
||||||
|
|
||||||
(define er-bif-file-read-file
|
|
||||||
(fn (vs)
|
|
||||||
(let ((path (er-source-to-string (nth vs 0))))
|
|
||||||
(cond
|
|
||||||
(= path nil)
|
|
||||||
(er-mk-tuple (list (er-mk-atom "error") (er-mk-atom "badarg")))
|
|
||||||
:else
|
|
||||||
(let ((res (list nil)) (err (list nil)))
|
|
||||||
(guard (c (:else (set-nth! err 0 c)))
|
|
||||||
(set-nth! res 0 (file-read path)))
|
|
||||||
(cond
|
|
||||||
(not (= (nth err 0) nil))
|
|
||||||
(er-mk-tuple (list (er-mk-atom "error")
|
|
||||||
(er-classify-file-error (nth err 0))))
|
|
||||||
:else
|
|
||||||
(er-mk-tuple (list (er-mk-atom "ok")
|
|
||||||
(er-mk-binary (map char->integer (string->list (nth res 0))))))))))))
|
|
||||||
|
|
||||||
(define er-bif-file-write-file
|
|
||||||
(fn (vs)
|
|
||||||
(let ((path (er-source-to-string (nth vs 0)))
|
|
||||||
(data (er-source-to-string (nth vs 1))))
|
|
||||||
(cond
|
|
||||||
(or (= path nil) (= data nil))
|
|
||||||
(er-mk-tuple (list (er-mk-atom "error") (er-mk-atom "badarg")))
|
|
||||||
:else
|
|
||||||
(let ((err (list nil)))
|
|
||||||
(guard (c (:else (set-nth! err 0 c)))
|
|
||||||
(file-write path data))
|
|
||||||
(cond
|
|
||||||
(not (= (nth err 0) nil))
|
|
||||||
(er-mk-tuple (list (er-mk-atom "error")
|
|
||||||
(er-classify-file-error (nth err 0))))
|
|
||||||
:else (er-mk-atom "ok")))))))
|
|
||||||
|
|
||||||
(define er-bif-file-delete
|
|
||||||
(fn (vs)
|
|
||||||
(let ((path (er-source-to-string (nth vs 0))))
|
|
||||||
(cond
|
|
||||||
(= path nil)
|
|
||||||
(er-mk-tuple (list (er-mk-atom "error") (er-mk-atom "badarg")))
|
|
||||||
:else
|
|
||||||
(let ((err (list nil)))
|
|
||||||
(guard (c (:else (set-nth! err 0 c)))
|
|
||||||
(file-delete path))
|
|
||||||
(cond
|
|
||||||
(not (= (nth err 0) nil))
|
|
||||||
(er-mk-tuple (list (er-mk-atom "error")
|
|
||||||
(er-classify-file-error (nth err 0))))
|
|
||||||
:else (er-mk-atom "ok")))))))
|
|
||||||
|
|
||||||
|
|
||||||
;; ── crypto / cid / file:list_dir (Phase 8 FFI — host primitives) ──
|
|
||||||
;; Wired against loops/fed-prims host primitives (see plans Blockers
|
|
||||||
;; "RESOLVED 2026-05-18"). Term marshalling at the boundary:
|
|
||||||
;; Erlang binary/string/charlist -> SX byte-string via er-source-to-string;
|
|
||||||
;; results -> Erlang binary via er-mk-binary.
|
|
||||||
|
|
||||||
(define er-hexval
|
|
||||||
(fn (c)
|
|
||||||
(let ((v (char->integer c)))
|
|
||||||
(cond
|
|
||||||
(and (>= v 48) (<= v 57)) (- v 48) ;; 0-9
|
|
||||||
(and (>= v 97) (<= v 102)) (+ 10 (- v 97)) ;; a-f
|
|
||||||
(and (>= v 65) (<= v 70)) (+ 10 (- v 65)) ;; A-F
|
|
||||||
:else 0))))
|
|
||||||
|
|
||||||
(define er-hex->bytes
|
|
||||||
(fn (hex)
|
|
||||||
(let ((cs (string->list hex)) (out (list)) (n (string-length hex)))
|
|
||||||
(for-each
|
|
||||||
(fn (i)
|
|
||||||
(append! out
|
|
||||||
(+ (* 16 (er-hexval (nth cs (* i 2))))
|
|
||||||
(er-hexval (nth cs (+ (* i 2) 1))))))
|
|
||||||
(range 0 (truncate (/ n 2))))
|
|
||||||
out)))
|
|
||||||
|
|
||||||
;; crypto:hash(Type, Data) -> raw digest binary. Type is an Erlang
|
|
||||||
;; atom (sha256 | sha512 | sha3_256). Bad type / non-binary -> badarg.
|
|
||||||
(define er-bif-crypto-hash
|
|
||||||
(fn (vs)
|
|
||||||
(let ((ty (nth vs 0)) (data (er-source-to-string (nth vs 1))))
|
|
||||||
(cond
|
|
||||||
(or (not (er-atom? ty)) (= data nil))
|
|
||||||
(raise (er-mk-error-marker (er-mk-atom "badarg")))
|
|
||||||
:else
|
|
||||||
(let ((name (get ty :name)))
|
|
||||||
(let ((hex (cond
|
|
||||||
(= name "sha256") (crypto-sha256 data)
|
|
||||||
(= name "sha512") (crypto-sha512 data)
|
|
||||||
(= name "sha3_256") (crypto-sha3-256 data)
|
|
||||||
:else nil)))
|
|
||||||
(cond
|
|
||||||
(= hex nil) (raise (er-mk-error-marker (er-mk-atom "badarg")))
|
|
||||||
:else (er-mk-binary (er-hex->bytes hex)))))))))
|
|
||||||
|
|
||||||
;; cid:from_bytes(Bin) -> CIDv1 (raw codec 0x55, sha2-256 multihash)
|
|
||||||
;; as an Erlang binary string.
|
|
||||||
(define er-bif-cid-from-bytes
|
|
||||||
(fn (vs)
|
|
||||||
(let ((data (er-source-to-string (nth vs 0))))
|
|
||||||
(cond
|
|
||||||
(= data nil) (raise (er-mk-error-marker (er-mk-atom "badarg")))
|
|
||||||
:else
|
|
||||||
(let ((digest (er-hex->bytes (crypto-sha256 data))))
|
|
||||||
(let ((mh (list->string
|
|
||||||
(map integer->char (append (list 18 32) digest)))))
|
|
||||||
(er-mk-binary
|
|
||||||
(map char->integer
|
|
||||||
(string->list (cid-from-bytes 85 mh))))))))))
|
|
||||||
|
|
||||||
;; cid:to_string(Term) -> canonical CIDv1 (dag-cbor) of the term,
|
|
||||||
;; as an Erlang binary string.
|
|
||||||
(define er-bif-cid-to-string
|
|
||||||
(fn (vs)
|
|
||||||
;; Canonical CID of the term's stable string form. (cbor-encode
|
|
||||||
;; rejects symbols, so er-to-sx of compound terms is unencodable;
|
|
||||||
;; er-format-value yields a canonical SX string per term value.)
|
|
||||||
(er-mk-binary
|
|
||||||
(map char->integer
|
|
||||||
(string->list (cid-from-sx (er-format-value (nth vs 0))))))))
|
|
||||||
|
|
||||||
;; file:list_dir(Path) -> {ok, [Binary]} | {error, Reason}
|
|
||||||
(define er-bif-file-list-dir
|
|
||||||
(fn (vs)
|
|
||||||
(let ((path (er-source-to-string (nth vs 0))))
|
|
||||||
(cond
|
|
||||||
(= path nil)
|
|
||||||
(er-mk-tuple (list (er-mk-atom "error") (er-mk-atom "badarg")))
|
|
||||||
:else
|
|
||||||
(let ((res (list nil)) (err (list nil)))
|
|
||||||
(guard (c (:else (set-nth! err 0 c)))
|
|
||||||
(set-nth! res 0 (file-list-dir path)))
|
|
||||||
(cond
|
|
||||||
(not (= (nth err 0) nil))
|
|
||||||
(er-mk-tuple (list (er-mk-atom "error")
|
|
||||||
(er-classify-file-error (nth err 0))))
|
|
||||||
:else
|
|
||||||
(er-mk-tuple (list (er-mk-atom "ok")
|
|
||||||
(er-of-sx (nth res 0))))))))))
|
|
||||||
|
|
||||||
;; ── builtin BIF registrations (Phase 8 migration) ────────────────
|
|
||||||
;; Populates `er-bif-registry` with every existing built-in BIF. Each
|
|
||||||
;; entry is keyed by "Module/Name/Arity"; multi-arity BIFs register
|
|
||||||
;; once per arity. Called eagerly at the end of runtime.sx so the
|
|
||||||
;; registry is ready before any erlang-eval-ast call.
|
|
||||||
(define er-register-builtin-bifs!
|
|
||||||
(fn ()
|
|
||||||
;; erlang module — type predicates (all pure)
|
|
||||||
(er-register-pure-bif! "erlang" "is_integer" 1 er-bif-is-integer)
|
|
||||||
(er-register-pure-bif! "erlang" "is_atom" 1 er-bif-is-atom)
|
|
||||||
(er-register-pure-bif! "erlang" "is_list" 1 er-bif-is-list)
|
|
||||||
(er-register-pure-bif! "erlang" "is_tuple" 1 er-bif-is-tuple)
|
|
||||||
(er-register-pure-bif! "erlang" "is_number" 1 er-bif-is-number)
|
|
||||||
(er-register-pure-bif! "erlang" "is_float" 1 er-bif-is-float)
|
|
||||||
(er-register-pure-bif! "erlang" "is_boolean" 1 er-bif-is-boolean)
|
|
||||||
(er-register-pure-bif! "erlang" "is_pid" 1 er-bif-is-pid)
|
|
||||||
(er-register-pure-bif! "erlang" "is_reference" 1 er-bif-is-reference)
|
|
||||||
(er-register-pure-bif! "erlang" "is_binary" 1 er-bif-is-binary)
|
|
||||||
(er-register-pure-bif! "erlang" "is_function" 1 er-bif-is-function)
|
|
||||||
(er-register-pure-bif! "erlang" "is_function" 2 er-bif-is-function)
|
|
||||||
;; erlang module — pure data ops
|
|
||||||
(er-register-pure-bif! "erlang" "length" 1 er-bif-length)
|
|
||||||
(er-register-pure-bif! "erlang" "hd" 1 er-bif-hd)
|
|
||||||
(er-register-pure-bif! "erlang" "tl" 1 er-bif-tl)
|
|
||||||
(er-register-pure-bif! "erlang" "element" 2 er-bif-element)
|
|
||||||
(er-register-pure-bif! "erlang" "tuple_size" 1 er-bif-tuple-size)
|
|
||||||
(er-register-pure-bif! "erlang" "byte_size" 1 er-bif-byte-size)
|
|
||||||
(er-register-pure-bif! "erlang" "atom_to_list" 1 er-bif-atom-to-list)
|
|
||||||
(er-register-pure-bif! "erlang" "list_to_atom" 1 er-bif-list-to-atom)
|
|
||||||
(er-register-pure-bif! "erlang" "abs" 1 er-bif-abs)
|
|
||||||
(er-register-pure-bif! "erlang" "min" 2 er-bif-min)
|
|
||||||
(er-register-pure-bif! "erlang" "max" 2 er-bif-max)
|
|
||||||
(er-register-pure-bif! "erlang" "tuple_to_list" 1 er-bif-tuple-to-list)
|
|
||||||
(er-register-pure-bif! "erlang" "list_to_tuple" 1 er-bif-list-to-tuple)
|
|
||||||
(er-register-pure-bif! "erlang" "integer_to_list" 1 er-bif-integer-to-list)
|
|
||||||
(er-register-pure-bif! "erlang" "list_to_integer" 1 er-bif-list-to-integer)
|
|
||||||
;; erlang module — process / runtime (side-effecting)
|
|
||||||
(er-register-bif! "erlang" "self" 0 er-bif-self)
|
|
||||||
(er-register-bif! "erlang" "spawn" 1 er-bif-spawn)
|
|
||||||
(er-register-bif! "erlang" "spawn" 3 er-bif-spawn)
|
|
||||||
(er-register-bif! "erlang" "exit" 1 er-bif-exit)
|
|
||||||
(er-register-bif! "erlang" "exit" 2 er-bif-exit)
|
|
||||||
(er-register-bif! "erlang" "make_ref" 0 er-bif-make-ref)
|
|
||||||
(er-register-bif! "erlang" "link" 1 er-bif-link)
|
|
||||||
(er-register-bif! "erlang" "unlink" 1 er-bif-unlink)
|
|
||||||
(er-register-bif! "erlang" "monitor" 2 er-bif-monitor)
|
|
||||||
(er-register-bif! "erlang" "demonitor" 1 er-bif-demonitor)
|
|
||||||
(er-register-bif! "erlang" "process_flag" 2 er-bif-process-flag)
|
|
||||||
(er-register-bif! "erlang" "register" 2 er-bif-register)
|
|
||||||
(er-register-bif! "erlang" "unregister" 1 er-bif-unregister)
|
|
||||||
(er-register-bif! "erlang" "whereis" 1 er-bif-whereis)
|
|
||||||
(er-register-bif! "erlang" "registered" 0 er-bif-registered)
|
|
||||||
;; erlang module — exception raising (modelled as side-effecting)
|
|
||||||
(er-register-bif! "erlang" "throw" 1
|
|
||||||
(fn (vs) (raise (er-mk-throw-marker (er-bif-arg1 vs "throw")))))
|
|
||||||
(er-register-bif! "erlang" "error" 1
|
|
||||||
(fn (vs) (raise (er-mk-error-marker (er-bif-arg1 vs "error")))))
|
|
||||||
;; lists module — all pure
|
|
||||||
(er-register-pure-bif! "lists" "reverse" 1 er-bif-lists-reverse)
|
|
||||||
(er-register-pure-bif! "lists" "map" 2 er-bif-lists-map)
|
|
||||||
(er-register-pure-bif! "lists" "foldl" 3 er-bif-lists-foldl)
|
|
||||||
(er-register-pure-bif! "lists" "seq" 2 er-bif-lists-seq)
|
|
||||||
(er-register-pure-bif! "lists" "seq" 3 er-bif-lists-seq)
|
|
||||||
(er-register-pure-bif! "lists" "sum" 1 er-bif-lists-sum)
|
|
||||||
(er-register-pure-bif! "lists" "nth" 2 er-bif-lists-nth)
|
|
||||||
(er-register-pure-bif! "lists" "last" 1 er-bif-lists-last)
|
|
||||||
(er-register-pure-bif! "lists" "member" 2 er-bif-lists-member)
|
|
||||||
(er-register-pure-bif! "lists" "append" 2 er-bif-lists-append)
|
|
||||||
(er-register-pure-bif! "lists" "filter" 2 er-bif-lists-filter)
|
|
||||||
(er-register-pure-bif! "lists" "any" 2 er-bif-lists-any)
|
|
||||||
(er-register-pure-bif! "lists" "all" 2 er-bif-lists-all)
|
|
||||||
(er-register-pure-bif! "lists" "duplicate" 2 er-bif-lists-duplicate)
|
|
||||||
;; io module — side-effecting (writes to io buffer)
|
|
||||||
(er-register-bif! "io" "format" 1 er-bif-io-format)
|
|
||||||
(er-register-bif! "io" "format" 2 er-bif-io-format)
|
|
||||||
;; ets module — side-effecting (mutates table state)
|
|
||||||
(er-register-bif! "ets" "new" 2 er-bif-ets-new)
|
|
||||||
(er-register-bif! "ets" "insert" 2 er-bif-ets-insert)
|
|
||||||
(er-register-bif! "ets" "lookup" 2 er-bif-ets-lookup)
|
|
||||||
(er-register-bif! "ets" "delete" 1 er-bif-ets-delete)
|
|
||||||
(er-register-bif! "ets" "delete" 2 er-bif-ets-delete)
|
|
||||||
(er-register-bif! "ets" "tab2list" 1 er-bif-ets-tab2list)
|
|
||||||
(er-register-bif! "ets" "info" 2 er-bif-ets-info)
|
|
||||||
;; code module — side-effecting (mutates module registry, kills procs)
|
|
||||||
(er-register-bif! "code" "load_binary" 3 er-bif-code-load-binary)
|
|
||||||
(er-register-bif! "code" "purge" 1 er-bif-code-purge)
|
|
||||||
(er-register-bif! "code" "soft_purge" 1 er-bif-code-soft-purge)
|
|
||||||
(er-register-bif! "code" "which" 1 er-bif-code-which)
|
|
||||||
(er-register-bif! "code" "is_loaded" 1 er-bif-code-is-loaded)
|
|
||||||
(er-register-bif! "code" "all_loaded" 0 er-bif-code-all-loaded)
|
|
||||||
;; file module
|
|
||||||
(er-register-bif! "file" "read_file" 1 er-bif-file-read-file)
|
|
||||||
(er-register-bif! "file" "write_file" 2 er-bif-file-write-file)
|
|
||||||
(er-register-bif! "file" "delete" 1 er-bif-file-delete)
|
|
||||||
;; Phase 8 FFI — host-primitive BIFs (loops/fed-prims)
|
|
||||||
(er-register-pure-bif! "crypto" "hash" 2 er-bif-crypto-hash)
|
|
||||||
(er-register-pure-bif! "cid" "from_bytes" 1 er-bif-cid-from-bytes)
|
|
||||||
(er-register-pure-bif! "cid" "to_string" 1 er-bif-cid-to-string)
|
|
||||||
|
|
||||||
;; ── binary_to_list / list_to_binary (Step 3b — term codec) ──────
|
|
||||||
;; Standard Erlang semantics:
|
|
||||||
;; binary_to_list(<<B1,B2,...>>) -> [B1, B2, ...] (Erlang cons of ints)
|
|
||||||
;; list_to_binary(IoList) -> <<...>> (flattens nested
|
|
||||||
;; iolists; elements are byte ints 0-255 or binaries)
|
|
||||||
;; Bad arg / out-of-range byte / non-iolist element -> error:badarg.
|
|
||||||
|
|
||||||
(define er-bif-binary-to-list
|
|
||||||
(fn (vs)
|
|
||||||
(let ((v (nth vs 0)))
|
|
||||||
(cond
|
|
||||||
(not (er-binary? v))
|
|
||||||
(raise (er-mk-error-marker (er-mk-atom "badarg")))
|
|
||||||
:else
|
|
||||||
(let ((bs (get v :bytes)) (out (er-mk-nil)))
|
|
||||||
(for-each
|
|
||||||
(fn (i)
|
|
||||||
(set! out (er-mk-cons (nth bs (- (- (len bs) 1) i)) out)))
|
|
||||||
(range 0 (len bs)))
|
|
||||||
out)))))
|
|
||||||
|
|
||||||
;; Walk an Erlang iolist, appending bytes to `acc` (a mutable SX list).
|
|
||||||
;; Accepts: nil, cons-of-X, binary, integer in 0..255. Anything else
|
|
||||||
;; signals failure by setting (nth fail 0) to true.
|
|
||||||
(define er-iolist-walk!
|
|
||||||
(fn (v acc fail)
|
|
||||||
(cond
|
(cond
|
||||||
(nth fail 0) nil
|
(= name "new") (er-bif-ets-new vs)
|
||||||
(er-nil? v) nil
|
(= name "insert") (er-bif-ets-insert vs)
|
||||||
(er-cons? v)
|
(= name "lookup") (er-bif-ets-lookup vs)
|
||||||
(do (er-iolist-walk! (get v :head) acc fail)
|
(= name "delete") (er-bif-ets-delete vs)
|
||||||
(er-iolist-walk! (get v :tail) acc fail))
|
(= name "tab2list") (er-bif-ets-tab2list vs)
|
||||||
(er-binary? v)
|
(= name "info") (er-bif-ets-info vs)
|
||||||
(for-each
|
:else (error
|
||||||
(fn (i) (append! acc (nth (get v :bytes) i)))
|
(str "Erlang: undefined 'ets:" name "/" (len vs) "'")))))
|
||||||
(range 0 (len (get v :bytes))))
|
|
||||||
(= (type-of v) "number")
|
|
||||||
(cond
|
|
||||||
(and (>= v 0) (<= v 255)) (append! acc v)
|
|
||||||
:else (set-nth! fail 0 true))
|
|
||||||
:else (set-nth! fail 0 true))))
|
|
||||||
|
|
||||||
(define er-bif-list-to-binary
|
;; ── JIT interpret-only boundary ───────────────────────────────────────────
|
||||||
(fn (vs)
|
;; The Erlang evaluator (er-eval-* in transpile.sx + the vm/dispatcher) recurses
|
||||||
(let ((v (nth vs 0)) (acc (list)) (fail (list false)))
|
;; over the AST and the scheduler/receive path captures call/cc continuations.
|
||||||
(cond
|
;; Under JIT the recursive eval miscompiles into a non-terminating loop and the
|
||||||
(not (or (er-nil? v) (er-cons? v) (er-binary? v)))
|
;; continuation path cannot transfer control. Exclude the whole er-/erlang-
|
||||||
(raise (er-mk-error-marker (er-mk-atom "badarg")))
|
;; namespace (covers transpile, runtime, and vm/dispatcher in one declaration).
|
||||||
:else
|
(jit-exclude! "er-*" "erlang-*")
|
||||||
(do
|
|
||||||
(er-iolist-walk! v acc fail)
|
|
||||||
(cond
|
|
||||||
(nth fail 0)
|
|
||||||
(raise (er-mk-error-marker (er-mk-atom "badarg")))
|
|
||||||
:else (er-mk-binary acc)))))))
|
|
||||||
|
|
||||||
(er-register-bif! "file" "list_dir" 1 er-bif-file-list-dir)
|
|
||||||
(er-register-pure-bif! "erlang" "binary_to_list" 1 er-bif-binary-to-list)
|
|
||||||
(er-register-pure-bif! "erlang" "list_to_binary" 1 er-bif-list-to-binary)
|
|
||||||
(er-mk-atom "ok")))
|
|
||||||
|
|
||||||
;; Register everything at load time.
|
|
||||||
(er-register-builtin-bifs!)
|
|
||||||
|
|||||||
@@ -148,3 +148,9 @@
|
|||||||
(fn (acc i) (str acc (char-at buf i)))
|
(fn (acc i) (str acc (char-at buf i)))
|
||||||
""
|
""
|
||||||
(range off (string-length buf)))))))
|
(range off (string-length buf)))))))
|
||||||
|
|
||||||
|
;; ── JIT interpret-only boundary ───────────────────────────────────────────
|
||||||
|
;; The Haskell evaluator (hk-eval and the lazy-thunk forcer) recurses deeply
|
||||||
|
;; over the AST/graph; under JIT the recursive eval can miscompile into a
|
||||||
|
;; non-terminating loop. Exclude the hk- namespace from JIT.
|
||||||
|
(jit-exclude! "hk-*")
|
||||||
|
|||||||
@@ -6994,3 +6994,9 @@
|
|||||||
(set! js-global-this js-global)
|
(set! js-global-this js-global)
|
||||||
|
|
||||||
(dict-set! js-global "globalThis" js-global)
|
(dict-set! js-global "globalThis" js-global)
|
||||||
|
|
||||||
|
;; ── JIT interpret-only boundary ───────────────────────────────────────────
|
||||||
|
;; The JS evaluator (transpile.sx) uses call/cc for control flow (exceptions,
|
||||||
|
;; early return); a JIT-compiled frame can't escape through a CEK continuation.
|
||||||
|
;; Exclude the js- namespace from JIT. See Sx_types.jit_excluded_prefixes.
|
||||||
|
(jit-exclude! "js-*" "jp-*")
|
||||||
|
|||||||
@@ -2792,3 +2792,10 @@
|
|||||||
{:cut false}
|
{:cut false}
|
||||||
(fn () (begin (dict-set! box :n (+ (dict-get box :n) 1)) false)))
|
(fn () (begin (dict-set! box :n (+ (dict-get box :n) 1)) false)))
|
||||||
(dict-get box :n))))
|
(dict-get box :n))))
|
||||||
|
|
||||||
|
;; ── JIT interpret-only boundary ───────────────────────────────────────────
|
||||||
|
;; The Prolog resolution engine (pl-solve! and friends) recurses deeply over
|
||||||
|
;; goals/clauses with backtracking; under JIT it miscompiles into a
|
||||||
|
;; non-terminating loop (the suite never completes). Exclude the whole pl-
|
||||||
|
;; namespace from JIT. See Sx_types.jit_excluded_prefixes.
|
||||||
|
(jit-exclude! "pl-*")
|
||||||
|
|||||||
@@ -647,3 +647,11 @@
|
|||||||
(raise (get outcome :value)))
|
(raise (get outcome :value)))
|
||||||
(:else outcome))))))))))
|
(:else outcome))))))))))
|
||||||
env)))
|
env)))
|
||||||
|
|
||||||
|
;; ── JIT interpret-only boundary ───────────────────────────────────────────
|
||||||
|
;; The Scheme evaluator uses call/cc, dynamic-wind, guard/raise and applies
|
||||||
|
;; user procedures (which may be continuations or JIT-returned closures); a
|
||||||
|
;; JIT-compiled frame cannot transfer control through a CEK continuation.
|
||||||
|
;; Exclude the whole scheme-/scm- namespace from JIT (robust vs a name list,
|
||||||
|
;; which misses functions in extra files). See Sx_types.jit_excluded_prefixes.
|
||||||
|
(jit-exclude! "scheme-*" "scm-*")
|
||||||
|
|||||||
@@ -1475,3 +1475,22 @@
|
|||||||
(get ast :temps)))
|
(get ast :temps)))
|
||||||
(smalltalk-eval-ast ast frame)))))))
|
(smalltalk-eval-ast ast frame)))))))
|
||||||
(begin (dict-set! cell :active false) result)))))
|
(begin (dict-set! cell :active false) result)))))
|
||||||
|
|
||||||
|
;; ── JIT interpret-only boundary ──────────────────────────────────────────
|
||||||
|
;; The Smalltalk evaluator implements non-local return (^expr), block escape,
|
||||||
|
;; and exception unwinding via first-class continuations (call/cc). A stack
|
||||||
|
;; bytecode VM cannot transfer control through a CEK continuation, so any of
|
||||||
|
;; these dispatch-core functions, if JIT-compiled, would be an un-escapable
|
||||||
|
;; VM frame on the stack between a `call/cc` capture and its `(k v)` invocation
|
||||||
|
;; — failing at runtime and (before this guard) re-running with duplicated
|
||||||
|
;; side effects. Declaring them interpret-only keeps them on the CEK while the
|
||||||
|
;; pure leaf helpers (parsing, ident/ivar lookup, formatting, predicates,
|
||||||
|
;; arithmetic) still JIT. See Sx_types.jit_excluded / `jit-exclude!`.
|
||||||
|
(jit-exclude!
|
||||||
|
"smalltalk-eval" "smalltalk-eval-program" "smalltalk-load"
|
||||||
|
"smalltalk-eval-ast" "st-eval-seq" "st-eval-send" "st-eval-send-dispatch"
|
||||||
|
"st-eval-cascade" "st-try-intrinsify" "st-send" "st-invoke" "st-dnu"
|
||||||
|
"st-super-send" "st-primitive-send" "st-num-send" "st-bool-send"
|
||||||
|
"st-string-send" "st-array-send" "st-nil-send" "st-class-side-send"
|
||||||
|
"st-block-apply" "st-block-dispatch" "st-block-while" "st-block-ensure"
|
||||||
|
"st-block-if-curtailed" "st-block-on-do" "st-block-value-selector?")
|
||||||
|
|||||||
@@ -360,3 +360,10 @@
|
|||||||
{:type "number" :value 2}))
|
{:type "number" :value 2}))
|
||||||
|
|
||||||
(list st-test-pass st-test-fail)
|
(list st-test-pass st-test-fail)
|
||||||
|
|
||||||
|
;; The SUnit suite-runner `pharo-test-class` (defined in tests/pharo.sx and
|
||||||
|
;; tests/ansi.sx) drives the interpret-only Smalltalk evaluator through
|
||||||
|
;; smalltalk-eval-program in a loop and accumulates results via st-test
|
||||||
|
;; (a side-effecting accumulator). Under JIT it can fail mid-loop and re-run
|
||||||
|
;; via CEK, double-counting already-emitted rows. Keep it interpret-only.
|
||||||
|
(jit-exclude! "pharo-test-class")
|
||||||
|
|||||||
236
plans/jit-bytecode-correctness.md
Normal file
236
plans/jit-bytecode-correctness.md
Normal file
@@ -0,0 +1,236 @@
|
|||||||
|
# JIT bytecode correctness — enable the JIT in serving mode
|
||||||
|
|
||||||
|
> Kickoff handed over from the **host-on-sx** loop (2026-06-19). This is the
|
||||||
|
> highest-leverage perf win on the platform.
|
||||||
|
|
||||||
|
## Why this matters
|
||||||
|
|
||||||
|
Every SX-on-SX subsystem runs **interpreted on the tree-walking CEK**: the
|
||||||
|
Smalltalk runtime (→ content-on-sx rendering), and the guest languages
|
||||||
|
(Datalog, Prolog, APL, Scheme, Haskell, Erlang, Maude). The lazy JIT
|
||||||
|
(`register_jit_hook` → bytecode VM) would speed all of them up ~10–60×. It is
|
||||||
|
currently **only installed in `--http` page-server mode**, not the epoch /
|
||||||
|
`http-listen` serving mode — because it **miscompiles** these workloads.
|
||||||
|
|
||||||
|
Concrete impact: the host serves a blog post (`content/html`, interpreted
|
||||||
|
Smalltalk) in **~2 seconds per request**. With a correct JIT it should be tens
|
||||||
|
of ms. Same slowdown applies to every guest-language-backed service.
|
||||||
|
|
||||||
|
## Concrete repro (from the host loop)
|
||||||
|
|
||||||
|
In `hosts/ocaml/bin/sx_server.ml`, the persistent server mode (`make_server_env`,
|
||||||
|
~line 4871) does **not** call `register_jit_hook env` — only the `--http` mode
|
||||||
|
(~line 4034) does. To reproduce the miscompile:
|
||||||
|
|
||||||
|
1. Add `register_jit_hook env;` right after `let env = make_server_env () in` in
|
||||||
|
the persistent server-mode branch (~4871).
|
||||||
|
2. Rebuild: `eval $(opam env --switch=5.2.0); dune build bin/sx_server.exe`.
|
||||||
|
3. Run a Smalltalk/content-heavy suite, e.g. the host-on-sx conformance
|
||||||
|
(`bash /root/rose-ash-loops/host/lib/host/conformance.sh`, or any
|
||||||
|
content-on-sx suite). **With the hook ON, tests FAIL** — host-on-sx dropped to
|
||||||
|
`router 3/6, feed 4/11, relations 9/16, blog 4/11`. With the hook OFF: all green.
|
||||||
|
|
||||||
|
So the JIT produces **wrong results** (the known "compiled compiler helpers loop
|
||||||
|
on complex nested ASTs" — see memory `project_jit_bytecode_bug`).
|
||||||
|
|
||||||
|
## Goal
|
||||||
|
|
||||||
|
Make the JIT compile the Smalltalk-on-SX evaluator + guest-language evaluators
|
||||||
|
**correctly**, so `register_jit_hook` can be enabled in serving mode with
|
||||||
|
conformance **fully green**. Then enable it there.
|
||||||
|
|
||||||
|
## Suggested approach
|
||||||
|
|
||||||
|
- Minimal repro to bisect: render a `lib/content` doc via `content/html` with JIT
|
||||||
|
ON vs OFF, diff the output, find the first divergence.
|
||||||
|
- Localize with the VM debugging tools (see CLAUDE.md): `(vm-trace ...)`,
|
||||||
|
`(bytecode-inspect ...)`, `(prim-check ...)`, `(deps-check ...)`.
|
||||||
|
- Likely suspects: nested closures / TCO, dict construction, `st-send` dispatch
|
||||||
|
patterns, recursion through the Smalltalk method interpreter.
|
||||||
|
|
||||||
|
## Pointers
|
||||||
|
|
||||||
|
- `register_jit_hook` — `sx_server.ml` ~1493; JIT VM-suspend/resolve path ~1497–1514.
|
||||||
|
- `hosts/ocaml/lib/sx_vm.ml` — the bytecode VM + compiler.
|
||||||
|
- `plans/jit-cache-architecture.md`, `plans/jit-perf-regression.md`, `restore-jit-perf.sh`.
|
||||||
|
- Memory: `project_jit_bytecode_bug.md` (plan ref `plans/reflective-rolling-treehouse.md`).
|
||||||
|
- The shared `sx_server.exe` binary is used by ALL loops — coordinate before
|
||||||
|
changing VM semantics that could affect sibling conformance runs.
|
||||||
|
|
||||||
|
---
|
||||||
|
|
||||||
|
## Resolution (2026-06-19, loop loops/sx-vm-extensions)
|
||||||
|
|
||||||
|
JIT is now enabled in the persistent (epoch) serving mode (`register_jit_hook`
|
||||||
|
in `sx_server.ml`'s server-mode branch). Smalltalk conformance is **847/847 —
|
||||||
|
identical to the no-JIT baseline** (no failures, no double-counted rows).
|
||||||
|
Datalog conformance (a non-continuation guest) is **356/356** under JIT.
|
||||||
|
|
||||||
|
Five distinct root causes were found and fixed (not one "miscompile"):
|
||||||
|
|
||||||
|
1. **Serving mode never loaded `lib/compiler.sx`.** The JIT then used the
|
||||||
|
native `Sx_compiler.compile` stub, which emits arity-0 bytecode with every
|
||||||
|
parameter compiled as `GLOBAL_GET` → "VM undefined: <param>" on the first
|
||||||
|
call of essentially every function. `http`/`cli`/`site` modes already load
|
||||||
|
`compiler.sx`; the epoch serving branch now does too (before the hook).
|
||||||
|
*Fix: `sx_server.ml` server-mode branch loads `lib/compiler.sx`.*
|
||||||
|
|
||||||
|
2. **`compile-cond`/`compile-case-clauses`/`compile-guard-clauses` only treated
|
||||||
|
the keyword `:else` and `true` as the catch-all** — not the bare symbol
|
||||||
|
`else` that the CEK's `is-else-clause?` accepts. They emitted
|
||||||
|
`GLOBAL_GET "else"` → runtime "VM undefined: else".
|
||||||
|
*Fix: `lib/compiler.sx` — add the symbol-`else` case to all three.*
|
||||||
|
|
||||||
|
3. **`OP_DIV` produced a float for non-divisible Integer/Integer** (`1/2` → 0.5)
|
||||||
|
instead of the exact `Rational` the `/` primitive returns → diverged from CEK
|
||||||
|
and broke equality vs rational results.
|
||||||
|
*Fix: `sx_vm.ml` — delegate non-divisible int/int to the `/` primitive.*
|
||||||
|
|
||||||
|
4. **`OP_EQ` / `_fast_eq` lacked `Rational`/`ListRef` cases** that the real `=`
|
||||||
|
primitive's `safe_eq` has → `(= 1/2 1/2)` was false under JIT.
|
||||||
|
*Fix: `OP_EQ` delegates non-trivial types to the `=` primitive;
|
||||||
|
`_fast_eq` (also used by `prim_call "="`) gained rational + ListRef cases.*
|
||||||
|
|
||||||
|
5. **Continuation-based control flow can't run in the stack VM.** Smalltalk's
|
||||||
|
non-local return (`^expr`), block escape, and exception unwinding use
|
||||||
|
`call/cc`; a JIT-compiled frame between a `call/cc` capture and its `(k v)`
|
||||||
|
invocation cannot transfer control and (via the hook's re-run-on-failure)
|
||||||
|
double-executes side effects.
|
||||||
|
*Fix: a general, data-driven exclusion set — `Sx_types.jit_excluded`,
|
||||||
|
populated from SX via the new `jit-exclude!` primitive, consulted in
|
||||||
|
`jit_compile_lambda` so it covers BOTH JIT entry points (CEK hook + in-VM
|
||||||
|
tiered path). `lib/smalltalk/eval.sx` self-declares its continuation-using
|
||||||
|
dispatch core interpret-only; pure helpers (parsing, lookup, formatting,
|
||||||
|
arithmetic) still JIT.* One SUnit suite-runner test helper
|
||||||
|
(`pharo-test-class`) miscompiles under JIT on a specific iteration and is
|
||||||
|
excluded in the test prelude (`tests/tokenize.sx`).
|
||||||
|
|
||||||
|
### Known residual / follow-up
|
||||||
|
- The hook still **re-runs a failed VM execution via CEK** (always yields the
|
||||||
|
correct result, but can duplicate side effects if a JIT'd function fails
|
||||||
|
mid-run after a side effect). `run_tests`'s hook instead propagates non-IO /
|
||||||
|
non-"VM undefined" exceptions. Adopting that propagate-don't-rerun semantics
|
||||||
|
in the serving hook would remove the double-execution class entirely, but it
|
||||||
|
surfaces genuine mid-run miscompiles as errors — so it must land together
|
||||||
|
with fixing/excluding any function that miscompiles mid-run (e.g.
|
||||||
|
`pharo-test-class`). Deferred to avoid changing shared VM/CEK semantics under
|
||||||
|
this loop.
|
||||||
|
- Other continuation-heavy guests (Scheme, Erlang use `call/cc`) will need
|
||||||
|
their own `jit-exclude!` declarations for their dispatch cores; the mechanism
|
||||||
|
is in place. Non-continuation guests (Datalog/Prolog/Haskell/APL) JIT as-is.
|
||||||
|
- A debug aid was added to the serving hook: `SX_JIT_DENY=name,...` /
|
||||||
|
`SX_JIT_ONLY=name,...` env vars to bisect which named lambda the VM
|
||||||
|
mishandles (hook-path only).
|
||||||
|
|
||||||
|
---
|
||||||
|
|
||||||
|
## Guest-loop regression sweep + safe-default gate (2026-06-19, follow-up)
|
||||||
|
|
||||||
|
Host-loop verification found that enabling serving-mode JIT **globally**
|
||||||
|
regresses continuation-based guest interpreters (the epoch serving mode is the
|
||||||
|
shared command channel for every loop's conformance runner). Failure modes:
|
||||||
|
- **VmClosure not callable** — a JIT'd higher-order function returns its inner
|
||||||
|
closure as a `VmClosure`; the native `callable?` predicate didn't list
|
||||||
|
`VmClosure`, so `scheme-apply`'s `(callable? proc)` guard rejected it
|
||||||
|
("scheme-eval: not a procedure: <vm:anon>"). FIXED generally: `callable?`
|
||||||
|
(all 4 bindings) now accepts `VmClosure`.
|
||||||
|
- **Continuation escape** — Scheme `call/cc`, Erlang receive, CL conditions,
|
||||||
|
JS exceptions: a JIT'd frame can't transfer control through a CEK
|
||||||
|
continuation.
|
||||||
|
- **Non-terminating miscompile (HANG)** — Erlang/Prolog/Haskell recursive
|
||||||
|
evaluators miscompiled into an infinite loop (worse than an error: can't
|
||||||
|
fall back).
|
||||||
|
|
||||||
|
### Mechanism
|
||||||
|
- `jit-exclude!` now accepts a trailing `*` wildcard → namespace-prefix
|
||||||
|
exclusion (`Sx_types.jit_excluded_prefixes`, checked in
|
||||||
|
`jit_compile_lambda` for both JIT entry points). One declaration per guest,
|
||||||
|
robust vs name-lists (which missed e.g. the erlang `vm/dispatcher`).
|
||||||
|
|
||||||
|
### Per-guest exclusions added (in each guest's runtime, loaded with it)
|
||||||
|
| Guest | Declaration | Status under opt-in JIT |
|
||||||
|
|-------|-------------|--------------------------|
|
||||||
|
| smalltalk | name-list (dispatch core) + `pharo-test-class` | 847/847 == CEK |
|
||||||
|
| scheme | `(jit-exclude! "scheme-*" "scm-*")` | flow 166/166 == CEK |
|
||||||
|
| erlang | `(jit-exclude! "er-*" "erlang-*")` | 530/530 == CEK, no hang |
|
||||||
|
| prolog | `(jit-exclude! "pl-*")` | 590/590 == CEK |
|
||||||
|
| common-lisp | `(jit-exclude! "cl-*" "clos-*")` | residual: 6 fail (advanced suites) |
|
||||||
|
| js | `(jit-exclude! "js-*")` | (verifying) |
|
||||||
|
| haskell | `(jit-exclude! "hk-*")` | (verifying) |
|
||||||
|
|
||||||
|
Not JIT-related (fail identically on CEK and JIT, pre-existing): lua 0/16,
|
||||||
|
tcl 3/4. apl/datalog/forth/ocaml: clean under JIT as-is (no continuations).
|
||||||
|
|
||||||
|
### Safe-default gate
|
||||||
|
Serving-mode JIT is now **opt-in via `SX_SERVING_JIT=1` (default OFF)** in
|
||||||
|
`sx_server.ml`. Default behavior is unchanged (no JIT in epoch serving) ⇒
|
||||||
|
**zero regression** for every sibling loop's conformance. The content/Smalltalk
|
||||||
|
page server opts in. This bounds risk: guests are validated and excluded
|
||||||
|
incrementally; until then the default protects them. Common-Lisp's advanced
|
||||||
|
suites still need investigation before CL is opt-in-clean.
|
||||||
|
|
||||||
|
---
|
||||||
|
|
||||||
|
## guard / handler-bind under JIT — central recursive PUSH_HANDLER scan (2026-06-20)
|
||||||
|
|
||||||
|
Combined-binary integration (my JIT + host render-page) surfaced a third
|
||||||
|
JIT-unsafe class beyond guest dispatch cores: **`guard`-based error handling**.
|
||||||
|
The VM's `OP_PUSH_HANDLER` (compiled `guard`) only intercepts a VM-level
|
||||||
|
`RAISE` (opcode 37) — it does NOT catch the OCaml `Eval_error` the `error`
|
||||||
|
primitive throws from a CALL/CALL_PRIM in a callee frame. So a JIT-compiled
|
||||||
|
`guard` silently fails to catch; the thrown error escapes across the JIT frame.
|
||||||
|
|
||||||
|
- SOLID break: `host/wrap-errors -> dream-catch-with` (curried:
|
||||||
|
`(fn (on-error) (fn (next) (fn (req) (guard ...))))`) — middleware suite
|
||||||
|
7/9 under JIT (9/9 CEK), "kaboom" escaped as Unhandled exception, NOT
|
||||||
|
fallback-saved (the guard is in an outer frame, the throw in an inner one).
|
||||||
|
- LATENT (turned out harmless): `host/blog--render-node`'s `guard` — it JIT-
|
||||||
|
failed then the hook RE-RAN it on CEK where the guard caught (pure render, no
|
||||||
|
duplicated effects). This is the double-execution residual firing live.
|
||||||
|
|
||||||
|
Fix: `code_uses_handler` scans a JIT candidate's bytecode **recursively**
|
||||||
|
(including nested closure code in the constant pool) for `OP_PUSH_HANDLER`;
|
||||||
|
`jit_compile_lambda` skips JIT for any match. The recursion is essential —
|
||||||
|
curried `dream-catch-with` has no PUSH_HANDLER in its own body; the guard is in
|
||||||
|
a nested `OP_CLOSURE`. Verified: direct + curried cross-frame guards catch
|
||||||
|
under JIT; host "kaboom" escapes 2 -> 0.
|
||||||
|
|
||||||
|
### Remaining (documented, gated): the double-execution residual
|
||||||
|
The serving hook still re-runs a failed VM execution via CEK (correct result,
|
||||||
|
duplicated side effects if the function is impure and fails mid-run). The guard
|
||||||
|
fix removes the common trigger (guard functions no longer JIT). The clean
|
||||||
|
general fix is propagate-don't-rerun (run_tests' hook semantics) but that
|
||||||
|
surfaces genuine mid-run miscompiles as errors and must land with fixing/
|
||||||
|
excluding those — deferred (shared CEK/VM change). The default-OFF gate makes
|
||||||
|
all of this opt-in, so nothing regresses by default.
|
||||||
|
|
||||||
|
---
|
||||||
|
|
||||||
|
## common-lisp residual resolved — call/cc-caller exclusion (2026-06-28)
|
||||||
|
|
||||||
|
Investigated the 6 CL opt-in-JIT failures. Findings:
|
||||||
|
- **geometry / mop-trace (0/0) are NOT JIT regressions** — they error "Undefined
|
||||||
|
symbol: refl-class-chain-depth-with" on BOTH CEK and JIT (the CLOS suites in
|
||||||
|
conformance.sh don't preload lib/guest/reflective/class-chain.sx). Pre-existing
|
||||||
|
harness gap; not counted in the 6.
|
||||||
|
- The **6 real failures** (parse-recover 4, interactive-debugger 2) were all
|
||||||
|
condition-system continuation escape. cl-restart-case/cl-handler-case/
|
||||||
|
cl-handler-bind wrap their body in call/cc. When an SX function driving the
|
||||||
|
condition system (parse-numbers, make-policy-debugger) is JIT-compiled, the
|
||||||
|
call/cc form runs in a NESTED cek-run where invoking the captured continuation
|
||||||
|
runs-to-completion-and-returns instead of escaping → restart fails to abort,
|
||||||
|
body falls through. Seen as accumulation ((1 3 0 3) vs (1 3)) and no-abort
|
||||||
|
(999 sentinel). Also produced a +3 double-execution over-count (490 vs 487).
|
||||||
|
|
||||||
|
Fix: a third interpret-only signal beyond name/prefix and PUSH_HANDLER —
|
||||||
|
`jit-exclude-callers-of!` registers call/cc-establishing/invoking form names;
|
||||||
|
`jit_compile_lambda` skips any function whose constant pool (recursively)
|
||||||
|
references one (`code_refs_escaping_caller`). Guarded so it's a no-op for guests
|
||||||
|
that don't register. CL registers cl-restart-case/cl-handler-case/cl-handler-bind
|
||||||
|
(establish) + cl-invoke-restart/cl-invoke-debugger/cl-signal/cl-error-with-debugger
|
||||||
|
(invoke). Result: **CL under SX_SERVING_JIT=1 = 487/0, exactly matching CEK.**
|
||||||
|
|
||||||
|
The three interpret-only signals now: (1) name / "ns-*" prefix [jit-exclude!],
|
||||||
|
(2) PUSH_HANDLER in bytecode [guard users, structural], (3) references a
|
||||||
|
registered escaping form [call/cc-establishing callers]. Together they cover the
|
||||||
|
continuation-unsafe surface without a deep VM continuation rewrite.
|
||||||
Reference in New Issue
Block a user