diff --git a/hosts/ocaml/lib/sx_primitives.ml b/hosts/ocaml/lib/sx_primitives.ml index 39a65874..d4c2295d 100644 --- a/hosts/ocaml/lib/sx_primitives.ml +++ b/hosts/ocaml/lib/sx_primitives.ml @@ -4175,6 +4175,16 @@ let () = 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; diff --git a/hosts/ocaml/lib/sx_types.ml b/hosts/ocaml/lib/sx_types.ml index 599232ba..91416918 100644 --- a/hosts/ocaml/lib/sx_types.ml +++ b/hosts/ocaml/lib/sx_types.ml @@ -502,6 +502,20 @@ let jit_name_excluded name = 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. diff --git a/hosts/ocaml/lib/sx_vm.ml b/hosts/ocaml/lib/sx_vm.ml index f15ba252..3ba4529e 100644 --- a/hosts/ocaml/lib/sx_vm.ml +++ b/hosts/ocaml/lib/sx_vm.ml @@ -1156,6 +1156,22 @@ let rec code_uses_handler code = (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 -> "" in if !_jit_compiling then ( @@ -1241,6 +1257,13 @@ let jit_compile_lambda (l : lambda) globals = 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 } diff --git a/lib/common-lisp/runtime.sx b/lib/common-lisp/runtime.sx index 9656c3ef..136a4df4 100644 --- a/lib/common-lisp/runtime.sx +++ b/lib/common-lisp/runtime.sx @@ -764,3 +764,17 @@ ;; 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")