Long frames in frametable

backend/emitaux.ml

@@ -17,6 +17,7 @@
 
 type error =
   | Stack_frame_too_large of int
+  | Stack_frame_way_too_large of int
 
 exception Error of error
 
@@ -119,16 +120,48 @@ type frame_descr =
   { fd_lbl: int;                        (* Return address *)
     fd_frame_size: int;                 (* Size of stack frame *)
     fd_live_offset: int list;           (* Offsets/regs of live addresses *)
-    fd_debuginfo: frame_debuginfo }     (* Location, if any *)
+    fd_debuginfo: frame_debuginfo;      (* Location, if any *)
+    fd_long: bool;                      (* Use 32 instead of 16 bit format. *)
+  }
 
 let frame_descriptors = ref([] : frame_descr list)
 
+let get_flags debuginfo =
+  match debuginfo with
+  | Dbg_other d | Dbg_raise d ->
+    if Debuginfo.is_none d then 0 else 1
+  | Dbg_alloc dbgs ->
+    if !Clflags.debug &&
+       List.exists (fun d ->
+         not (Debuginfo.is_none d.Debuginfo.alloc_dbg)) dbgs
+    then 3 else 2
+
+let is_long n =
+  assert (n >= 0);
+  (* Long frames must fit in 32-bit integer and
+     not truncated upon conversion from int on any target. *)
+  if n > 0x3FFF_FFFF then
+    raise (Error(Stack_frame_way_too_large n));
+  n >= !Flambda_backend_flags.long_frames_threshold
+
 let record_frame_descr ~label ~frame_size ~live_offset debuginfo =
-  frame_descriptors :=
-    { fd_lbl = label;
+  assert (frame_size land 3 = 0);
+  let fd_long =
+    is_long (frame_size + get_flags debuginfo) ||
+    (* The checks below are redundant
+       (if they fail, then frame size check above should have failed),
+       but they make the safety of [emit_frame] clear. *)
+    is_long (List.length live_offset) ||
+    (List.exists is_long live_offset)
+  in
+  if fd_long && not !Flambda_backend_flags.allow_long_frames then
+    raise (Error(Stack_frame_too_large frame_size));
+  frame_descriptors :=     { fd_lbl = label;
       fd_frame_size = frame_size;
       fd_live_offset = List.sort_uniq (-) live_offset;
-      fd_debuginfo = debuginfo } :: !frame_descriptors
+      fd_debuginfo = debuginfo;
+      fd_long;
+    } :: !frame_descriptors
 
 type emit_frame_actions =
   { efa_code_label: int -> unit;
@@ -183,28 +216,22 @@ let emit_frames a =
       Label_table.add debuginfos key lbl;
       lbl
   in
-  let efa_16_checked n =
-    assert (n >= 0);
-    if n < 0x1_0000
-    then a.efa_16 n
-    else raise (Error(Stack_frame_too_large n))
-  in
+  let emit_32 n = n |> Int32.of_int |> a.efa_32 in
   let emit_frame fd =
-    assert (fd.fd_frame_size land 3 = 0);
-    let flags =
-      match fd.fd_debuginfo with
-      | Dbg_other d | Dbg_raise d ->
-        if Debuginfo.is_none d then 0 else 1
-      | Dbg_alloc dbgs ->
-        if !Clflags.debug &&
-           List.exists (fun d ->
-             not (Debuginfo.is_none d.Debuginfo.alloc_dbg)) dbgs
-        then 3 else 2
-    in
+    let flags = get_flags fd.fd_debuginfo in
     a.efa_code_label fd.fd_lbl;
-    efa_16_checked (fd.fd_frame_size + flags);
-    efa_16_checked (List.length fd.fd_live_offset);
-    List.iter efa_16_checked fd.fd_live_offset;
+    (* For short format, the size is guaranteed
+       to be less than the constant below. *)
+    if fd.fd_long then begin
+      a.efa_16 Flambda_backend_flags.max_long_frames_threshold;
+      a.efa_align 4;
+    end;
+    let emit_16_or_32 =
+      if fd.fd_long then emit_32 else a.efa_16
+    in
+    emit_16_or_32 (fd.fd_frame_size + flags);
+    emit_16_or_32 (List.length fd.fd_live_offset);
+    List.iter emit_16_or_32 fd.fd_live_offset;
     begin match fd.fd_debuginfo with
     | _ when flags = 0 ->
       ()
@@ -407,5 +434,7 @@ let reduce_heap_size ~reset =
 
 let report_error ppf = function
   | Stack_frame_too_large n ->
-      Format.fprintf ppf "stack frame too large (%d bytes)" n
-
+    Format.fprintf ppf "stack frame too large (%d bytes). \n\
+                        Use -long-frames compiler flag." n
+  | Stack_frame_way_too_large n ->
+    Format.fprintf ppf "stack frame too large (%d bytes)." n

backend/emitaux.mli

@@ -105,6 +105,7 @@ val reduce_heap_size : reset:(unit -> unit) -> unit
 
 type error =
   | Stack_frame_too_large of int
+  | Stack_frame_way_too_large of int
 
 exception Error of error
 val report_error: Format.formatter -> error -> unit

driver/flambda_backend_args.ml

@@ -62,6 +62,15 @@ let mk_dcheckmach f =
 let mk_disable_poll_insertion f =
   "-disable-poll-insertion", Arg.Unit f, " Do not insert poll points"
 
+let mk_long_frames f =
+  "-long-frames", Arg.Unit f, " Allow stack frames longer than 2^16 bytes"
+
+let mk_no_long_frames f =
+  "-no-long-frames", Arg.Unit f, " Do not allow stack frames longer than 2^16 bytes"
+
+let mk_debug_long_frames_threshold f =
+  "-debug-long-frames-threshold", Arg.Int f, "n debug only: set long frames threshold"
+
 let mk_dump_inlining_paths f =
   "-dump-inlining-paths", Arg.Unit f, " Dump inlining paths when dumping flambda2 terms"
 
@@ -418,6 +427,17 @@ let mk_no_dwarf_for_startup_file f =
   "-gno-startup", Arg.Unit f, " Emit the same DWARF information for the\n\
     \     startup file as the upstream compiler"
 
+let set_long_frames_threshold n =
+  if n < 0 then
+    raise (Arg.Bad "Long frames threshold must be non-negative.");
+  if n > Flambda_backend_flags.max_long_frames_threshold then
+    raise
+      (Arg.Bad
+         (Printf.sprintf "Long frames threshold too big: 0x%x, \
+                          must be less or equal to 0x%x" n
+            Flambda_backend_flags.max_long_frames_threshold));
+  Flambda_backend_flags.long_frames_threshold := n
+
 module type Flambda_backend_options = sig
   val ocamlcfg : unit -> unit
   val no_ocamlcfg : unit -> unit
@@ -436,6 +456,11 @@ module type Flambda_backend_options = sig
   val dcheckmach : unit -> unit
 
   val disable_poll_insertion : unit -> unit
+
+  val long_frames : unit -> unit
+  val no_long_frames : unit -> unit
+  val long_frames_threshold : int -> unit
+
   val internal_assembler : unit -> unit
 
   val flambda2_join_points : unit -> unit
@@ -510,6 +535,10 @@ struct
 
     mk_disable_poll_insertion F.disable_poll_insertion;
 
+    mk_long_frames F.long_frames;
+    mk_no_long_frames F.no_long_frames;
+    mk_debug_long_frames_threshold F.long_frames_threshold;
+
     mk_internal_assembler F.internal_assembler;
 
     mk_flambda2_join_points F.flambda2_join_points;
@@ -619,6 +648,10 @@ module Flambda_backend_options_impl = struct
 
   let disable_poll_insertion = set' Flambda_backend_flags.disable_poll_insertion
 
+  let long_frames =  set' Flambda_backend_flags.allow_long_frames
+  let no_long_frames = clear' Flambda_backend_flags.allow_long_frames
+  let long_frames_threshold n = set_long_frames_threshold n
+
   let internal_assembler = set' Flambda_backend_flags.internal_assembler
 
   let flambda2_join_points = set Flambda2.join_points
@@ -817,6 +850,16 @@ module Extra_params = struct
     | "alloc-check" -> set' Flambda_backend_flags.alloc_check
     | "dump-checkmach" -> set' Flambda_backend_flags.dump_checkmach
     | "disable-poll-insertion" -> set' Flambda_backend_flags.disable_poll_insertion
+    | "long-frames" -> set' Flambda_backend_flags.allow_long_frames
+    | "debug-long-frames-threshold" ->
+      begin match Compenv.check_int ppf name v with
+      | Some n -> set_long_frames_threshold n; true
+      | None ->
+        raise
+          (Arg.Bad
+             (Printf.sprintf "Expected integer between 0 and %d"
+                Flambda_backend_flags.max_long_frames_threshold))
+      end
     | "dasm-comments" -> set' Flambda_backend_flags.dasm_comments
     | "dno-asm-comments" -> clear' Flambda_backend_flags.dasm_comments
     | "gupstream-dwarf" -> set' Debugging.restrict_to_upstream_dwarf

driver/flambda_backend_args.mli

@@ -37,6 +37,9 @@ module type Flambda_backend_options = sig
   val dcheckmach : unit -> unit
 
   val disable_poll_insertion : unit -> unit
+  val long_frames : unit -> unit
+  val no_long_frames : unit -> unit
+  val long_frames_threshold : int -> unit
 
   val internal_assembler : unit -> unit
 

driver/flambda_backend_flags.ml

@@ -28,6 +28,12 @@ let alloc_check = ref false             (* -alloc-check *)
 let dump_checkmach = ref false          (* -dcheckmach *)
 
 let disable_poll_insertion = ref false  (* -disable-poll-insertion *)
+let allow_long_frames = ref true        (* -no-long-frames *)
+(* Keep the value of [max_long_frames_threshold] in sync with LONG_FRAME_MARKER
+   in ocaml/runtime/roots_nat.c *)
+let max_long_frames_threshold = 0x7FFF
+let long_frames_threshold = ref max_long_frames_threshold (* -debug-long-frames-threshold n *)
+
 type function_result_types = Never | Functors_only | All_functions
 type opt_level = Oclassic | O2 | O3
 type 'a or_default = Set of 'a | Default

driver/flambda_backend_flags.mli

@@ -29,6 +29,9 @@ val alloc_check : bool ref
 val dump_checkmach : bool ref
 
 val disable_poll_insertion : bool ref
+val allow_long_frames : bool ref
+val max_long_frames_threshold : int
+val long_frames_threshold : int ref
 
 type function_result_types = Never | Functors_only | All_functions
 type opt_level = Oclassic | O2 | O3

dune-project

@@ -16,3 +16,4 @@
 (package
   (name ocaml_runtime_stdlib)
 )
+

ocaml/runtime/backtrace_nat.c

@@ -47,7 +47,7 @@ frame_descr * caml_next_frame_descriptor(uintnat * pc, char ** sp)
     /* Skip to next frame */
     if (d->frame_size != 0xFFFF) {
       /* Regular frame, update sp/pc and return the frame descriptor */
-      *sp += (d->frame_size & 0xFFFC);
+      *sp += (get_frame_size(d) & 0xFFFFFFFC);
       *pc = Saved_return_address(*sp);
 #ifdef Mask_already_scanned
       *pc = Mask_already_scanned(*pc);
@@ -164,17 +164,19 @@ static debuginfo debuginfo_extract(frame_descr* d, int alloc_idx)
 {
   unsigned char* infoptr;
   uint32_t debuginfo_offset;
+  uint32_t frame_size;
 
   /* The special frames marking the top of an ML stack chunk are never
      returned by caml_next_frame_descriptor, so should never reach here. */
-  CAMLassert(d->frame_size != 0xffff);
+  CAMLassert(d->frame_size != 0xFFFF);
+  frame_size = get_frame_size(d);
 
-  if ((d->frame_size & 1) == 0) {
+  if ((frame_size & 1) == 0) {
     return NULL;
   }
   /* Recover debugging info */
-  infoptr = (unsigned char*)&d->live_ofs[d->num_live];
-  if (d->frame_size & 2) {
+  infoptr = get_end_of_live_ofs(d);
+  if (frame_size & 2) {
     CAMLassert(alloc_idx == -1 || (0 <= alloc_idx && alloc_idx < *infoptr));
     /* skip alloc_lengths */
     infoptr += *infoptr + 1;

ocaml/runtime/caml/stack.h

@@ -86,7 +86,6 @@ struct caml_context {
 };
 
 /* Structure of frame descriptors */
-
 typedef struct {
   uintnat retaddr;
   unsigned short frame_size;
@@ -104,6 +103,29 @@ typedef struct {
     num_debug is num_alloc if frame_size & 2, otherwise 1. */
 } frame_descr;
 
+typedef struct {
+  uintnat retaddr;
+  unsigned short marker;        /* LONG_FRAME_MARKER */
+  unsigned short _pad;  /* Ensure frame_size is 4-byte aligned */
+  uint32_t frame_size;
+  uint32_t num_live;
+  uint32_t live_ofs[1 /* num_live */];
+  /*
+    If frame_size & 2, then allocation info follows:
+  unsigned char num_allocs;
+  unsigned char alloc_lengths[num_alloc];
+
+    If frame_size & 1, then debug info follows:
+  uint32_t debug_info_offset[num_debug];
+
+    Debug info is stored as relative offsets to debuginfo structures.
+    num_debug is num_alloc if frame_size & 2, otherwise 1. */
+} frame_descr_long;
+
+/* Helpers for long frames */
+uint32_t get_frame_size(frame_descr *);
+unsigned char * get_end_of_live_ofs (frame_descr *d);
+
 /* Allocation lengths are encoded as 0-255, giving sizes 1-256 */
 #define Wosize_encoded_alloc_len(n) ((uintnat)(n) + 1)