diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/codegen.ml | 239 | ||||
| -rw-r--r-- | src/typing.ml | 6 |
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; |