Optimize : use regs for argument passing. Still has bugs.

2 files changed, 166 insertions, 79 deletions

diff --git a/src/codegen.ml b/src/codegen.ml
index 5dde4d7..5d11866 100644
--- a/src/codegen.ml
+++ b/src/codegen.ml
@@ -5,9 +5,11 @@ exception Very_bad_error of string
 
 (* Convention pour les registres :
   - a0, a1, a2, a3 : contiennent les (éventuels) 4 premiers arguments de la fonction
-  - v0 : contient la valeur de retour des fonctions
+  - v0 : contient la valeur de retour des fonctions (rien de particulier pour un constructeur)
   - v0-v1, t0-t9, s0-s1 : utilisés pour les calculs
   Tous les registres doivent être sauvés par l'appellant
+  Les registres a0, a1, a2, a3 sont susceptibles d'être modifiés par la fonction appellée.
+    **sauf dans le cas où a0 représente this** !!
 *)
 
 (* Environnement pour accéder aux variables *)
@@ -16,14 +18,23 @@ type whereis_var =
   | VStack of int (* position relative à $fp *)
   | VStackByRef of int
   | VRegister of register
+  | VRegisterByRef of register
 
 type cg_env = {
   c_penv : env;
   c_names : whereis_var Smap.t;
   c_ret_ref : bool;
   c_fp_used : int;
+  c_save_regs : register list;
 }
 
+let env_push n e =
+  { c_penv = e.c_penv;
+    c_names = e.c_names;
+    c_ret_ref = e.c_ret_ref;
+    c_fp_used = e.c_fp_used + n;
+    c_save_regs = e.c_save_regs }
+
 let globals_env = ref Smap.empty
 
 let strings = Hashtbl.create 12 (* string -> label *)
@@ -34,6 +45,32 @@ let id =
   fun prefix -> (last := !last + 1; prefix ^ (string_of_int !last))
 
 
+let rec expr_does_call e = match e.te_desc with
+  | TEInt _ | TENull | TEThis | TEIdent _ -> false
+  | TEAssign(a, b) -> expr_does_call a || expr_does_call b
+  | TECallFun (_, _, _) -> true
+  | TECallVirtual (_, _, _, _) -> true
+  | TEUnary (_, e) -> expr_does_call e
+  | TEBinary (a, _, b) -> expr_does_call a || expr_does_call b
+  | TEMember (e, _) -> expr_does_call e
+  | TEPointerCast(e, _) -> expr_does_call e
+  | TENew(_, _, _) -> true
+let rec stmt_does_call = function
+  | TSEmpty | TSReturn(None) -> false
+  | TSExpr(e) -> expr_does_call e
+  | TSIf (e, sa, sb) -> expr_does_call e || stmt_does_call sa || stmt_does_call sb
+  | TSWhile(e, s) -> expr_does_call e || stmt_does_call s
+  | TSFor(e, f, g, s) -> (List.exists expr_does_call e) || (match f with | None -> false | Some k -> expr_does_call k)
+          || (List.exists expr_does_call g) || stmt_does_call s
+  | TSBlock(k) -> List.exists stmt_does_call k
+  | TSReturn(Some k) -> expr_does_call k
+  | TSDeclare(TClass _, _) -> true
+  | TSDeclare (_, _) -> false
+  | TSDeclareAssignExpr(_, _, e) -> expr_does_call e
+  | TSDeclareAssignConstructor(_, _, _, _) -> true
+  | TSWriteCout(l) -> List.exists (function | TSEExpr e -> expr_does_call e | TSEStr _ -> false) l
+
+
 (* Génération de code des machins *)
 
 type expr_type =
@@ -50,35 +87,58 @@ let use_regs = [ v0; v1; t0; t1; t2; t3; t4; t5; t6; t7; t8; t9 ]
 let spare_reg = s0
 let spare_reg2 = s1
 
+let saver env save_regs =
+  let sc, lc, env2 = List.fold_left
+    (fun (code, more_code, env) r ->
+      let new_fp_used = env.c_fp_used + 4 in
+      let pos = - new_fp_used in
+      code ++ sw r areg (pos, fp), lw r areg (pos, fp) ++ more_code,
+      { c_penv = env.c_penv;
+        c_names = Smap.map
+          (function
+            | VRegister k when k = r -> VStack (pos)
+            | VRegisterByRef k when k = r -> VStackByRef(pos)
+            | a -> a) env.c_names;
+        c_ret_ref = env.c_ret_ref;
+        c_fp_used = new_fp_used;
+        c_save_regs = (List.filter (fun k -> k <> r) env.c_save_regs) }
+    )
+    (nop, nop, env) save_regs
+  in 
+    let d = env2.c_fp_used - env.c_fp_used in
+    (if d = 0 then nop else la sp areg (-env2.c_fp_used, fp)) ++ sc, 
+      lc ++ (if d = 0 then nop else la sp areg (-env.c_fp_used, fp)),
+      env2
 
-(* Convention : doit garder $sp invariant ; renvoie le résultat dans le premier registre de free_regs *)
+(* Convention :
+    doit garder $sp invariant ; renvoie le résultat dans le premier registre de free_regs
+    on doit toujours avoir lors d'un appel à cette fonction, $fp - env.c_fp_used = $sp
+*)
 let rec gen_expr env free_regs save_regs e =
   (* register management *)
   let r = List.hd free_regs in (* register where to put result *)
   let more = List.tl free_regs in
-  let code_save_regs = List.fold_left
-    (fun code r -> push r ++ code) nop save_regs in
-  let code_restore_regs = List.fold_left
-    (fun code r -> code ++ pop r) nop save_regs in
   (* the generator... *)
   match e.te_desc with
   | TEInt(k) -> li r k, Copy
   | TENull -> move r zero, Copy
-  | TEThis -> (* convention : this is always the last-pushed argument, so in a0 *)
-    lw r areg (8, fp), Copy
+  | TEThis -> (* convention : this is always the first argument, so in a0 *)
+    move r a0, Copy
   | TEIdent(i) ->
     begin match Smap.find i env.c_names with
     | VGlobal -> la r alab i, Addr
     | VStack(i) -> la r areg (i, fp), Addr
     | VStackByRef(i) -> lw r areg (i, fp), Addr
-    | VRegister(r) -> nop, Value r
+    | VRegister(k) -> nop, Value k
+    | VRegisterByRef(k) when k <> r -> move r k, Addr
+    | _ -> assert false
     end
   | TEAssign(e1, e2) ->
-    let t2, ae2 = gen_expr env free_regs save_regs e2 in
-    let t2 = t2 ++ cr r ae2 in
     begin match more with
     | [] ->
       let t1, ae1 = gen_expr env free_regs save_regs e1 in
+      let t2, ae2 = gen_expr (env_push 4 env) free_regs save_regs e2 in
+      let t2 = t2 ++ cr r ae2 in
       begin match ae1 with
       | Addr -> t1 ++ push r ++ t2 ++ pop spare_reg ++ sw r areg (0, spare_reg), Copy
       | Value k when t1 = nop && k <> r -> t2 ++ move k r, Copy
@@ -86,6 +146,8 @@ let rec gen_expr env free_regs save_regs e =
       end
     | b::_ ->
       let t1, ae1 = gen_expr env more (r::save_regs) e1 in
+      let t2, ae2 = gen_expr env free_regs save_regs e2 in
+      let t2 = t2 ++ cr r ae2 in
       begin match ae1 with
       | Addr -> t2 ++ t1 ++ sw r areg (0, b), Copy
       | Value k when t1 = nop && k <> r -> t2 ++ move k r, Copy
@@ -93,24 +155,18 @@ let rec gen_expr env free_regs save_regs e =
       end
     end
   | TECallFun(id, args, b) ->
-    let code = List.fold_left
-      (fun code (arg, byref) ->
-        let c, addr = gen_expr_v0 env arg in
-        assert (addr = Addr || not byref);
-        c ++ (if not byref then cr v0 addr else nop) ++ push v0 ++ code) nop args in
-    code_save_regs ++ code ++ jal id ++ popn (4 * (List.length args))
+    let code_save_regs, code_restore_regs, env_regs_saved = saver env save_regs in
+    let args_code, su = code_for_args env_regs_saved args [ a0; a1; a2; a3 ] in
+    code_save_regs ++ args_code ++ jal id ++ (if su <> 0 then popn su else nop)
       ++ (if r <> v0 then move r v0 else nop) ++ code_restore_regs, if b then Addr else Copy
   | TECallVirtual(obj, fi, args, b) ->
-    let code = List.fold_left
-      (fun code (arg, byref) ->
-        let c, addr = gen_expr_v0 env arg in
-        assert (addr = Addr || not byref);
-        c ++ (if not byref then cr v0 addr else nop) ++ push v0 ++ code) nop args in
-    let code2, a = gen_expr_v0 env obj in
+    let code_save_regs, code_restore_regs, env_regs_saved = saver env save_regs in
+    let args_code, su = code_for_args env_regs_saved args [ a1; a2; a3 ] in
+    let code2, a = gen_expr (env_push su env_regs_saved) (a0::use_regs) [] obj in
     assert (a = Addr);
     code_save_regs
-      ++ code ++ code2 ++ push v0 ++ lw v0 areg (0, v0) ++ lw v0 areg (fi, v0)
-      ++ jalr v0 ++ popn (4 * (1 + List.length args))
+      ++ args_code ++ code2 ++ lw v0 areg (0, a0) ++ lw v0 areg (fi, v0)
+      ++ jalr v0 ++ (if su <> 0 then popn su else nop)
       ++ (if r <> v0 then move r v0 else nop) ++ code_restore_regs, if b then Addr else Copy
   | TEUnary (x, e) ->
     let t, a = gen_expr env free_regs save_regs e in
@@ -150,7 +206,7 @@ let rec gen_expr env free_regs save_regs e =
   | TEBinary(e1, op, e2) when op <> Ast.Lor && op <> Ast.Land ->
     let rb, precode = match more with
     | [] ->
-      let t1, ae1 = gen_expr env free_regs save_regs e1 in
+      let t1, ae1 = gen_expr (env_push 4 env) free_regs save_regs e1 in
       let t2, ae2 = gen_expr env free_regs save_regs e2 in
       let t1 = t1 ++ cr r ae1 in
       let t2 = t2 ++ cr r ae2 in
@@ -194,16 +250,28 @@ let rec gen_expr env free_regs save_regs e =
     let c, a = gen_expr env free_regs save_regs e in
     c ++ cr r a ++ (if i = 0 then nop else la r areg (i, r)), Copy
   | TENew(cls, constr, args) ->
-    let args_code = List.fold_left
-      (fun code (arg, byref) ->
-        let c, addr = gen_expr_v0 env arg in
-        assert (addr = Addr || not byref);
-        c ++ (if not byref then cr v0 addr else nop) ++ push v0 ++ code) nop args in
+    let code_save_regs, code_restore_regs, env_regs_saved = saver env save_regs in
+    let args_code, stack_used = code_for_args env_regs_saved args [ a1; a2; a3 ] in
     let alloc = li v0 9 ++ li a0 cls.tc_size ++ syscall in
-    code_save_regs ++ args_code ++ alloc ++ push v0 ++ jal constr  
-      ++ pop r ++ popn (4 * List.length args) ++ code_restore_regs, Copy
+    code_save_regs ++ args_code ++ alloc ++ move a0 v0 ++ jal constr  
+      ++ move r a0 ++ (if stack_used <> 0 then popn stack_used else nop) ++ code_restore_regs, Copy
+and code_for_args env arg_list regs =
+  let code, _, u = List.fold_left
+    (fun (code, r, u) (arg, byref) ->
+      match r with
+      | [] ->
+        let c, addr = gen_expr (env_push u env) use_regs [] arg in
+        assert (addr = Addr || not byref);
+        c ++ (if not byref then cr v0 addr else nop) ++ push v0 ++ code, regs, u + 4
+      | reg::more_regs ->
+        let c, addr = gen_expr (env_push u env) (reg::use_regs) [] arg in
+        assert (addr = Addr || not byref);
+        c ++ (if not byref then cr reg addr else nop) ++ code, more_regs, u
+    ) (nop, regs, 0) arg_list
+  in code, u
+  
 
-and gen_expr_v0 env = gen_expr env use_regs []
+let gen_expr_v0 env = gen_expr env use_regs env.c_save_regs
     
 
 let rec gen_stmt env = function
@@ -212,7 +280,7 @@ let rec gen_stmt env = function
     comment "expr" ++ (fst (gen_expr_v0 env e)), nop, env
   | TSIf(cond, s1, s2) ->
     let c, a = gen_expr_v0 env cond in
-    let l_else = id "_cond_then" in
+    let l_else = id "_cond_else" in
     let l_end = id "_cond_end" in
     let c_then, d_then, _ = gen_stmt env s1 in
     let c_else, d_else, _ = gen_stmt env s2 in
@@ -256,47 +324,48 @@ let rec gen_stmt env = function
     | TClass(i) ->
       let c = get_c env.c_penv i in
       let cproto = List.find (fun p -> p.tp_ret_type = None && p.tp_name =  i && p.tp_args = []) c.tc_methods in
-      sub sp sp oi s ++
-      la v0 areg (pos, fp) ++
-      push v0 ++
+      la sp areg (pos, fp) ++
+      la a0 areg (pos, fp) ++
       jal cproto.tp_unique_ident
-    | _ -> push zero
+    | _ -> la sp areg (pos, fp) ++ sw zero areg (0, sp)
     in
     comment ("declare " ^ id) ++ code, nop, {
       c_penv = env.c_penv;
       c_names = Smap.add id (VStack pos) env.c_names;
       c_ret_ref = env.c_ret_ref;
-      c_fp_used = new_fp_used }
+      c_fp_used = new_fp_used;
+      c_save_regs = env.c_save_regs }
   | TSDeclareAssignConstructor(cls, id, constr, args) ->
     let new_fp_used = env.c_fp_used + cls.tc_size in
     let pos = - new_fp_used in
     let code =
-      let args_code = List.fold_left
-        (fun code (arg, byref) ->
-          let c, addr = gen_expr_v0 env arg in
-          assert (addr = Addr || not byref);
-          c ++ (if not byref then cr v0 addr else nop) ++ push v0 ++ code) nop args in
-      sub sp sp oi cls.tc_size ++ args_code ++ la v0 areg(pos, fp) ++ push v0 ++ jal constr ++
-          popn (4 * (List.length args + 1))
+      let code_save_regs, code_restore_regs, env_regs_saved = saver (env_push cls.tc_size env) env.c_save_regs in
+      let args_code, su = code_for_args env_regs_saved args [ a1; a2; a3 ] in
+      la sp areg (pos, fp) ++ code_save_regs ++ args_code ++ la a0 areg(pos, fp) ++ jal constr ++
+        (if su <> 0 then popn su else nop) ++ code_restore_regs
     in
     comment ("declare " ^ id) ++ code, nop, {
       c_penv = env.c_penv;
       c_names = Smap.add id (VStack pos) env.c_names;
       c_ret_ref = env.c_ret_ref;
+      c_save_regs = env.c_save_regs;
       c_fp_used = new_fp_used; }
   | TSDeclareAssignExpr ((ty, ref), id, e) ->
     let s = if ref then 4 else type_size env.c_penv ty in
     assert (s = 4);
     let new_fp_used = env.c_fp_used + 4 in
     let pos = - new_fp_used in
-    let code, a = gen_expr_v0 env e in
+    let code, a = gen_expr_v0 (env_push 4 env) e in
     assert (a = Addr || not ref);
-    comment ("declare " ^ id) ++ sub sp sp oi 4 ++ code ++ (if not ref then cr v0 a else nop) ++ sw v0 areg (pos, fp), nop, {
-      c_penv = env.c_penv;
+    comment ("declare " ^ id) ++ la sp areg (pos, fp) ++ code ++ (if not ref then cr v0 a else nop) ++ sw v0 areg (pos, fp), nop,
+    { c_penv = env.c_penv;
       c_names = Smap.add id (if ref then VStackByRef pos else VStack pos) env.c_names;
       c_ret_ref = env.c_ret_ref;
-      c_fp_used = new_fp_used }
+      c_fp_used = new_fp_used;
+      c_save_regs = env.c_save_regs }
   | TSWriteCout(sl) ->
+    let save = List.mem a0 env.c_save_regs in
+    let env = if save then env_push 4 env else env in
     let text1, data1 = List.fold_left
       (fun (text, data) s ->
         match s with
@@ -312,7 +381,7 @@ let rec gen_stmt env = function
               l, label l ++ asciiz s
           in
             text ++ la a0 alab l ++ li v0 4 ++ syscall, data ++ d) (nop, nop) sl in
-    comment "cout<<..." ++ text1, data1, env
+    comment "cout<<..." ++ (if save then push a0 else nop) ++ text1 ++ (if save then pop a0 else nop), data1, env
 and gen_block env b =
   let text, data, fin_env =
     List.fold_left (fun (t, d, e) s ->
@@ -321,7 +390,7 @@ and gen_block env b =
       (nop, nop, env) b
   in
     let n = (fin_env.c_fp_used - env.c_fp_used) in
-    text ++ (if n = 0 then nop else popn n), data
+    text ++ (if n = 0 then nop else la sp areg (-env.c_fp_used, fp)), data
 
 let gen_decl tenv decl = match decl with
   | TDGlobal(ty, id) ->
@@ -329,29 +398,45 @@ let gen_decl tenv decl = match decl with
     let bytes = type_size tenv ty in
     nop, (label id) ++ (dword (let rec a n = if n > 0 then 0::(a (n-4)) else [] in a bytes))
   | TDFunction(proto, block) ->
-    let names, _ = List.fold_left 
-            (fun (env, p) ((ty, r), id) -> 
-              Smap.add id (if r then VStackByRef p else VStack p) env, p + (type_size tenv ty)) 
-            (!globals_env, (match proto.tp_class with | None -> 8 | Some k -> 12)) proto.tp_args in
+    let regs_for_args = match proto.tp_class with | None -> [ a0; a1; a2; a3 ] | Some k -> [ a1; a2; a3 ] in
+    let names, _, free_regs = List.fold_left 
+            (fun (env, p, regs) ((ty, r), id) -> 
+              let s = (if r then 4 else type_size tenv ty) in
+              assert (s = 4);
+              match regs with
+              | reg::more_regs ->
+                Smap.add id (if r then VRegisterByRef reg else VRegister reg) env, p, more_regs
+              | _ -> Smap.add id (if r then VStackByRef p else VStack p) env, p + 4, regs
+            )
+            (!globals_env, 0, regs_for_args) proto.tp_args in
     let env = {
       c_penv = tenv;
       c_names = names;
       c_ret_ref = (match proto.tp_ret_type with | None -> false | Some(_, r) -> r);
-      c_fp_used = 0;
+      c_fp_used = 8;
+      c_save_regs = List.filter (fun r -> not (List.mem r free_regs)) [a0; a1; a2; a3];
       } in
-    let code_for_constructor = match proto.tp_ret_type with
-      | Some _ -> nop
+    let save_code, unsave_code, env2 = saver env (List.filter (fun x -> x <> a0 || proto.tp_class = None) env.c_save_regs) in
+    let code_for_constructor, does_calls = match proto.tp_ret_type with
+      | Some _ -> nop, (List.exists stmt_does_call block)
       | None -> let cls_name = (match proto.tp_class with | Some k -> k | None -> assert false) in
-        lw v0 areg (8, fp) ++ jal ("_c_" ^ cls_name) in
+        jal (cls_name ^ "0"), true in
     let code_for_virtual = match proto.tp_virtual with
       | Some (c, _) when c.h_pos <> 0 ->
-        lw a0 areg (8, fp) ++ la a0 areg (-c.h_pos, a0) ++ sw a0 areg (8, fp)
+        la a0 areg (-c.h_pos, a0)
       | _ -> nop
     in
-    let text, data = gen_block env block in 
-    label proto.tp_unique_ident ++
-    push fp ++ push ra ++ move fp sp ++ code_for_constructor ++ code_for_virtual ++
-    text ++ b "_return", data
+    let code1 = 
+      label proto.tp_unique_ident ++
+      sw fp areg (-4, sp) ++ sw ra areg (-8, sp) ++ move fp sp ++ la sp areg (-8, fp)
+    in
+    if does_calls 
+      then
+        let text, data = gen_block env2 block in 
+        code1 ++ code_for_virtual ++ save_code ++ text ++ b "_return", data
+      else
+        let text, data = gen_block env block in 
+        code1 ++ code_for_constructor ++ code_for_virtual ++ text ++ b "_return", data
   | TDClass(c) ->
     let calls_something = ref false in
     (* Call default constructor of parent classes *)
@@ -361,9 +446,11 @@ let gen_decl tenv decl = match decl with
           let c = get_c tenv cn in
           let proto = List.find (fun p -> p.tp_ret_type = None && p.tp_args = [] && p.tp_name = cn) c.tc_methods in
           calls_something := true;
-          code ++ lw v0 areg(0, sp) ++ la v0 areg(parent.h_pos, v0) ++push v0 ++ jal proto.tp_unique_ident ++ popn 4)
+          code ++ (if parent.h_pos <> 0 then la a0 areg(parent.h_pos, a0) else nop)
+            ++ jal proto.tp_unique_ident ++ (if parent.h_pos <> 0 then lw a0 areg(0, sp) else nop)
+      )
       nop c.tc_hier.h_supers in
-    let code_parents = if code_parents <> nop then push v0 ++ code_parents ++ pop v0 else nop in
+    let code_parents = if code_parents <> nop then push a0 ++ code_parents ++ popn 4 else nop in
     (* Build vtables and build constructor *)
     let rec make_vtables hh =
       (* calculate vtable contents *)
@@ -379,8 +466,8 @@ let gen_decl tenv decl = match decl with
       let constructor_code = 
         if vt_l = []
           then nop
-          else la a0 alab ("_vt_" ^ c.tc_name ^ "_as_" ^ hh.h_class)
-            ++ sw a0 areg (hh.h_pos, v0) in
+          else la a1 alab ("_vt_" ^ c.tc_name ^ "_as_" ^ hh.h_class)
+            ++ sw a1 areg (hh.h_pos, a0) in
       (* code for subclasses vtable initialization *)
       List.fold_left
           (fun (vt, cc) sup ->
@@ -397,13 +484,13 @@ let gen_decl tenv decl = match decl with
             let cs = get_c tenv s in
             let proto = List.find (fun p -> p.tp_ret_type = None && p.tp_args = [] && p.tp_name = s) cs.tc_methods in
             calls_something := true;
-            push v0 ++
-              la a0 areg (pos, v0) ++ push a0 ++
-               jal proto.tp_unique_ident ++ popn 4 ++ pop v0
-          | _ -> sw zero areg (pos, v0)
+            push a0 ++
+              (if pos <> 0 then la a0 areg (pos, a0) else nop) ++
+               jal proto.tp_unique_ident ++ pop a0
+          | _ -> sw zero areg (pos, a0)
         ) ++ code) c.tc_members nop 
     in (* Put it all together *)
-      label (c.tc_name ^ "0") ++ lw v0 areg (0, sp) ++ label ("_c_" ^ c.tc_name) 
+      label (c.tc_name ^ "0")
           ++ (if !calls_something then push ra else nop)
           ++ code_parents ++ vtable_init_code ++ init_code_proper
           ++ (if !calls_something then pop ra else nop) ++ jr ra, vtables
@@ -417,7 +504,7 @@ let generate p =
     let text =
       label "main" ++ jal p.prog_main ++
       li v0 10 ++ syscall ++
-      label "_return" ++ move sp fp ++ pop ra ++ pop fp ++
+      label "_return" ++ move sp fp ++ lw fp areg (-4, sp) ++ lw ra areg (-8, sp) ++
       label "_nothing" ++ jr ra ++
       text in
     { text = text;
diff --git a/src/typing.ml b/src/typing.ml
index a405855..966057c 100644
--- a/src/typing.ml
+++ b/src/typing.ml
@@ -715,16 +715,16 @@ let compute_tclass env c =
             tp_args = [] }::meth
     in
     (* if vtable is empty, remove it *)
-    let mem =
+    let mem, mem_u =
       if hier.h_vtable = [] then
         let rec mv_h h =
           h.h_pos <- h.h_pos - 4;
           List.iter mv_h h.h_supers
         in
           List.iter mv_h hier.h_supers;
-        Smap.map (fun (ty, pos) -> (ty, pos-4)) mem
+        Smap.map (fun (ty, pos) -> (ty, pos-4)) mem, mem_u - 4
       else
-        mem
+        mem, mem_u
     in
     {   tc_name = cls_name;
         tc_size = mem_u;