merge

Author: TheNumbat

.github/workflows/build.yml

@@ -114,7 +114,7 @@ jobs:
       # run: HOMEBREW_NO_INSTALL_CLEANUP=TRUE brew install afl-fuzz
 
     - name: Cache OCaml 4.14, dune and menhir
-      uses: actions/cache@v2
+      uses: actions/cache@v4
       id: cache
       with:
         path: ${{ github.workspace }}/ocaml-414/_install

HACKING.md

@@ -96,10 +96,7 @@ To rebuild after making changes, you can just type `make`. You need to
 have a working OCaml 4.14 or 4.14.1 compiler on your PATH before doing so,
 e.g. installed via OPAM. You also need to have dune and menhir.
 
-<!-- CR someone: investigate this -->
-The build currently fails when using the latest version of `dune` (3.11.1).
-To install a known-good dune, run `opam pin add dune 3.8.1`. `menhir` should be pinned to a specific
-version as well: `opam pin add menhir 20210419`.
+`menhir` should be pinned to a specific version: `opam pin add menhir 20210419`.
 
 There is a special target `make hacking` which starts Dune in polling mode.  The rebuild
 performed here is equivalent to `make ocamlopt` in the upstream distribution: it rebuilds the

backend/amd64/emit.mlp

@@ -474,31 +474,44 @@ let emit_call_safety_errors () =
 type stack_realloc = {
   sc_label : Label.t; (* Label of the reallocation code. *)
   sc_return : Label.t; (* Label to return to after reallocation. *)
-  sc_max_frame_size_in_bytes : int; (* Size for reallocation. *)
+  sc_size_in_bytes : int; (* Size for reallocation. *)
 }
 
-let stack_realloc = ref (None : stack_realloc option)
+let stack_realloc = ref ([] : stack_realloc list)
 
 let clear_stack_realloc () =
-  stack_realloc := None
+  stack_realloc := []
 
 let emit_stack_realloc () =
-  begin match !stack_realloc with
-  | None -> ()
-  | Some { sc_label; sc_return; sc_max_frame_size_in_bytes; } -> begin
-      def_label sc_label;
-      (* Pass the desired frame size on the stack, since all of the
-         argument-passing registers may be in use.
-         Also serves to align the stack properly before the call *)
-      I.push (int (Config.stack_threshold + sc_max_frame_size_in_bytes / 8));
-      cfi_adjust_cfa_offset 8;
-      (* measured in words *)
-      emit_call (Cmm.global_symbol "caml_call_realloc_stack");
-      I.add (int 8) rsp;
-      cfi_adjust_cfa_offset (-8);
-      I.jmp (label sc_return)
-    end
-  end
+  List.iter
+    (fun { sc_label; sc_return; sc_size_in_bytes; } ->
+       def_label sc_label;
+       (* Pass the desired frame size on the stack, since all of the
+          argument-passing registers may be in use.
+          Also serves to align the stack properly before the call *)
+       I.push (int (Config.stack_threshold + sc_size_in_bytes / 8));
+       cfi_adjust_cfa_offset 8;
+       (* measured in words *)
+       emit_call (Cmm.global_symbol "caml_call_realloc_stack");
+       I.add (int 8) rsp;
+       cfi_adjust_cfa_offset (-8);
+       I.jmp (label sc_return))
+    !stack_realloc
+
+let emit_stack_check ~size_in_bytes ~save_registers =
+  let overflow = new_label () and ret = new_label () in
+  let threshold_offset = Domainstate.stack_ctx_words * 8 + Stack_check.stack_threshold_size in
+  if save_registers then I.push r10;
+  I.lea (mem64 NONE (-(size_in_bytes + threshold_offset)) RSP) r10;
+  I.cmp (domain_field Domainstate.Domain_current_stack) r10;
+  if save_registers then I.pop r10;
+  I.jb (label overflow);
+  def_label ret;
+  stack_realloc := {
+    sc_label = overflow;
+    sc_return = ret;
+    sc_size_in_bytes = size_in_bytes;
+  } :: !stack_realloc
 
 (* Record jump tables *)
 type jump_table =
@@ -1856,20 +1869,7 @@ let emit_instr ~first ~fallthrough i =
           I.jmp r11
     end
   | Lstackcheck { max_frame_size_bytes; } ->
-    let save_registers = not first in
-    let overflow = new_label () and ret = new_label () in
-    let threshold_offset = Domainstate.stack_ctx_words * 8 + Stack_check.stack_threshold_size in
-    if save_registers then I.push r10;
-    I.lea (mem64 NONE (-(max_frame_size_bytes + threshold_offset)) RSP) r10;
-    I.cmp (domain_field Domainstate.Domain_current_stack) r10;
-    if save_registers then I.pop r10;
-    I.jb (label overflow);
-    def_label ret;
-    stack_realloc := Some {
-      sc_label = overflow;
-      sc_return = ret;
-      sc_max_frame_size_in_bytes = max_frame_size_bytes;
-    }
+    emit_stack_check ~size_in_bytes:max_frame_size_bytes ~save_registers:(not first)
 
 let rec emit_all ~first ~fallthrough i =
   match i.desc with
@@ -1933,7 +1933,7 @@ let fundecl fundecl =
   D.label (label_name (emit_symbol fundecl.fun_name));
   emit_debug_info fundecl.fun_dbg;
   cfi_startproc ();
-  if Config.runtime5 && !Clflags.runtime_variant = "d" then begin
+  if Config.runtime5 && (not Config.no_stack_checks) && !Clflags.runtime_variant = "d" then begin
     emit_call (Cmm.global_symbol "caml_assert_stack_invariants");
   end;
   emit_all ~first:true ~fallthrough:true fundecl.fun_body;
@@ -2199,6 +2199,8 @@ let emit_probe_handler_wrapper p =
   let padding = if ((wrapper_frame_size k) mod 16) = 0 then 0 else 8 in
   let n = k + padding in
   (* Allocate stack space *)
+  if Config.runtime5 && (not Config.no_stack_checks) && (n >= Stack_check.stack_threshold_size) then
+    emit_stack_check ~size_in_bytes:n ~save_registers:true;
   emit_stack_offset n;
   (* Save all live hard registers *)
   let offset = aux_offset + tmp_offset + loc_offset in

backend/cfg/cfg_dominators.ml

@@ -8,8 +8,7 @@ module List = ListLabels
 
 let fatal = Misc.fatal_errorf
 
-(* CR-soon xclerc for xclerc: switch back to `false`. *)
-let debug = true
+let debug = false
 
 type doms = Label.t Label.Tbl.t
 

backend/cfg/cfg_stack_checks.ml

@@ -217,11 +217,13 @@ let cfg (cfg_with_layout : Cfg_with_layout.t) =
   | false -> cfg_with_layout
   | true ->
     let cfg = Cfg_with_layout.cfg cfg_with_layout in
-    let { max_frame_size; blocks_needing_stack_checks; max_instr_id } =
-      build_cfg_info cfg
-    in
-    if not (Label.Set.is_empty blocks_needing_stack_checks)
+    (if not Config.no_stack_checks
     then
-      insert_stack_checks cfg ~max_frame_size ~blocks_needing_stack_checks
-        ~max_instr_id;
+      let { max_frame_size; blocks_needing_stack_checks; max_instr_id } =
+        build_cfg_info cfg
+      in
+      if not (Label.Set.is_empty blocks_needing_stack_checks)
+      then
+        insert_stack_checks cfg ~max_frame_size ~blocks_needing_stack_checks
+          ~max_instr_id);
     cfg_with_layout