Bugfix for Comballoc with local allocations. (oxcaml#41)

stedolan · stedolan · commit f2c5a85bce51 · 2021-11-11T09:41:21.000Z
It is incorrect to combine two local allocations that straddle
a heap allocation, as the GC traverses the local allocations
looking for roots and must not see uninitialised local data.
diff --git a/asmcomp/comballoc.ml b/asmcomp/comballoc.ml
@@ -20,64 +20,54 @@ open Mach
 type pending_alloc =
   { reg: Reg.t;         (* register holding the result of the last allocation *)
     dbginfos: Debuginfo.alloc_dbginfo;   (* debug info for each pending alloc *)
-    totalsz: int }                    (* amount to be allocated in this block *)
+    totalsz: int;                     (* amount to be allocated in this block *)
+    mode: Lambda.alloc_mode }                     (* heap or stack allocation *)
 
-type mode_allocation_state =
+type allocation_state =
     No_alloc
   | Pending_alloc of pending_alloc
 
-type allocation_state =
-  { heap: mode_allocation_state; local: mode_allocation_state }
-
-let get_mode (m : Lambda.alloc_mode) s =
-  match m with
-  | Alloc_heap -> s.heap
-  | Alloc_local -> s.local
-
-let set_mode (m : Lambda.alloc_mode) s x =
-  match m with
-  | Alloc_heap -> { s with heap = x }
-  | Alloc_local -> { s with local = x }
-
 let rec combine i allocstate =
   match i.desc with
     Iend | Ireturn | Iexit _ | Iraise _ ->
       (i, allocstate)
   | Iop(Ialloc { bytes = sz; dbginfo; mode }) ->
       assert (List.length dbginfo = 1);
-      begin match get_mode mode allocstate with
-      | Pending_alloc {reg; dbginfos; totalsz}
-          when (totalsz + sz <= (Config.max_young_wosize + 1) * Arch.size_addr)
-               || mode = Lambda.Alloc_local ->
+      begin match allocstate with
+      | Pending_alloc {reg; dbginfos; totalsz; mode = prev_mode}
+          when (mode = prev_mode) &&
+              ((totalsz + sz <= (Config.max_young_wosize + 1) * Arch.size_addr)
+               || mode = Lambda.Alloc_local) ->
           let (next, state) =
            combine i.next
-             (set_mode mode allocstate
-                (Pending_alloc { reg = i.res.(0);
-                                 dbginfos = dbginfo @ dbginfos;
-                                 totalsz = totalsz + sz })) in
+             (Pending_alloc { reg = i.res.(0);
+                              dbginfos = dbginfo @ dbginfos;
+                              totalsz = totalsz + sz;
+                              mode }) in
          (instr_cons_debug (Iop(Iintop_imm(Iadd, -sz)))
             [| reg |] i.res i.dbg next,
            state)
       | No_alloc | Pending_alloc _ ->
          let (next, state) =
            combine i.next
-             (set_mode mode allocstate
-                (Pending_alloc { reg = i.res.(0);
-                                 dbginfos = dbginfo;
-                                 totalsz = sz })) in
+             (Pending_alloc { reg = i.res.(0);
+                              dbginfos = dbginfo;
+                              totalsz = sz;
+                              mode }) in
          let totalsz, dbginfo =
-           match get_mode mode state with
+           match state with
            | No_alloc -> assert false
-           | Pending_alloc { totalsz; dbginfos; _ } -> totalsz, dbginfos in
+           | Pending_alloc { totalsz; dbginfos; mode = m; _ } ->
+              assert (m = mode);
+              totalsz, dbginfos in
          let next =
            let offset = totalsz - sz in
            if offset = 0 then next
            else instr_cons_debug (Iop(Iintop_imm(Iadd, offset))) i.res
                 i.res i.dbg next
          in
-         let rstate = set_mode mode state (get_mode mode allocstate) in
          (instr_cons_debug (Iop(Ialloc {bytes = totalsz; dbginfo; mode}))
-          i.arg i.res i.dbg next, rstate)
+          i.arg i.res i.dbg next, allocstate)
       end
   | Iop(Icall_ind | Icall_imm _ | Iextcall _ |
         Itailcall_ind | Itailcall_imm _) ->
@@ -112,7 +102,7 @@ let rec combine i allocstate =
       (instr_cons (Itrywith(newbody, newhandler)) i.arg i.res newnext, s')
 
 and combine_restart i =
-  let (newi, _) = combine i {local=No_alloc; heap=No_alloc} in newi
+  let (newi, _) = combine i No_alloc in newi
 
 let fundecl f =
   {f with fun_body = combine_restart f.fun_body}
diff --git a/testsuite/tests/typing-local/comballoc.ml b/testsuite/tests/typing-local/comballoc.ml
@@ -0,0 +1,28 @@
+(* TEST *)
+let glob = ref []
+
+let[@inline never] f g n =
+  let a = local_ [n] in
+  let b = [n+1] in
+  let c = local_ [n+2] in
+  glob := b;
+  g a c;
+  ()
+
+type junk = { a : float; b : float; c : float; d : float; e : float; f : float }
+let[@inline never] clear g n =
+  let junk = local_ {a=n;b=n;c=n;d=n;e=n;f=n} in
+  g junk;
+  ()
+
+(* As a header, this looks like tag 0 and marked,
+   while as a value it's (probably) an invalid pointer *)
+let ones = Int64.float_of_bits 0x3FFF_FF00_FFFF_FF00L
+let () =
+  for i = 1 to 1_000_000 do
+    clear (fun _ -> ()) ones;
+    f (fun _ _ -> ()) 42
+  done;
+  print_endline "ok"
+
+
diff --git a/testsuite/tests/typing-local/comballoc.reference b/testsuite/tests/typing-local/comballoc.reference
@@ -0,0 +1 @@
+ok
