Merge pull request ocaml#8805 from stedolan/statmemprof-comballoc-native

Keep information about allocation sizes, for statmemprof, and use during GC.

.depend

@@ -2152,10 +2152,12 @@ asmcomp/branch_relaxation.cmi : \
     asmcomp/linear.cmi \
     asmcomp/branch_relaxation_intf.cmo
 asmcomp/branch_relaxation_intf.cmo : \
+    asmcomp/mach.cmi \
     asmcomp/linear.cmi \
     asmcomp/cmm.cmi \
     asmcomp/arch.cmo
 asmcomp/branch_relaxation_intf.cmx : \
+    asmcomp/mach.cmx \
     asmcomp/linear.cmx \
     asmcomp/cmm.cmx \
     asmcomp/arch.cmx
@@ -2351,7 +2353,6 @@ asmcomp/emit.cmo : \
     lambda/lambda.cmi \
     asmcomp/emitaux.cmi \
     utils/domainstate.cmi \
-    lambda/debuginfo.cmi \
     utils/config.cmi \
     middle_end/compilenv.cmi \
     asmcomp/cmm.cmi \
@@ -2373,7 +2374,6 @@ asmcomp/emit.cmx : \
     lambda/lambda.cmx \
     asmcomp/emitaux.cmx \
     utils/domainstate.cmx \
-    lambda/debuginfo.cmx \
     utils/config.cmx \
     middle_end/compilenv.cmx \
     asmcomp/cmm.cmx \
@@ -2385,20 +2385,23 @@ asmcomp/emit.cmi : \
     asmcomp/linear.cmi \
     asmcomp/cmm.cmi
 asmcomp/emitaux.cmo : \
+    asmcomp/mach.cmi \
     lambda/debuginfo.cmi \
     utils/config.cmi \
     asmcomp/cmm.cmi \
     utils/clflags.cmi \
     asmcomp/arch.cmo \
     asmcomp/emitaux.cmi
 asmcomp/emitaux.cmx : \
+    asmcomp/mach.cmx \
     lambda/debuginfo.cmx \
     utils/config.cmx \
     asmcomp/cmm.cmx \
     utils/clflags.cmx \
     asmcomp/arch.cmx \
     asmcomp/emitaux.cmi
 asmcomp/emitaux.cmi : \
+    asmcomp/mach.cmi \
     lambda/debuginfo.cmi
 asmcomp/interf.cmo : \
     asmcomp/reg.cmi \

Changes

@@ -262,6 +262,10 @@ OCaml 4.10.0
   the new hook caml_fatal_error_hook.
   (Jacques-Henri Jourdan, review by Xavier Leroy)
 
+- #8637, #8805: Record debug info for each allocation
+  (Stephen Dolan and Jacques-Henri Jourdan, review by Damien Doligez,
+   KC Sivaramakrishnan and Xavier Leroy)
+
 - #8713: Introduce a state table in the runtime to contain the global variables
    which must be duplicated for each domain in the multicore runtime.
    (KC Sivaramakrishnan and Stephen Dolan, compatibility header hacking by
@@ -517,7 +521,6 @@ OCaml 4.09.0 (19 September 2019):
 - #8787, #8788: avoid integer overflow in caml_output_value_to_bytes
   (Jeremy Yallop, report by Marcello Seri)
 
-
 - #2075, #7729: rename _T macro used to support Unicode in the (Windows) runtime
   in order to avoid compiler warning
   (Nicolás Ojeda Bär, review by Gabriel Scherer and David Allsopp)

asmcomp/amd64/emit.mlp

@@ -239,7 +239,7 @@ let addressing addr typ i n =
 
 (* Record live pointers at call points -- see Emitaux *)
 
-let record_frame_label ?label live raise_ dbg =
+let record_frame_label ?label live dbg =
   let lbl =
     match label with
     | None -> new_label()
@@ -258,11 +258,11 @@ let record_frame_label ?label live raise_ dbg =
     )
     live;
   record_frame_descr ~label:lbl ~frame_size:(frame_size())
-    ~live_offset:!live_offset ~raise_frame:raise_ dbg;
+    ~live_offset:!live_offset dbg;
   lbl
 
-let record_frame ?label live raise_ dbg =
-  let lbl = record_frame_label ?label live raise_ dbg in
+let record_frame ?label live dbg =
+  let lbl = record_frame_label ?label live dbg in
   def_label lbl
 
 (* Spacetime instrumentation *)
@@ -281,8 +281,7 @@ let spacetime_before_uninstrumented_call ~node_ptr ~index =
 (* Record calls to the GC -- we've moved them out of the way *)
 
 type gc_call =
-  { gc_size: int;                       (* Allocation size, in bytes *)
-    gc_lbl: label;                      (* Entry label *)
+  { gc_lbl: label;                      (* Entry label *)
     gc_return_lbl: label;               (* Where to branch after GC *)
     gc_frame: label;                    (* Label of frame descriptor *)
     gc_spacetime : (X86_ast.arg * int) option;
@@ -299,13 +298,7 @@ let emit_call_gc gc =
     assert Config.spacetime;
     spacetime_before_uninstrumented_call ~node_ptr ~index
   end;
-  begin match gc.gc_size with
-  | 16 -> emit_call "caml_call_gc1"
-  | 24 -> emit_call "caml_call_gc2"
-  | 32 -> emit_call "caml_call_gc3"
-  | n ->  I.add (int n) r15;
-          emit_call "caml_call_gc"
-  end;
+  emit_call "caml_call_gc";
   def_label gc.gc_frame;
   I.jmp (label gc.gc_return_lbl)
 
@@ -327,7 +320,7 @@ let bound_error_call = ref 0
 let bound_error_label ?label dbg ~spacetime =
   if !Clflags.debug || Config.spacetime then begin
     let lbl_bound_error = new_label() in
-    let lbl_frame = record_frame_label ?label Reg.Set.empty false dbg in
+    let lbl_frame = record_frame_label ?label Reg.Set.empty (Dbg_other dbg) in
     bound_error_sites :=
       { bd_lbl = lbl_bound_error; bd_frame = lbl_frame;
         bd_spacetime = spacetime; } :: !bound_error_sites;
@@ -573,16 +566,16 @@ let emit_instr fallthrough i =
       load_symbol_addr s (res i 0)
   | Lop(Icall_ind { label_after; }) ->
       I.call (arg i 0);
-      record_frame i.live false i.dbg ~label:label_after
+      record_frame i.live (Dbg_other i.dbg) ~label:label_after
   | Lop(Icall_imm { func; label_after; }) ->
       add_used_symbol func;
       emit_call func;
-      record_frame i.live false i.dbg ~label:label_after
+      record_frame i.live (Dbg_other i.dbg) ~label:label_after
   | Lop(Itailcall_ind { label_after; }) ->
       output_epilogue begin fun () ->
         I.jmp (arg i 0);
         if Config.spacetime then begin
-          record_frame Reg.Set.empty false i.dbg ~label:label_after
+          record_frame Reg.Set.empty (Dbg_other i.dbg) ~label:label_after
         end
       end
   | Lop(Itailcall_imm { func; label_after; }) ->
@@ -597,14 +590,14 @@ let emit_instr fallthrough i =
         end
       end;
       if Config.spacetime then begin
-        record_frame Reg.Set.empty false i.dbg ~label:label_after
+        record_frame Reg.Set.empty (Dbg_other i.dbg) ~label:label_after
       end
   | Lop(Iextcall { func; alloc; label_after; }) ->
       add_used_symbol func;
       if alloc then begin
         load_symbol_addr func rax;
         emit_call "caml_c_call";
-        record_frame i.live false i.dbg ~label:label_after;
+        record_frame i.live (Dbg_other i.dbg) ~label:label_after;
         if system <> S_win64 then begin
           (* TODO: investigate why such a diff.
              This comes from:
@@ -618,7 +611,7 @@ let emit_instr fallthrough i =
       end else begin
         emit_call func;
         if Config.spacetime then begin
-          record_frame Reg.Set.empty false i.dbg ~label:label_after
+          record_frame Reg.Set.empty (Dbg_other i.dbg) ~label:label_after
         end
       end
   | Lop(Istackoffset n) ->
@@ -667,30 +660,26 @@ let emit_instr fallthrough i =
       | Double | Double_u ->
           I.movsd (arg i 0) (addressing addr REAL8 i 1)
       end
-  | Lop(Ialloc { bytes = n; label_after_call_gc; spacetime_index; }) ->
+  | Lop(Ialloc { bytes = n; label_after_call_gc; spacetime_index; dbginfo }) ->
+      assert (n <= (Config.max_young_wosize + 1) * Arch.size_addr);
       if !fastcode_flag then begin
-        let lbl_redo = new_label() in
-        def_label lbl_redo;
         I.sub (int n) r15;
         I.cmp (domain_field Domainstate.Domain_young_limit) r15;
         let lbl_call_gc = new_label() in
-        let dbg =
-          if not Config.spacetime then Debuginfo.none
-          else i.dbg
-        in
         let lbl_frame =
-          record_frame_label ?label:label_after_call_gc i.live false dbg
+          record_frame_label ?label:label_after_call_gc i.live (Dbg_alloc dbginfo)
         in
         I.jb (label lbl_call_gc);
+        let lbl_after_alloc = new_label() in
+        def_label lbl_after_alloc;
         I.lea (mem64 NONE 8 R15) (res i 0);
         let gc_spacetime =
           if not Config.spacetime then None
           else Some (arg i 0, spacetime_index)
         in
         call_gc_sites :=
-          { gc_size = n;
-            gc_lbl = lbl_call_gc;
-            gc_return_lbl = lbl_redo;
+          { gc_lbl = lbl_call_gc;
+            gc_return_lbl = lbl_after_alloc;
             gc_frame = lbl_frame;
             gc_spacetime; } :: !call_gc_sites
       end else begin
@@ -707,8 +696,8 @@ let emit_instr fallthrough i =
             emit_call "caml_allocN"
         end;
         let label =
-          record_frame_label ?label:label_after_call_gc i.live false
-            Debuginfo.none
+          record_frame_label ?label:label_after_call_gc i.live
+            (Dbg_alloc dbginfo)
         in
         def_label label;
         I.lea (mem64 NONE 8 R15) (res i 0)
@@ -914,10 +903,10 @@ let emit_instr fallthrough i =
       | Lambda.Raise_regular ->
           I.mov (int 0) (domain_field Domainstate.Domain_backtrace_pos);
           emit_call "caml_raise_exn";
-          record_frame Reg.Set.empty true i.dbg
+          record_frame Reg.Set.empty (Dbg_raise i.dbg)
       | Lambda.Raise_reraise ->
           emit_call "caml_raise_exn";
-          record_frame Reg.Set.empty true i.dbg
+          record_frame Reg.Set.empty (Dbg_raise i.dbg)
       | Lambda.Raise_notrace ->
           I.mov (domain_field Domainstate.Domain_exception_pointer) rsp;
           I.pop (domain_field Domainstate.Domain_exception_pointer);
@@ -1015,9 +1004,6 @@ let begin_assembly() =
   all_functions := [];
   if system = S_win64 then begin
     D.extrn "caml_call_gc" NEAR;
-    D.extrn "caml_call_gc1" NEAR;
-    D.extrn "caml_call_gc2" NEAR;
-    D.extrn "caml_call_gc3" NEAR;
     D.extrn "caml_c_call" NEAR;
     D.extrn "caml_allocN" NEAR;
     D.extrn "caml_alloc1" NEAR;
@@ -1119,6 +1105,7 @@ let end_assembly() =
   emit_frames
     { efa_code_label = (fun l -> D.qword (ConstLabel (emit_label l)));
       efa_data_label = (fun l -> D.qword (ConstLabel (emit_label l)));
+      efa_8 = (fun n -> D.byte (const n));
       efa_16 = (fun n -> D.word (const n));
       efa_32 = (fun n -> D.long (const_32 n));
       efa_word = (fun n -> D.qword (const n));
@@ -1142,6 +1129,11 @@ let end_assembly() =
       efa_string = (fun s -> D.bytes (s ^ "\000"))
     };
 
+  if system = S_linux then begin
+    let frametable = Compilenv.make_symbol (Some "frametable") in
+    D.size frametable (ConstSub (ConstThis, ConstLabel frametable))
+  end;
+
   if Config.spacetime then begin
     emit_spacetime_shapes ()
   end;

asmcomp/arm/emit.mlp

@@ -105,7 +105,7 @@ let emit_addressing addr r n =
 
 (* Record live pointers at call points *)
 
-let record_frame_label ?label live raise_ dbg =
+let record_frame_label ?label live dbg =
   let lbl =
     match label with
     | None -> new_label()
@@ -123,11 +123,11 @@ let record_frame_label ?label live raise_ dbg =
       | _ -> ())
     live;
   record_frame_descr ~label:lbl ~frame_size:(frame_size())
-    ~live_offset:!live_offset ~raise_frame:raise_ dbg;
+    ~live_offset:!live_offset dbg;
   lbl
 
-let record_frame ?label live raise_ dbg =
-  let lbl = record_frame_label ?label live raise_ dbg in `{emit_label lbl}:`
+let record_frame ?label live dbg =
+  let lbl = record_frame_label ?label live dbg in `{emit_label lbl}:`
 
 (* Record calls to the GC -- we've moved them out of the way *)
 
@@ -155,7 +155,7 @@ let bound_error_sites = ref ([] : bound_error_call list)
 let bound_error_label ?label dbg =
   if !Clflags.debug || !bound_error_sites = [] then begin
     let lbl_bound_error = new_label() in
-    let lbl_frame = record_frame_label ?label Reg.Set.empty false dbg in
+    let lbl_frame = record_frame_label ?label Reg.Set.empty (Dbg_other dbg) in
     bound_error_sites :=
       { bd_lbl = lbl_bound_error;
         bd_frame_lbl = lbl_frame } :: !bound_error_sites;
@@ -542,15 +542,15 @@ let emit_instr i =
     | Lop(Icall_ind { label_after; }) ->
         if !arch >= ARMv5 then begin
           `	blx	{emit_reg i.arg.(0)}\n`;
-          `{record_frame i.live false i.dbg ~label:label_after}\n`; 1
+          `{record_frame i.live (Dbg_other i.dbg) ~label:label_after}\n`; 1
         end else begin
           `	mov	lr, pc\n`;
           `	bx	{emit_reg i.arg.(0)}\n`;
-          `{record_frame i.live false i.dbg ~label:label_after}\n`; 2
+          `{record_frame i.live (Dbg_other i.dbg) ~label:label_after}\n`; 2
         end
     | Lop(Icall_imm { func; label_after; }) ->
         `	{emit_call func}\n`;
-        `{record_frame i.live false i.dbg ~label:label_after}\n`; 1
+        `{record_frame i.live (Dbg_other i.dbg) ~label:label_after}\n`; 1
     | Lop(Itailcall_ind { label_after = _; }) ->
         output_epilogue begin fun () ->
           if !contains_calls then
@@ -572,7 +572,7 @@ let emit_instr i =
     | Lop(Iextcall { func; alloc = true; label_after; }) ->
         let ninstr = emit_load_symbol_addr (phys_reg 7 (* r7 *)) func in
         `	{emit_call "caml_c_call"}\n`;
-        `{record_frame i.live false i.dbg ~label:label_after}\n`;
+        `{record_frame i.live (Dbg_other i.dbg) ~label:label_after}\n`;
         1 + ninstr
     | Lop(Istackoffset n) ->
         assert (n mod 8 = 0);
@@ -642,34 +642,28 @@ let emit_instr i =
           | Double_u -> "fstd"
           | _ (* 32-bit quantities *) -> "str" in
         `	{emit_string instr}	{emit_reg r}, {emit_addressing addr i.arg 1}\n`; 1
-    | Lop(Ialloc { bytes = n; label_after_call_gc; }) ->
+    | Lop(Ialloc { bytes = n; label_after_call_gc; dbginfo }) ->
         let lbl_frame =
-          record_frame_label i.live false i.dbg ?label:label_after_call_gc
+          record_frame_label i.live (Dbg_alloc dbginfo) ?label:label_after_call_gc
         in
         if !fastcode_flag then begin
-          let lbl_redo = new_label() in
-          `{emit_label lbl_redo}:`;
-          let first = ref true in
-          let ninstr =
-            decompose_intconst (Int32.of_int (n - 4)) (fun a ->
-              if !first
-              then `	sub	{emit_reg i.res.(0)}, alloc_ptr, #{emit_int32 a}\n`
-              else `	sub	{emit_reg i.res.(0)}, {emit_reg i.res.(0)}, #{emit_int32 a}\n`;
-              first := false) in
+          let ninstr = decompose_intconst
+                         (Int32.of_int n)
+                         (fun i ->
+                           `   sub     alloc_ptr, alloc_ptr, #{emit_int32 i}\n`) in
           let offset = Domainstate.(idx_of_field Domain_young_limit) * 8 in
-          let tmp = if i.res.(0).loc = Reg 8 (* r12 *) then phys_reg 7 (* r7 *)
-                    else phys_reg 8 (* r12 *)
-          in
-          `	ldr	{emit_reg tmp}, [domain_state_ptr, {emit_int offset}]\n`;
-          `	cmp	{emit_reg i.res.(0)}, {emit_reg tmp}\n`;
+          `	ldr	{emit_reg i.res.(0)}, [domain_state_ptr, {emit_int offset}]\n`;
+          `     cmp     alloc_ptr, {emit_reg i.res.(0)}\n`;
           let lbl_call_gc = new_label() in
-          `	bls	{emit_label lbl_call_gc}\n`;
-          `	sub	alloc_ptr, {emit_reg i.res.(0)}, #4\n`;
+          `     bcc     {emit_label lbl_call_gc}\n`;
+          let lbl_after_alloc = new_label() in
+          `{emit_label lbl_after_alloc}:`;
+          `     add     {emit_reg i.res.(0)}, alloc_ptr, #4\n`;
           call_gc_sites :=
             { gc_lbl = lbl_call_gc;
-              gc_return_lbl = lbl_redo;
+              gc_return_lbl = lbl_after_alloc;
               gc_frame_lbl = lbl_frame } :: !call_gc_sites;
-          3 + ninstr
+          4 + ninstr
         end else begin
           let ninstr =
             begin match n with
@@ -912,10 +906,10 @@ let emit_instr i =
           `	mov	r12, #0\n`;
           `	str	r12, [domain_state_ptr, {emit_int offset}]\n`;
           `	{emit_call "caml_raise_exn"}\n`;
-          `{record_frame Reg.Set.empty true i.dbg}\n`; 3
+          `{record_frame Reg.Set.empty (Dbg_raise i.dbg)}\n`; 3
         | Lambda.Raise_reraise ->
           `	{emit_call "caml_raise_exn"}\n`;
-          `{record_frame Reg.Set.empty true i.dbg}\n`; 1
+          `{record_frame Reg.Set.empty (Dbg_raise i.dbg)}\n`; 1
         | Lambda.Raise_notrace ->
           `	mov	sp, trap_ptr\n`;
           `	pop	\{trap_ptr, pc}\n`; 2
@@ -1072,6 +1066,7 @@ let end_assembly () =
       efa_data_label = (fun lbl ->
                        `	.type	{emit_label lbl}, %object\n`;
                        `	.word	{emit_label lbl}\n`);
+      efa_8 = (fun n -> `	.byte	{emit_int n}\n`);
       efa_16 = (fun n -> `	.short	{emit_int n}\n`);
       efa_32 = (fun n -> `	.long	{emit_int32 n}\n`);
       efa_word = (fun n -> `	.word	{emit_int n}\n`);