GPR#109: new unboxing strategy (patch by vbrankov).

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@16215 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

Changes

@@ -34,6 +34,8 @@ Compilers:
 - PR#6845: -no-check-prims to tell ocamlc not to check primitives in runtime
 - GPR#17: some cmm optimizations of integer operations with constants
   (Stephen Dolan, review by Pierre Chambart)
+- GPR#109: new unboxing strategy for float and int references (Vladimir Brankov,
+  review by Alain Frisch)
 
 Runtime system:
 - PR#6517: use ISO C99 types {,u}int{32,64}_t in preference to our homegrown

asmcomp/cmmgen.ml

@@ -1262,36 +1262,29 @@ let rec is_unboxed_number = function
   | Ulet (_, _, e) | Usequence (_, e) -> is_unboxed_number e
   | _ -> No_unboxing
 
-let subst_boxed_number unbox_fn boxed_id unboxed_id box_chunk box_offset exp =
+let subst_boxed_number box_fn unbox_fn boxed_id unboxed_id box_chunk box_offset exp =
-  let need_boxed = ref false in
-  let assigned = ref false in
   let rec subst = function
       Cvar id as e ->
-        if Ident.same id boxed_id then need_boxed := true; e
+        if Ident.same id boxed_id then
+          box_fn (Cvar unboxed_id)
+        else e
     | Clet(id, arg, body) -> Clet(id, subst arg, subst body)
     | Cassign(id, arg) ->
         if Ident.same id boxed_id then begin
-          assigned := true;
           Cassign(unboxed_id, subst(unbox_fn arg))
         end else
           Cassign(id, subst arg)
     | Ctuple argv -> Ctuple(List.map subst argv)
-    | Cop(Cload chunk, [Cvar id]) as e ->
+    | Cop(Cload chunk, [Cvar id])
-      if not (Ident.same id boxed_id) then e
+      when Ident.same id boxed_id &&
-      else if chunk = box_chunk && box_offset = 0 then
+           chunk = box_chunk && box_offset = 0
+      ->
         Cvar unboxed_id
-      else begin
+    | Cop(Cload chunk, [Cop(Cadda, [Cvar id; Cconst_int ofs])])
-        need_boxed := true;
+        when Ident.same id boxed_id &&
-        e
+             chunk = box_chunk && ofs = box_offset
-      end
+      ->
-    | Cop(Cload chunk, [Cop(Cadda, [Cvar id; Cconst_int ofs])]) as e ->
-      if not (Ident.same id boxed_id) then e
-      else if chunk = box_chunk && ofs = box_offset then
         Cvar unboxed_id
-      else begin
-        need_boxed := true;
-        e
-      end
     | Cop(op, argv) -> Cop(op, List.map subst argv)
     | Csequence(e1, e2) -> Csequence(subst e1, subst e2)
     | Cifthenelse(e1, e2, e3) -> Cifthenelse(subst e1, subst e2, subst e3)
@@ -1305,8 +1298,7 @@ let subst_boxed_number unbox_fn boxed_id unboxed_id box_chunk box_offset exp =
     | Cconst_pointer _ | Cconst_natpointer _
     | Cconst_blockheader _ as e -> e
   in
-  let res = subst exp in
+  subst exp
-  (res, !need_boxed, !assigned)
 
 (* Translate an expression *)
 
@@ -2073,15 +2065,9 @@ and transl_unbox_let box_fn unbox_fn transl_unbox_fn box_chunk box_offset
                      id exp body =
   let unboxed_id = Ident.create (Ident.name id) in
   let trbody1 = transl body in
-  let (trbody2, need_boxed, is_assigned) =
+  let trbody2 =
-    subst_boxed_number unbox_fn id unboxed_id box_chunk box_offset trbody1 in
+    subst_boxed_number box_fn unbox_fn id unboxed_id box_chunk box_offset trbody1 in
-  if need_boxed && is_assigned then
+  Clet(unboxed_id, transl_unbox_fn exp, trbody2)
-    Clet(id, transl exp, trbody1)
-  else
-    Clet(unboxed_id, transl_unbox_fn exp,
-         if need_boxed
-         then Clet(id, box_fn(Cvar unboxed_id), trbody2)
-         else trbody2)
 
 and make_catch ncatch body handler = match body with
 | Cexit (nexit,[]) when nexit=ncatch -> handler

testsuite/tests/float-unboxing/float_subst_boxed_number.ml

@@ -24,3 +24,29 @@ module PR_6770 = struct
 
   let _ = to_string (Constant 4.)
 end
+
+
+module GPR_109 = struct
+
+  let f () =
+    let r = ref 0. in
+    for i = 1 to 1000 do
+       r := !r +. float i
+    done;
+    !r
+
+  let test () =
+    let a0 = Gc.allocated_bytes () in
+    let a1 = Gc.allocated_bytes () in
+    let _x = f () in
+    let a2 = Gc.allocated_bytes () in
+    let alloc = (a2 -. 2. *. a1 +. a0) in
+    assert(alloc < 100.)
+
+    let () =
+      (* is there a better to test whether we run in native code? *)
+      match Filename.basename Sys.argv.(0) with
+      | "program.byte" -> ()
+      | "program.native" -> test ()
+      | _ -> assert false
+end