1 files changed, 342 insertions, 2 deletions

diff --git a/src/codegen.ml b/src/codegen.ml
index 2709526..b1501fd 100644
--- a/src/codegen.ml
+++ b/src/codegen.ml
@@ -1,6 +1,346 @@
 open Mips
+open Typing
+
+exception Very_bad_error of string
+
+(* Environnement pour accéder aux variables *)
+type whereis_var =
+  | VGlobal
+  | VStack of int (* position relative à $fp *)
+  | VStackByRef of int
+
+type cg_env = {
+  c_penv : env;
+  c_names : whereis_var Smap.t;
+  c_ret_ref : bool;
+  c_fp_used : int;
+}
+
+let globals_env = ref Smap.empty
+
+let strings = Hashtbl.create 12 (* string -> label *)
+
+(* Identifiants uniques pour les machins - essentiellement labels *)
+let id =
+  let last = ref 0 in
+  fun prefix -> (last := !last + 1; prefix ^ (string_of_int !last))
+
+
+(* Génération de code des machins *)
+
+let cr a = if a then lw a0 areg (0, a0) else nop (* conditionnally read *)
+
+(* Convention : doit garder $sp invariant *)
+let rec gen_expr env e = match e.te_desc with
+  | TEInt(k) -> li a0 k, false
+  | TENull -> move a0 zero, false
+  | TEThis -> (* convention : this is always the last-pushed argument *)
+    lw a0 areg (8, fp), false
+  | TEIdent(i) ->
+    begin match Smap.find i env.c_names with
+    | VGlobal -> la a0 alab i, true
+    | VStack(i) -> la a0 areg (i, fp), true
+    | VStackByRef(i) -> lw a0 areg (i, fp), true
+    end
+  | TEAssign(e1, e2) ->
+    let t1, ae1 = gen_expr env e1 in
+    assert ae1;
+    let t2, ae2 = gen_expr env e2 in
+    t1 ++ push a0 ++ t2 ++ cr ae2 ++ pop a1 ++ sw a0 areg (0, a1), false
+  | TECallFun(id, args, b) ->
+    let code = List.fold_left
+      (fun code (arg, byref) ->
+        let c, r = gen_expr env arg in
+        assert (r || not byref);
+        c ++ cr (r && not byref) ++ push a0 ++ code) nop args in
+    code ++ jal id ++ popn (4 * (List.length args)), b
+  | TECallVirtual(obj, fi, args, b) ->
+    let code = List.fold_left
+      (fun code (arg, byref) ->
+        let c, r = gen_expr env arg in
+        assert (r || not byref);
+        c ++ cr (r && not byref) ++ push a0 ++ code) nop args in
+    let code2, a = gen_expr env obj in
+    assert a;
+    code ++ code2 ++ push a0 ++ lw a0 areg (0, a0) ++ lw a0 areg (fi, a0)
+      ++ jalr a0 ++ popn (4 * (1 + List.length args)), b
+  | TEUnary (x, e) ->
+    let t, a = gen_expr env e in
+    begin match x with
+    | Ast.Deref -> t ++ cr a, true
+    | Ast.Ref -> assert a; t, false
+    | Ast.Plus -> t ++ cr a, false
+    | Ast.Minus -> t ++ cr a ++ neg a0 a0, false
+    | Ast.Not -> t ++ cr a ++ not_ a0 a0, false
+    | Ast.PreIncr -> assert a; t ++ lw a1 areg (0, a0) ++ add a1 a1 oi 1 ++ sw a1 areg (0, a0), true
+    | Ast.PreDecr -> assert a; t ++ lw a1 areg (0, a0) ++ sub a1 a1 oi 1 ++ sw a1 areg (0, a0), true
+    | Ast.PostIncr -> assert a; t ++ move a1 a0 ++ lw a2 areg(0, a1) ++ move a0 a2 ++
+          add a2 a2 oi 1 ++ sw a2 areg(0, a1), false
+    | Ast.PostDecr -> assert a; t ++ move a1 a0 ++ lw a2 areg(0, a1) ++ move a0 a2 ++
+          sub a2 a2 oi 1 ++ sw a2 areg(0, a1), false
+    end
+  | TEBinary(e1, op, e2) ->
+    let t1, ae1 = gen_expr env e1 in
+    let t2, ae2 = gen_expr env e2 in
+    let t1 = t1 ++ cr ae1 in
+    let t2 = t2 ++ cr ae2 in
+    (
+      match op with
+      | Ast.Add -> t1 ++ push a0 ++ t2 ++ pop a1 ++ add a0 a1 oreg a0
+      | Ast.Sub -> t1 ++ push a0 ++ t2 ++ pop a1 ++ sub a0 a1 oreg a0
+      | Ast.Mul -> t1 ++ push a0 ++ t2 ++ pop a1 ++ mul a0 a1 oreg a0
+      | Ast.Div -> t1 ++ push a0 ++ t2 ++ pop a1 ++ div a0 a1 oreg a0
+      | Ast.Modulo -> t1 ++ push a0 ++ t2 ++ pop a1 ++ rem a0 a1 oreg a0
+      | Ast.Equal -> t1 ++ push a0 ++ t2 ++ pop a1 ++ seq a0 a1 a0
+      | Ast.NotEqual -> t1 ++ push a0 ++ t2 ++ pop a1 ++ sne a0 a1 a0
+      | Ast.Lt -> t1 ++ push a0 ++ t2 ++ pop a1 ++ slt a0 a1 a0
+      | Ast.Le -> t1 ++ push a0 ++ t2 ++ pop a1 ++ sle a0 a1 a0
+      | Ast.Gt -> t1 ++ push a0 ++ t2 ++ pop a1 ++ sgt a0 a1 a0
+      | Ast.Ge -> t1 ++ push a0 ++ t2 ++ pop a1 ++ sge a0 a1 a0
+      | Ast.Land -> 
+        let lazy_lbl = id "_lazy" in
+        t1 ++ beqz a0 lazy_lbl ++ t2 ++ label lazy_lbl ++ sne a0 a0 zero
+      | Ast.Lor -> 
+        let lazy_lbl = id "_lazy" in
+        t1 ++ bnez a0 lazy_lbl ++ t2 ++ label lazy_lbl ++ sne a0 a0 zero
+    ), false
+  | TEMember(e, i) ->
+    let c, a = gen_expr env e in
+    if i <> 0 then begin
+      assert a;
+      c ++ la a0 areg (i, a0), true
+    end else
+      c, a
+  | TEPointerCast(e, i) ->
+    let c, a = gen_expr env e in
+    c ++ cr a ++ (if i = 0 then nop else la a0 areg (i, a0)), false
+  | TENew(cls, constr, args) ->
+    let args_code = List.fold_left
+      (fun code (arg, byref) ->
+        let c, r = gen_expr env arg in
+        assert (r || not byref);
+        c ++ cr (r && not byref) ++ push a0 ++ code) nop args in
+    let alloc = li v0 9 ++ li a0 cls.tc_size ++ syscall in
+    args_code ++ alloc ++ push v0 ++ jal constr  
+      ++ pop a0 ++ popn (4 * List.length args), false
+    
+
+let rec gen_stmt env = function
+  | TSEmpty -> nop, nop, env
+  | TSExpr(e) ->
+    comment "expr" ++ (fst (gen_expr env e)), nop, env
+  | TSIf(cond, s1, s2) ->
+    let c, a = gen_expr env cond in
+    let l_else = id "_cond_then" 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
+    comment "if" ++ c ++ cr a ++ beqz a0 l_else ++ c_then ++ b l_end ++
+      label l_else ++ c_else ++ label l_end, d_then ++ d_else, env
+  | TSWhile(cond, body) ->
+    let c, a = gen_expr env cond in
+    let l_begin = id "_while_begin" in
+    let l_cond = id "_while_cond" in
+    let c_body, d_body, _ = gen_stmt env body in
+    comment "while" ++ b l_cond ++ label l_begin ++ c_body ++
+      label l_cond ++ c ++ cr a ++ bnez a0 l_begin, d_body, env
+  | TSFor(before, cond, after, body) ->
+    let l_begin = id "_for_begin" in
+    let l_cond = id "_for_cond" in
+    let c_before = List.fold_left
+      (fun code expr -> let c, _ = gen_expr env expr in code ++ c) nop before in
+    let c_after = List.fold_left
+      (fun code expr -> let c, _ = gen_expr env expr in code ++ c) nop after in
+    let c_cond = match cond with
+      | None -> b l_begin
+      | Some x -> let c, a = gen_expr env x in
+        c ++ cr a ++ bnez a0 l_begin in
+    let c_body, d_body, _ = gen_stmt env body in
+    comment "for" ++ c_before ++ b l_cond ++ label l_begin ++ c_body ++ c_after ++ label l_cond
+      ++ c_cond, d_body, env
+  | TSBlock(b) ->
+    let c, d = gen_block env b in
+    comment "block" ++ c, d, env
+  | TSReturn (None) ->
+    comment "return" ++ b "_return", nop, env
+  | TSReturn (Some e) ->
+    let c, a = gen_expr env e in
+    assert (a || not env.c_ret_ref);
+    comment "return" ++ c ++ cr (not env.c_ret_ref && a) ++ b "_return", nop, env
+  | TSDeclare (ty, id) ->
+    let s = type_size env.c_penv ty in
+    let new_fp_used = env.c_fp_used + s in
+    let pos = - new_fp_used in
+    let code = match ty with
+    | 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 a0 areg (pos, fp) ++
+      push a0 ++
+      jal cproto.tp_unique_ident
+    | _ -> push zero
+    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 }
+  | 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, r = gen_expr env arg in
+          assert (r || not byref);
+          c ++ cr (r && not byref) ++ push a0 ++ code) nop args in
+      sub sp sp oi cls.tc_size ++ args_code ++ la a0 areg(pos, fp) ++ push a0 ++ jal constr ++
+          popn (4 * (List.length args + 1))
+    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; }
+  | TSDeclareAssignExpr ((ty, r), id, e) ->
+    let s = if r 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 env e in
+    assert (a || not r);
+    comment ("declare " ^ id) ++ sub sp sp oi 4 ++ code ++ cr (a && not r) ++ sw a0 areg (pos, fp), nop, {
+      c_penv = env.c_penv;
+      c_names = Smap.add id (if r then VStackByRef pos else VStack pos) env.c_names;
+      c_ret_ref = env.c_ret_ref;
+      c_fp_used = new_fp_used }
+  | TSWriteCout(sl) ->
+    let text1, data1 = List.fold_left
+      (fun (text, data) s ->
+        match s with
+        | TSEExpr(e) ->
+          let t, a = gen_expr env e in
+          text ++ t ++ cr a ++  li v0 1 ++ syscall, data
+        | TSEStr(s) ->
+          let l, d =
+            if Hashtbl.mem strings s then
+              Hashtbl.find strings s, nop
+            else
+              let l = id "_s" in Hashtbl.add strings s l;
+              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
+and gen_block env b =
+  let text, data, fin_env =
+    List.fold_left (fun (t, d, e) s ->
+        let tt, dd, e = gen_stmt e s in
+          t ++ tt, d ++ dd, e)
+      (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
+
+let gen_decl tenv decl = match decl with
+  | TDGlobal(ty, id) ->
+    globals_env := Smap.add id VGlobal !globals_env;
+    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 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;
+      } in
+    let code_for_constructor = match proto.tp_ret_type with
+      | Some _ -> nop
+      | 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
+    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)
+      | _ -> 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
+  | TDClass(c) ->
+    (* Call default constructor of parent classes *)
+    let code_parents = List.fold_left
+      (fun code parent ->
+          let cn = parent.h_class in
+          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
+          code ++ lw v0 areg(0, sp) ++ la v0 areg(parent.h_pos, v0) ++push v0 ++ jal proto.tp_unique_ident ++ popn 4)
+      nop c.tc_hier.h_supers in
+    let code_parents = if code_parents <> nop then push v0 ++ code_parents ++ pop v0 else nop in
+    (* Build vtables and build constructor *)
+    let rec make_vtables hh =
+      (* calculate vtable contents *)
+      let vtable_size = List.fold_left (fun k (p, _) -> max k (p+4)) 0 hh.h_vtable in
+      let vtable_as_array = Array.make (vtable_size / 4) "_nothing" in
+      List.iter (fun (p, s) -> vtable_as_array.(p/4) <- s.tp_unique_ident) hh.h_vtable;
+      let vt_l = Array.to_list vtable_as_array in
+      (* code for vtable initialization *)
+      let vtable =
+        if vt_l = [] 
+          then nop 
+          else label ("_vt_" ^ c.tc_name ^ "_as_" ^ hh.h_class) ++ address vt_l in
+      let constructor_code = 
+        if vt_l = []
+          then sw zero areg (hh.h_pos, v0)
+          else la a0 alab ("_vt_" ^ c.tc_name ^ "_as_" ^ hh.h_class)
+            ++ sw a0 areg (hh.h_pos, v0) in
+      (* code for subclasses initialization *)
+      List.fold_left
+          (fun (vt, cc) sup ->
+            let mvt, mcc = make_vtables sup in
+            vt ++ mvt, cc ++ mcc)
+          (vtable, constructor_code) hh.h_supers
+    in
+    let vtables, vtable_init_code = make_vtables c.tc_hier in
+    let init_code_proper = Smap.fold
+      (fun _ (ty, pos) code ->
+        (match ty with
+          | TClass(s) ->
+            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
+            push v0 ++
+              la a0 areg (pos, v0) ++ push a0 ++
+               jal proto.tp_unique_ident ++ popn 4 ++ pop v0
+          | _ -> sw zero areg (pos, v0)
+        ) ++ code) c.tc_members nop 
+    in
+      label (c.tc_name ^ "0") ++ lw v0 areg (0, sp) ++ label ("_c_" ^ c.tc_name) 
+          ++ push ra ++ code_parents ++ vtable_init_code ++ init_code_proper ++ pop ra ++ jr ra, vtables
 
 
 let generate p =
-  { text = nop;
-    data = nop }
+  try 
+    let text, data = List.fold_left (fun (text, data) decl ->
+        let more_text, more_data = gen_decl p.prog_env decl in
+        text ++ more_text, data ++ more_data) (nop, nop) p.prog_decls in
+    let text =
+      label "main" ++ jal p.prog_main ++
+      li v0 10 ++ syscall ++
+      label "_return" ++ move sp fp ++ pop ra ++ pop fp ++
+      label "_nothing" ++ jr ra ++
+      text in
+    { text = text;
+      data = data }
+  with
+  | Assert_failure (k, a, b) -> raise (Very_bad_error (
+        "(unexpected) Assertion failure: "^k^" at "^(string_of_int a)^":"^(string_of_int b)))
+  | Not_found -> raise (Very_bad_error ("(unexpected) Not found"))
+  | Invalid_argument(k) -> raise (Very_bad_error ("(unexpected) Invalid argument: "^k))
+  | Match_failure(k, a, b) -> raise (Very_bad_error (
+      "(unexpected) Match failure: "^k^" at "^(string_of_int a)^":"^(string_of_int b)))
+  | Stack_overflow -> raise (Very_bad_error ("(unexpected) Stack overflow"))
+  | _ -> raise (Very_bad_error ("(unexpected) Other error"))