Position [Lprologue] correctly (#2292)

17 files changed, 151 insertions, 27 deletions

diff --git a/Changes b/Changes
index 812fba7579..42e14884b5 100644
--- a/Changes
+++ b/Changes
@@ -83,6 +83,11 @@ Working version
 - #2291: Add [Compute_ranges] pass
   (Mark Shinwell, review by Vincent Laviron)
 
+- #2292: Add [Proc.frame_required] and [Proc.prologue_required].
+  Move tail recursion label creation to [Linearize].  Correctly position
+  [Lprologue] relative to [Iname_for_debugger] operations.
+  (Mark Shinwell, review by Vincent Laviron)
+
 - #2308: More debugging information on [Cmm] terms
   (Mark Shinwell, review by Stephen Dolan)
 
diff --git a/asmcomp/amd64/emit.mlp b/asmcomp/amd64/emit.mlp
index 94531d311e..4b6d25e970 100644
--- a/asmcomp/amd64/emit.mlp
+++ b/asmcomp/amd64/emit.mlp
@@ -73,9 +73,6 @@ let stack_offset = ref 0
 
 (* Layout of the stack frame *)
 
-let frame_required () =
-  fp || !contains_calls || num_stack_slots.(0) > 0 || num_stack_slots.(1) > 0
-
 let frame_size () =                     (* includes return address *)
   if frame_required() then begin
     let sz =
@@ -486,6 +483,7 @@ let emit_instr fallthrough i =
   match i.desc with
   | Lend -> ()
   | Lprologue ->
+    assert (Proc.prologue_required ());
     if fp then begin
       I.push rbp;
       cfi_adjust_cfa_offset 8;
@@ -498,8 +496,7 @@ let emit_instr fallthrough i =
         I.sub (int n) rsp;
         cfi_adjust_cfa_offset n;
       end;
-    end;
-    def_label !tailrec_entry_point
+    end
   | Lop(Imove | Ispill | Ireload) ->
       let src = i.arg.(0) and dst = i.res.(0) in
       if src.loc <> dst.loc then
@@ -898,7 +895,7 @@ let all_functions = ref []
 let fundecl fundecl =
   function_name := fundecl.fun_name;
   fastcode_flag := fundecl.fun_fast;
-  tailrec_entry_point := new_label();
+  tailrec_entry_point := fundecl.fun_tailrec_entry_point_label;
   stack_offset := 0;
   call_gc_sites := [];
   bound_error_sites := [];
diff --git a/asmcomp/amd64/proc.ml b/asmcomp/amd64/proc.ml
index db94a476f6..4c3c636b59 100644
--- a/asmcomp/amd64/proc.ml
+++ b/asmcomp/amd64/proc.ml
@@ -377,6 +377,12 @@ let op_is_pure = function
 let num_stack_slots = [| 0; 0 |]
 let contains_calls = ref false
 
+let frame_required () =
+  fp || !contains_calls || num_stack_slots.(0) > 0 || num_stack_slots.(1) > 0
+
+let prologue_required () =
+  frame_required ()
+
 (* Calling the assembler *)
 
 let assemble_file infile outfile =
diff --git a/asmcomp/arm/emit.mlp b/asmcomp/arm/emit.mlp
index fe2a8aa12c..6830ba1582 100644
--- a/asmcomp/arm/emit.mlp
+++ b/asmcomp/arm/emit.mlp
@@ -439,6 +439,7 @@ let emit_instr i =
     match i.desc with
     | Lend -> 0
     | Lprologue ->
+      assert (Proc.prologue_required ());
       let n = frame_size() in
       let num_instrs =
         if n > 0 then begin
@@ -928,7 +929,7 @@ let rec emit_all ninstr fallthrough i =
 let fundecl fundecl =
   function_name := fundecl.fun_name;
   fastcode_flag := fundecl.fun_fast;
-  tailrec_entry_point := new_label();
+  tailrec_entry_point := fundecl.fun_tailrec_entry_point_label;
   float_literals := [];
   gotrel_literals := [];
   symbol_literals := [];
diff --git a/asmcomp/arm/proc.ml b/asmcomp/arm/proc.ml
index 1622fa49ce..8ad7bebcc4 100644
--- a/asmcomp/arm/proc.ml
+++ b/asmcomp/arm/proc.ml
@@ -345,6 +345,15 @@ let op_is_pure = function
 let num_stack_slots = [| 0; 0; 0 |]
 let contains_calls = ref false
 
+let frame_required () =
+  !contains_calls
+    || num_stack_slots.(0) > 0
+    || num_stack_slots.(1) > 0
+    || num_stack_slots.(2) > 0
+
+let prologue_required () =
+  frame_required ()
+
 (* Calling the assembler *)
 
 let assemble_file infile outfile =
diff --git a/asmcomp/arm64/emit.mlp b/asmcomp/arm64/emit.mlp
index f189d4bbf3..4a301cf183 100644
--- a/asmcomp/arm64/emit.mlp
+++ b/asmcomp/arm64/emit.mlp
@@ -566,14 +566,14 @@ let emit_instr i =
     match i.desc with
     | Lend -> ()
     | Lprologue ->
+      assert (Proc.prologue_required ());
       let n = frame_size() in
       if n > 0 then
         emit_stack_adjustment (-n);
       if !contains_calls then begin
         cfi_offset ~reg:30 (* return address *) ~offset:(-8);
         `	str	x30, [sp, #{emit_int (n-8)}]\n`
-      end;
-      `{emit_label !tailrec_entry_point}:\n`;
+      end
     | Lop(Imove | Ispill | Ireload) ->
         let src = i.arg.(0) and dst = i.res.(0) in
         if src.loc <> dst.loc then begin
@@ -896,7 +896,7 @@ let rec emit_all i =
 let fundecl fundecl =
   function_name := fundecl.fun_name;
   fastcode_flag := fundecl.fun_fast;
-  tailrec_entry_point := new_label();
+  tailrec_entry_point := fundecl.fun_tailrec_entry_point_label;
   float_literals := [];
   stack_offset := 0;
   call_gc_sites := [];
diff --git a/asmcomp/arm64/proc.ml b/asmcomp/arm64/proc.ml
index 14ba08d59b..095f22f269 100644
--- a/asmcomp/arm64/proc.ml
+++ b/asmcomp/arm64/proc.ml
@@ -254,6 +254,14 @@ let op_is_pure = function
 let num_stack_slots = [| 0; 0 |]
 let contains_calls = ref false
 
+let frame_required () =
+  !contains_calls
+    || num_stack_slots.(0) > 0
+    || num_stack_slots.(1) > 0
+
+let prologue_required () =
+  frame_required ()
+
 (* Calling the assembler *)
 
 let assemble_file infile outfile =
diff --git a/asmcomp/i386/emit.mlp b/asmcomp/i386/emit.mlp
index fd014c5604..9f55cd293a 100644
--- a/asmcomp/i386/emit.mlp
+++ b/asmcomp/i386/emit.mlp
@@ -473,12 +473,12 @@ let emit_instr fallthrough i =
   match i.desc with
   | Lend -> ()
   | Lprologue ->
+    assert (Proc.prologue_required ());
     let n = frame_size() - 4 in
     if n > 0 then  begin
       I.sub (int n) esp;
       cfi_adjust_cfa_offset n;
     end;
-    def_label !tailrec_entry_point
   | Lop(Imove | Ispill | Ireload) ->
       let src = i.arg.(0) and dst = i.res.(0) in
       if src.loc <> dst.loc then begin
@@ -887,7 +887,7 @@ let rec emit_all fallthrough i =
 let fundecl fundecl =
   function_name := fundecl.fun_name;
   fastcode_flag := fundecl.fun_fast;
-  tailrec_entry_point := new_label();
+  tailrec_entry_point := fundecl.fun_tailrec_entry_point_label;
   stack_offset := 0;
   call_gc_sites := [];
   bound_error_sites := [];
diff --git a/asmcomp/i386/proc.ml b/asmcomp/i386/proc.ml
index 29290d0d90..0b333af499 100644
--- a/asmcomp/i386/proc.ml
+++ b/asmcomp/i386/proc.ml
@@ -241,6 +241,17 @@ let op_is_pure = function
 let num_stack_slots = [| 0; 0 |]
 let contains_calls = ref false
 
+let frame_required () =
+  let frame_size_at_top_of_function =
+    (* cf. [frame_size] in emit.mlp. *)
+    Misc.align (4*num_stack_slots.(0) + 8*num_stack_slots.(1) + 4)
+      stack_alignment
+  in
+  frame_size_at_top_of_function > 4
+
+let prologue_required () =
+  frame_required ()
+
 (* Calling the assembler *)
 
 let assemble_file infile outfile =
diff --git a/asmcomp/linearize.ml b/asmcomp/linearize.ml
index 885a2e4fb1..38d3d6ac8b 100644
--- a/asmcomp/linearize.ml
+++ b/asmcomp/linearize.ml
@@ -55,6 +55,7 @@ type fundecl =
     fun_fast: bool;
     fun_dbg : Debuginfo.t;
     fun_spacetime_shape : Mach.spacetime_shape option;
+    fun_tailrec_entry_point_label : label;
   }
 
 (* Invert a test *)
@@ -313,20 +314,72 @@ let rec linear i n =
       copy_instr (Lraise k) i (discard_dead_code n)
 
 let add_prologue first_insn =
-  let insn = first_insn in
-  { desc = Lprologue;
-    next = insn;
-    arg = [| |];
-    res = [| |];
-    dbg = insn.dbg;
-    live = insn.live;
-  }
+  (* The prologue needs to come after any [Iname_for_debugger] operations that
+     refer to parameters.  (Such operations always come in a contiguous
+     block, cf. [Selectgen].) *)
+  let rec skip_naming_ops (insn : instruction) : label * instruction =
+    match insn.desc with
+    | Lop (Iname_for_debugger _) ->
+      let tailrec_entry_point_label, next = skip_naming_ops insn.next in
+      tailrec_entry_point_label, { insn with next; }
+    | _ ->
+      let tailrec_entry_point_label = Cmm.new_label () in
+      let tailrec_entry_point =
+        { desc = Llabel tailrec_entry_point_label;
+          next = insn;
+          arg = [| |];
+          res = [| |];
+          dbg = insn.dbg;
+          live = insn.live;
+        }
+      in
+      (* We expect [Lprologue] to expand to at least one instruction---as such,
+         if no prologue is required, we avoid adding the instruction here.
+         The reason is subtle: an empty expansion of [Lprologue] can cause
+         two labels, one either side of the [Lprologue], to point at the same
+         location.  This means that we lose the property (cf. [Coalesce_labels])
+         that we can check if two labels point at the same location by
+         comparing them for equality.  This causes trouble when the function
+         whose prologue is in question lands at the top of the object file
+         and we are emitting DWARF debugging information:
+           foo_code_begin:
+           foo:
+           .L1:
+           ; empty prologue
+           .L2:
+           ...
+         If we were to emit a location list entry from L1...L2, not realising
+         that they point at the same location, then the beginning and ending
+         points of the range would be both equal to each other and (relative to
+         "foo_code_begin") equal to zero.  This appears to confuse objdump,
+         which seemingly misinterprets the entry as an end-of-list entry
+         (which is encoded with two zero words), then complaining about a
+         "hole in location list" (as it ignores any remaining list entries
+         after the misinterpreted entry). *)
+      if Proc.prologue_required () then
+        let prologue =
+          { desc = Lprologue;
+            next = tailrec_entry_point;
+            arg = [| |];
+            res = [| |];
+            dbg = tailrec_entry_point.dbg;
+            live = Reg.Set.empty;  (* will not be used *)
+          }
+        in
+        tailrec_entry_point_label, prologue
+      else
+        tailrec_entry_point_label, tailrec_entry_point
+  in
+  skip_naming_ops first_insn
 
 let fundecl f =
-  let fun_body = add_prologue (linear f.Mach.fun_body end_instr) in
+  let fun_tailrec_entry_point_label, fun_body =
+    add_prologue (linear f.Mach.fun_body end_instr)
+  in
   { fun_name = f.Mach.fun_name;
     fun_body;
     fun_fast = not (List.mem Cmm.Reduce_code_size f.Mach.fun_codegen_options);
     fun_dbg  = f.Mach.fun_dbg;
     fun_spacetime_shape = f.Mach.fun_spacetime_shape;
+    fun_tailrec_entry_point_label;
   }
diff --git a/asmcomp/linearize.mli b/asmcomp/linearize.mli
index 257716bc6e..d166229568 100644
--- a/asmcomp/linearize.mli
+++ b/asmcomp/linearize.mli
@@ -53,6 +53,7 @@ type fundecl =
     fun_fast: bool;
     fun_dbg : Debuginfo.t;
     fun_spacetime_shape : Mach.spacetime_shape option;
+    fun_tailrec_entry_point_label : label;
   }
 
 val fundecl: Mach.fundecl -> fundecl
diff --git a/asmcomp/power/emit.mlp b/asmcomp/power/emit.mlp
index a06fb58721..abf3471c76 100644
--- a/asmcomp/power/emit.mlp
+++ b/asmcomp/power/emit.mlp
@@ -527,6 +527,7 @@ let emit_instr i =
     match i.desc with
     | Lend -> ()
     | Lprologue ->
+      assert (Proc.prologue_required ());
       let n = frame_size() in
       if n > 0 then begin
         `	addi	1, 1, {emit_int(-n)}\n`;
@@ -541,8 +542,7 @@ let emit_instr i =
         | ELF32 -> ()
         | ELF64v1 | ELF64v2 ->
           `	std	2, {emit_int(toc_save_offset())}(1)\n`
-      end;
-      `{emit_label !tailrec_entry_point}:\n`
+      end
     | Lop(Imove | Ispill | Ireload) ->
         let src = i.arg.(0) and dst = i.res.(0) in
         if src.loc <> dst.loc then begin
@@ -1007,7 +1007,7 @@ let rec emit_all i =
 
 let fundecl fundecl =
   function_name := fundecl.fun_name;
-  tailrec_entry_point := new_label();
+  tailrec_entry_point := fundecl.fun_tailrec_entry_point_label;
   stack_offset := 0;
   call_gc_label := 0;
   float_literals := [];
diff --git a/asmcomp/power/proc.ml b/asmcomp/power/proc.ml
index 8560d0f988..86b4476c19 100644
--- a/asmcomp/power/proc.ml
+++ b/asmcomp/power/proc.ml
@@ -341,6 +341,26 @@ let op_is_pure = function
 let num_stack_slots = [| 0; 0 |]
 let contains_calls = ref false
 
+(* See [reserved_stack_space] in emit.mlp. *)
+let reserved_stack_space_required () =
+  match abi with
+  | ELF32 -> false
+  | ELF64v1 | ELF64v2 -> true
+
+let frame_required () =
+  let is_elf32 =
+    match abi with
+    | ELF32 -> true
+    | ELF64v1 | ELF64v2 -> false
+  in
+  reserved_stack_space_required ()
+    || num_stack_slots.(0) > 0
+    || num_stack_slots.(1) > 0
+    || (!contains_calls && is_elf32)
+
+let prologue_required () =
+  frame_required ()
+
 (* Calling the assembler *)
 
 let assemble_file infile outfile =
diff --git a/asmcomp/proc.mli b/asmcomp/proc.mli
index 2074d619b3..4e0e03640e 100644
--- a/asmcomp/proc.mli
+++ b/asmcomp/proc.mli
@@ -67,6 +67,10 @@ val op_is_pure: Mach.operation -> bool
 (* Info for laying out the stack frame *)
 val num_stack_slots: int array
 val contains_calls: bool ref
+val frame_required : unit -> bool
+
+(* Function prologues *)
+val prologue_required : unit -> bool
 
 (** For a given register class, the DWARF register numbering for that class.
     Given an allocated register with location [Reg n] and class [reg_class], the
diff --git a/asmcomp/s390x/emit.mlp b/asmcomp/s390x/emit.mlp
index 52d724f757..619b454fe0 100644
--- a/asmcomp/s390x/emit.mlp
+++ b/asmcomp/s390x/emit.mlp
@@ -308,11 +308,11 @@ let emit_instr i =
     match i.desc with
       Lend -> ()
     | Lprologue ->
+      assert (Proc.prologue_required ());
       let n = frame_size() in
       emit_stack_adjust n;
       if !contains_calls then
-        `	stg	%r14, {emit_int(n - size_addr)}(%r15)\n`;
-      `{emit_label !tailrec_entry_point}:\n`;
+        `	stg	%r14, {emit_int(n - size_addr)}(%r15)\n`
     | Lop(Imove | Ispill | Ireload) ->
         let src = i.arg.(0) and dst = i.res.(0) in
         if src.loc <> dst.loc then begin
@@ -648,7 +648,7 @@ let rec emit_all i =
 
 let fundecl fundecl =
   function_name := fundecl.fun_name;
-  tailrec_entry_point := new_label();
+  tailrec_entry_point := fundecl.fun_tailrec_entry_point_label;
   stack_offset := 0;
   call_gc_sites := [];
   bound_error_sites := [];
diff --git a/asmcomp/s390x/proc.ml b/asmcomp/s390x/proc.ml
index 9b359b1905..db2b0c044d 100644
--- a/asmcomp/s390x/proc.ml
+++ b/asmcomp/s390x/proc.ml
@@ -228,6 +228,14 @@ let op_is_pure = function
 let num_stack_slots = [| 0; 0 |]
 let contains_calls = ref false
 
+let frame_required () =
+  !contains_calls
+    || num_stack_slots.(0) > 0
+    || num_stack_slots.(1) > 0
+
+let prologue_required () =
+  frame_required ()
+
 (* Calling the assembler *)
 
 let assemble_file infile outfile =
diff --git a/asmcomp/schedgen.ml b/asmcomp/schedgen.ml
index 62a7346d7d..414842283d 100644
--- a/asmcomp/schedgen.ml
+++ b/asmcomp/schedgen.ml
@@ -392,6 +392,7 @@ method schedule_fundecl f =
       fun_fast = f.fun_fast;
       fun_dbg  = f.fun_dbg;
       fun_spacetime_shape = f.fun_spacetime_shape;
+      fun_tailrec_entry_point_label = f.fun_tailrec_entry_point_label;
     }
   end else
     f