From 1a7d4a3293f2bc71dfd2c3d82db6bc0136ac0543 Mon Sep 17 00:00:00 2001
From: Xavier Leroy <xavier.leroy@inria.fr>
Date: Tue, 31 Mar 2009 09:44:50 +0000
Subject: [PATCH] Added and used Reg.createv_like. Selectgen: new methods
 regs_for, enables ports to store float values in pairs of integer registers.

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@9210 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
---
 asmcomp/reg.ml        |  6 ++++
 asmcomp/reg.mli       |  1 +
 asmcomp/selectgen.ml  | 82 +++++++++++++++++++++----------------------
 asmcomp/selectgen.mli |  5 +++
 4 files changed, 53 insertions(+), 41 deletions(-)

diff --git a/asmcomp/reg.ml b/asmcomp/reg.ml
index 0c6fed5fb..42670c472 100644
--- a/asmcomp/reg.ml
+++ b/asmcomp/reg.ml
@@ -59,6 +59,12 @@ let createv tyv =
   for i = 0 to n-1 do rv.(i) <- create tyv.(i) done;
   rv
 
+let createv_like rv =
+  let n = Array.length rv in
+  let rv' = Array.create n dummy in
+  for i = 0 to n-1 do rv'.(i) <- create rv.(i).typ done;
+  rv'
+
 let clone r =
   let nr = create r.typ in
   nr.name <- r.name;
diff --git a/asmcomp/reg.mli b/asmcomp/reg.mli
index 5bb06f597..b802344de 100644
--- a/asmcomp/reg.mli
+++ b/asmcomp/reg.mli
@@ -39,6 +39,7 @@ and stack_location =
 val dummy: t
 val create: Cmm.machtype_component -> t
 val createv: Cmm.machtype -> t array
+val createv_like: t array -> t array
 val clone: t -> t
 val at_location: Cmm.machtype_component -> location -> t
 
diff --git a/asmcomp/selectgen.ml b/asmcomp/selectgen.ml
index 6089b5ad6..079ae5401 100644
--- a/asmcomp/selectgen.ml
+++ b/asmcomp/selectgen.ml
@@ -335,6 +335,13 @@ method select_condition = function
   | arg ->
       (Itruetest, arg)
 
+(* Return an array of fresh registers of the given type.
+   Normally implemented as Reg.createv, but some
+   ports (e.g. Arm) can override this definition to store float values
+   in pairs of integer registers. *)
+
+method regs_for tys = Reg.createv tys
+
 (* Buffering of instruction sequences *)
 
 val mutable instr_seq = dummy_instr
@@ -391,22 +398,22 @@ method insert_op op rs rd =
 method emit_expr env exp =
   match exp with
     Cconst_int n ->
-      let r = Reg.createv typ_int in
+      let r = self#regs_for typ_int in
       Some(self#insert_op (Iconst_int(Nativeint.of_int n)) [||] r)
   | Cconst_natint n ->
-      let r = Reg.createv typ_int in
+      let r = self#regs_for typ_int in
       Some(self#insert_op (Iconst_int n) [||] r)
   | Cconst_float n ->
-      let r = Reg.createv typ_float in
+      let r = self#regs_for typ_float in
       Some(self#insert_op (Iconst_float n) [||] r)
   | Cconst_symbol n ->
-      let r = Reg.createv typ_addr in
+      let r = self#regs_for typ_addr in
       Some(self#insert_op (Iconst_symbol n) [||] r)
   | Cconst_pointer n ->
-      let r = Reg.createv typ_addr in
+      let r = self#regs_for typ_addr in
       Some(self#insert_op (Iconst_int(Nativeint.of_int n)) [||] r)
   | Cconst_natpointer n ->
-      let r = Reg.createv typ_addr in
+      let r = self#regs_for typ_addr in
       Some(self#insert_op (Iconst_int n) [||] r)
   | Cvar v ->
       begin try
@@ -460,7 +467,7 @@ method emit_expr env exp =
               Proc.contains_calls := true;
               let r1 = self#emit_tuple env new_args in
               let rarg = Array.sub r1 1 (Array.length r1 - 1) in
-              let rd = Reg.createv ty in
+              let rd = self#regs_for ty in
               let (loc_arg, stack_ofs) = Proc.loc_arguments rarg in
               let loc_res = Proc.loc_results rd in
               self#insert_move_args rarg loc_arg stack_ofs;
@@ -471,7 +478,7 @@ method emit_expr env exp =
           | Icall_imm lbl ->
               Proc.contains_calls := true;
               let r1 = self#emit_tuple env new_args in
-              let rd = Reg.createv ty in
+              let rd = self#regs_for ty in
               let (loc_arg, stack_ofs) = Proc.loc_arguments r1 in
               let loc_res = Proc.loc_results rd in
               self#insert_move_args r1 loc_arg stack_ofs;
@@ -482,7 +489,7 @@ method emit_expr env exp =
               Proc.contains_calls := true;
               let (loc_arg, stack_ofs) =
                 self#emit_extcall_args env new_args in
-              let rd = Reg.createv ty in
+              let rd = self#regs_for ty in
               let loc_res = Proc.loc_external_results rd in
               self#insert_debug (Iop(Iextcall(lbl, alloc))) dbg
                              loc_arg loc_res;
@@ -490,14 +497,14 @@ method emit_expr env exp =
               Some rd
           | Ialloc _ ->
               Proc.contains_calls := true;
-              let rd = Reg.createv typ_addr in
+              let rd = self#regs_for typ_addr in
               let size = size_expr env (Ctuple new_args) in
               self#insert (Iop(Ialloc size)) [||] rd;
               self#emit_stores env new_args rd;
               Some rd
           | op ->
               let r1 = self#emit_tuple env new_args in
-              let rd = Reg.createv ty in
+              let rd = self#regs_for ty in
               Some (self#insert_op_debug op dbg r1 rd)
       end        
   | Csequence(e1, e2) ->
@@ -536,7 +543,7 @@ method emit_expr env exp =
       let rs =
         List.map
           (fun id ->
-            let r = Reg.createv typ_addr in name_regs id r; r)
+            let r = self#regs_for typ_addr in name_regs id r; r)
           ids in
       catch_regs := (nfail, Array.concat rs) :: !catch_regs ; 
       let (r1, s1) = self#emit_sequence env e1 in
@@ -566,7 +573,7 @@ method emit_expr env exp =
   | Ctrywith(e1, v, e2) ->
       Proc.contains_calls := true;
       let (r1, s1) = self#emit_sequence env e1 in
-      let rv = Reg.createv typ_addr in
+      let rv = self#regs_for typ_addr in
       let (r2, s2) = self#emit_sequence (Tbl.add v rv env) e2 in
       let r = join r1 s1 r2 s2 in
       self#insert
@@ -586,10 +593,7 @@ method private bind_let env v r1 =
     name_regs v r1;
     Tbl.add v r1 env
   end else begin
-    let rv = Array.create (Array.length r1) Reg.dummy in
-    for i = 0 to Array.length r1 - 1 do
-      rv.(i) <- Reg.create r1.(i).typ
-    done;
+    let rv = Reg.createv_like r1 in
     name_regs v rv;
     self#insert_moves r1 rv;
     Tbl.add v rv env
@@ -602,25 +606,21 @@ method private emit_parts env exp =
     match self#emit_expr env exp with
       None -> None
     | Some r ->
-        match Array.length r with
-          0 ->
-            Some (Ctuple [], env)
-        | 1 ->
-            (* The normal case *)
-            let id = Ident.create "bind" in
-            let r0 = r.(0) in
-            if String.length r0.name = 0 then
-              (* r0 is an anonymous, unshared register; use it directly *)
-              Some (Cvar id, Tbl.add id r env)
-            else begin
-              (* Introduce a fresh temp reg to hold the result *)
-              let v0 = Reg.create r0.typ in
-              self#insert_move r0 v0;
-              Some (Cvar id, Tbl.add id [|v0|] env)
-            end
-        | _ ->
-            (* Must not happen, we no longer support nested tuples *)
-            assert false
+        if Array.length r = 0 then
+          Some (Ctuple [], env)
+        else begin
+          (* The normal case *)
+          let id = Ident.create "bind" in
+          if all_regs_anonymous r then
+            (* r is an anonymous, unshared register; use it directly *)
+            Some (Cvar id, Tbl.add id r env)
+          else begin
+            (* Introduce a fresh temp to hold the result *)
+            let tmp = Reg.createv_like r in
+            self#insert_moves r tmp;
+            Some (Cvar id, Tbl.add id tmp env)
+          end
+        end
   end
 
 method private emit_parts_list env exp_list =
@@ -709,7 +709,7 @@ method emit_tail env exp =
                             (Array.append [|r1.(0)|] loc_arg) [||]
               end else begin
                 Proc.contains_calls := true;
-                let rd = Reg.createv ty in
+                let rd = self#regs_for ty in
                 let loc_res = Proc.loc_results rd in
                 self#insert_move_args rarg loc_arg stack_ofs;
                 self#insert_debug (Iop Icall_ind) dbg
@@ -729,7 +729,7 @@ method emit_tail env exp =
                 self#insert (Iop(Itailcall_imm lbl)) loc_arg' [||]
               end else begin
                 Proc.contains_calls := true;
-                let rd = Reg.createv ty in
+                let rd = self#regs_for ty in
                 let loc_res = Proc.loc_results rd in
                 self#insert_move_args r1 loc_arg stack_ofs;
                 self#insert_debug (Iop(Icall_imm lbl)) dbg loc_arg loc_res;
@@ -764,7 +764,7 @@ method emit_tail env exp =
        let rs =
         List.map
           (fun id ->
-            let r = Reg.createv typ_addr in
+            let r = self#regs_for typ_addr in
             name_regs id r  ;
             r)
           ids in
@@ -780,7 +780,7 @@ method emit_tail env exp =
   | Ctrywith(e1, v, e2) ->
       Proc.contains_calls := true;
       let (opt_r1, s1) = self#emit_sequence env e1 in
-      let rv = Reg.createv typ_addr in
+      let rv = self#regs_for typ_addr in
       let s2 = self#emit_tail_sequence (Tbl.add v rv env) e2 in
       self#insert
         (Itrywith(s1#extract,
@@ -808,7 +808,7 @@ method emit_fundecl f =
   current_function_name := f.Cmm.fun_name;
   let rargs =
     List.map
-      (fun (id, ty) -> let r = Reg.createv ty in name_regs id r; r)
+      (fun (id, ty) -> let r = self#regs_for ty in name_regs id r; r)
       f.Cmm.fun_args in
   let rarg = Array.concat rargs in
   let loc_arg = Proc.loc_parameters rarg in
diff --git a/asmcomp/selectgen.mli b/asmcomp/selectgen.mli
index ed7d5917e..6d7bd2948 100644
--- a/asmcomp/selectgen.mli
+++ b/asmcomp/selectgen.mli
@@ -39,6 +39,11 @@ class virtual selector_generic : object
   method select_store :
     Arch.addressing_mode -> Cmm.expression -> Mach.operation * Cmm.expression
     (* Can be overriden to deal with special store constant instructions *)
+  method regs_for : Cmm.machtype -> Reg.t array
+    (* Return an array of fresh registers of the given type.
+       Default implementation is like Reg.createv.
+       Can be overriden if float values are stored as pairs of
+       integer registers. *)
   method insert_op :
     Mach.operation -> Reg.t array -> Reg.t array -> Reg.t array
     (* Can be overriden to deal with 2-address instructions