Check that stack frames are not too large (port upstream PR#10085)

backend/asmgen.ml

@@ -26,6 +26,7 @@ open Cmm
 type error =
   | Assembler_error of string
   | Mismatched_for_pack of string option
+  | Asm_generation of string * Emitaux.error
 
 exception Error of error
 
@@ -129,9 +130,13 @@ let if_emit_do f x = if should_emit () then f x else ()
 let emit_begin_assembly = if_emit_do Emit.begin_assembly
 let emit_end_assembly = if_emit_do Emit.end_assembly
 let emit_data = if_emit_do Emit.data
-let emit_fundecl =
-  if_emit_do
-    (Profile.record ~accumulate:true "emit" Emit.fundecl)
+let emit_fundecl fd =
+  if should_emit() then begin
+    try
+      Profile.record ~accumulate:true "emit" Emit.fundecl fd
+    with Emitaux.Error e ->
+      raise (Error (Asm_generation(fd.Linear.fun_name, e)))
+  end
 
 let rec regalloc ~ppf_dump round fd =
   if round > 50 then
@@ -407,6 +412,10 @@ let report_error ppf = function
      fprintf ppf
        "This input file cannot be compiled %s: it was generated %s."
        (msg !Clflags.for_package) (msg saved)
+  | Asm_generation(fn, err) ->
+     fprintf ppf
+       "Error producing assembly code for function %s: %a"
+       fn Emitaux.report_error err
 
 let () =
   Location.register_error_of_exn

backend/asmgen.mli

@@ -69,6 +69,7 @@ val compile_phrase :
 type error =
   | Assembler_error of string
   | Mismatched_for_pack of string option
+  | Asm_generation of string * Emitaux.error
 
 exception Error of error
 val report_error: Format.formatter -> error -> unit

backend/emitaux.ml

@@ -15,6 +15,11 @@
 
 (* Common functions for emitting assembly code *)
 
+type error =
+  | Stack_frame_too_large of int
+
+exception Error of error
+
 let output_channel = ref stdout
 
 let emit_string s = output_string !output_channel s
@@ -178,6 +183,12 @@ 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_frame fd =
     assert (fd.fd_frame_size land 3 = 0);
     let flags =
@@ -191,9 +202,9 @@ let emit_frames a =
         then 3 else 2
     in
     a.efa_code_label fd.fd_lbl;
-    a.efa_16 (fd.fd_frame_size + flags);
-    a.efa_16 (List.length fd.fd_live_offset);
-    List.iter a.efa_16 fd.fd_live_offset;
+    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;
     begin match fd.fd_debuginfo with
     | _ when flags = 0 ->
       ()
@@ -378,7 +389,7 @@ let create_asm_file = ref true
 
 let reduce_heap_size ~reset =
   let _minor, _promoted, major_words = Gc.counters () in
-  (* Uses [major_words] because it doesn't require a heap traversal to compute and 
+  (* Uses [major_words] because it doesn't require a heap traversal to compute and
      for this workload a majority of major words are live at this point. *)
   let heap_reduction_threshold =
     if !Flambda_backend_flags.heap_reduction_threshold >= 0 then
@@ -391,3 +402,8 @@ let reduce_heap_size ~reset =
       reset ();
       Gc.compact ())
   end
+
+let report_error ppf = function
+  | Stack_frame_too_large n ->
+      Format.fprintf ppf "stack frame too large (%d bytes)" n
+

backend/emitaux.mli

@@ -73,7 +73,6 @@ val cfi_endproc : unit -> unit
 val cfi_adjust_cfa_offset : int -> unit
 val cfi_offset : reg:int -> offset:int -> unit
 
-
 val binary_backend_available: bool ref
     (** Is a binary backend available.  If yes, we don't need
         to generate the textual assembly file (unless the user
@@ -82,6 +81,7 @@ val binary_backend_available: bool ref
 val create_asm_file: bool ref
     (** Are we actually generating the textual assembly file? *)
 
+
 (** Clear global state and compact the heap, so that an external program
     (such as the assembler or linker) may have more memory available to it.
 
@@ -96,3 +96,10 @@ val create_asm_file: bool ref
     state, since the fewer live words there are after GC, the smaller the new
     heap can be. *)
 val reduce_heap_size : reset:(unit -> unit) -> unit
+
+type error =
+  | Stack_frame_too_large of int
+
+exception Error of error
+val report_error: Format.formatter -> error -> unit
+

ocaml/.depend

@@ -2120,6 +2120,7 @@ asmcomp/asmgen.cmo : \
     asmcomp/linscan.cmi \
     asmcomp/linearize.cmi \
     file_formats/linear_format.cmi \
+    asmcomp/linear.cmi \
     lambda/lambda.cmi \
     asmcomp/interval.cmi \
     asmcomp/interf.cmi \
@@ -2162,6 +2163,7 @@ asmcomp/asmgen.cmx : \
     asmcomp/linscan.cmx \
     asmcomp/linearize.cmx \
     file_formats/linear_format.cmx \
+    asmcomp/linear.cmx \
     lambda/lambda.cmx \
     asmcomp/interval.cmx \
     asmcomp/interf.cmx \
@@ -2185,6 +2187,7 @@ asmcomp/asmgen.cmx : \
     asmcomp/asmgen.cmi
 asmcomp/asmgen.cmi : \
     lambda/lambda.cmi \
+    asmcomp/emitaux.cmi \
     asmcomp/cmm.cmi \
     middle_end/clambda.cmi \
     middle_end/backend_intf.cmi

ocaml/asmcomp/asmgen.ml

@@ -26,6 +26,7 @@ open Cmm
 type error =
   | Assembler_error of string
   | Mismatched_for_pack of string option
+  | Asm_generation of string * Emitaux.error
 
 exception Error of error
 
@@ -96,9 +97,13 @@ let if_emit_do f x = if should_emit () then f x else ()
 let emit_begin_assembly = if_emit_do Emit.begin_assembly
 let emit_end_assembly = if_emit_do Emit.end_assembly
 let emit_data = if_emit_do Emit.data
-let emit_fundecl =
-  if_emit_do
-    (Profile.record ~accumulate:true "emit" Emit.fundecl)
+let emit_fundecl fd =
+  if should_emit() then begin
+    try
+      Profile.record ~accumulate:true "emit" Emit.fundecl fd
+    with Emitaux.Error e ->
+      raise (Error (Asm_generation(fd.Linear.fun_name, e)))
+  end
 
 let rec regalloc ~ppf_dump round fd =
   if round > 50 then
@@ -290,6 +295,10 @@ let report_error ppf = function
      fprintf ppf
        "This input file cannot be compiled %s: it was generated %s."
        (msg !Clflags.for_package) (msg saved)
+  | Asm_generation(fn, err) ->
+     fprintf ppf
+       "Error producing assembly code for function %s: %a"
+       fn Emitaux.report_error err
 
 let () =
   Location.register_error_of_exn

ocaml/asmcomp/asmgen.mli

@@ -44,6 +44,7 @@ val compile_phrase :
 type error =
   | Assembler_error of string
   | Mismatched_for_pack of string option
+  | Asm_generation of string * Emitaux.error
 
 exception Error of error
 val report_error: Format.formatter -> error -> unit

ocaml/asmcomp/emitaux.ml

@@ -15,6 +15,11 @@
 
 (* Common functions for emitting assembly code *)
 
+type error =
+  | Stack_frame_too_large of int
+
+exception Error of error
+
 let output_channel = ref stdout
 
 let emit_string s = output_string !output_channel s
@@ -178,6 +183,12 @@ 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_frame fd =
     assert (fd.fd_frame_size land 3 = 0);
     let flags =
@@ -191,9 +202,9 @@ let emit_frames a =
         then 3 else 2
     in
     a.efa_code_label fd.fd_lbl;
-    a.efa_16 (fd.fd_frame_size + flags);
-    a.efa_16 (List.length fd.fd_live_offset);
-    List.iter a.efa_16 fd.fd_live_offset;
+    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;
     begin match fd.fd_debuginfo with
     | _ when flags = 0 ->
       ()
@@ -370,3 +381,7 @@ let reset () =
 
 let binary_backend_available = ref false
 let create_asm_file = ref true
+
+let report_error ppf = function
+  | Stack_frame_too_large n ->
+      Format.fprintf ppf "stack frame too large (%d bytes)" n

ocaml/asmcomp/emitaux.mli

@@ -71,11 +71,16 @@ val cfi_endproc : unit -> unit
 val cfi_adjust_cfa_offset : int -> unit
 val cfi_offset : reg:int -> offset:int -> unit
 
-
 val binary_backend_available: bool ref
     (** Is a binary backend available.  If yes, we don't need
         to generate the textual assembly file (unless the user
         request it with -S). *)
 
 val create_asm_file: bool ref
     (** Are we actually generating the textual assembly file? *)
+
+type error =
+  | Stack_frame_too_large of int
+
+exception Error of error
+val report_error: Format.formatter -> error -> unit