diff options
| -rw-r--r-- | src/codegen.ml | 204 |
1 files changed, 108 insertions, 96 deletions
diff --git a/src/codegen.ml b/src/codegen.ml index cccf83c..5042339 100644 --- a/src/codegen.ml +++ b/src/codegen.ml @@ -155,7 +155,7 @@ let spare_reg2 = s1 soient maintenant fait en prenant en compte la relocalisation de ces valeurs sur la pile. *) let saver env save_regs = - let save_code, load_code, env2 = List.fold_left + 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 @@ -174,8 +174,6 @@ let saver env save_regs = c_save_regs = (List.filter (fun k -> k <> r) env.c_save_regs) } ) (nop, nop, env) save_regs - in - save_code, load_code, env2 (* renvoie le résultat dans le premier registre de free_regs @@ -185,7 +183,7 @@ 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 - (* the generator... *) + (* generate the code... *) match e.te_desc with | TEInt(k) -> li r k, Copy | TENull -> nop, Value zero @@ -265,36 +263,33 @@ let rec gen_expr env free_regs save_regs e = | Ast.Plus -> t ++ cr r a, Copy | Ast.Minus -> t ++ cr r a ++ neg r r, Copy | Ast.Not -> t ++ cr r a ++ not_ r r, Copy - | Ast.PreIncr -> + | Ast.PreIncr | Ast.PreDecr -> + let delta = if x = Ast.PreIncr then 1 else -1 in begin match a with - | Addr -> t ++ lw spare_reg areg (0, r) ++ add spare_reg spare_reg oi 1 ++ sw spare_reg areg (0, r), Addr - | AddrByReg (k, rg) when t = nop -> t ++ lw r areg (k, rg) ++ add r r oi 1 ++ sw r areg (k, rg), Copy - | Value v when t = nop && v <> r -> add v v oi 1 ++ move r v, Copy + | Addr -> + t ++ move spare_reg r ++ lw r areg (0, spare_reg) + ++ add r r oi delta ++ sw r areg (0, spare_reg), Copy + | AddrByReg (k, rg) when t = nop && r <> rg -> + lw r areg (k, rg) + ++ add r r oi delta ++ sw r areg (k, rg), Copy + | Value v when t = nop && v <> r -> + add v v oi delta ++ move r v, Copy | _ -> assert false end - | Ast.PreDecr -> + | Ast.PostIncr | Ast.PostDecr -> + let delta = if x = Ast.PostIncr then 1 else -1 in begin match a with - | Addr -> t ++ lw spare_reg areg (0, r) ++ sub spare_reg spare_reg oi 1 ++ sw spare_reg areg (0, r), Addr - | AddrByReg (k, rg) when t = nop -> lw r areg (k, rg) ++ sub r r oi 1 ++ sw r areg (k, rg), Copy - | Value v when t = nop && v <> r -> sub v v oi 1 ++ move r v, Copy - | _ -> assert false - end - | Ast.PostIncr -> - begin match a with - | Addr -> t ++ move spare_reg r ++ lw spare_reg2 areg(0, spare_reg) ++ move r spare_reg2 ++ - add spare_reg2 spare_reg2 oi 1 ++ sw spare_reg2 areg(0, spare_reg), Copy - | AddrByReg (k, rg) when t = nop -> - lw r areg (k, rg) ++ add spare_reg r oi 1 ++ sw spare_reg areg (k, rg), Copy - | Value v when t = nop && v <> r -> move r v ++ add v v oi 1, Copy - | _ -> assert false - end - | Ast.PostDecr -> - begin match a with - | Addr -> t ++ move spare_reg r ++ lw spare_reg2 areg(0, spare_reg) ++ move r spare_reg2 ++ - sub spare_reg2 spare_reg2 oi 1 ++ sw spare_reg2 areg(0, spare_reg), Copy - | AddrByReg (k, rg) when t = nop -> - lw r areg (k, rg) ++ sub spare_reg r oi 1 ++ sw spare_reg areg (k, rg), Copy - | Value v when t = nop && v <> r -> move r v ++ sub v v oi 1, Copy + | Addr -> + t ++ move spare_reg r + ++ lw r areg(0, spare_reg) + ++ add spare_reg2 r oi delta + ++ sw spare_reg2 areg(0, spare_reg), Copy + | AddrByReg (k, rg) when t = nop && r <> rg -> + lw r areg (k, rg) + ++ add spare_reg r oi delta + ++ sw spare_reg areg (k, rg), Copy + | Value v when t = nop && v <> r -> + move r v ++ add v v oi delta, Copy | _ -> assert false end end @@ -304,9 +299,9 @@ let rec gen_expr env free_regs save_regs e = let env2, tspot = env_push 4 env in let t1, ae1 = gen_expr env2 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 - r, spare_reg, t2 ++ sw r areg (tspot, fp) ++ t1 ++ lw spare_reg areg (tspot, fp) + let t1, r1 = crb r t1 ae1 in + let t2, r2 = crb r t2 ae2 in + r1, spare_reg, t2 ++ sw r2 areg (tspot, fp) ++ t1 ++ lw spare_reg areg (tspot, fp) | b::_ -> let t1, ae1 = gen_expr env free_regs save_regs e1 in let t2, ae2 = gen_expr env more (r::save_regs) e2 in @@ -334,7 +329,8 @@ let rec gen_expr env free_regs save_regs e = let t1 = t1 ++ cr r ae1 in let t2 = t2 ++ cr r ae2 in let lazy_lbl = id "_lazy" in - t1 ++ (if op = Ast.Lor then bnez r lazy_lbl else beqz r lazy_lbl) ++ t2 ++ label lazy_lbl ++ sne r r zero, Copy + t1 ++ (if op = Ast.Lor then bnez r lazy_lbl else beqz r lazy_lbl) + ++ t2 ++ label lazy_lbl ++ sne r r zero, Copy | TEMember(e, i) -> let c, a = gen_expr env free_regs save_regs e in if i <> 0 then begin @@ -352,8 +348,8 @@ let rec gen_expr env free_regs save_regs e = let args_code, _, env_args = code_for_args env_regs_saved args [ a1; a2; a3 ] in code_save_regs ++ args_code ++ li v0 9 ++ li a0 cls.tc_size ++ syscall ++ move a0 v0 - ++ la sp areg (-env_args.c_fp_used, fp) ++ jal constr ++ (if r <> a0 then move r a0 else nop) - ++ code_restore_regs, Copy + ++ la sp areg (-env_args.c_fp_used, fp) ++ jal constr + ++ (if r <> a0 then move r a0 else nop) ++ code_restore_regs, Copy and code_for_args env arg_list regs = (* assigne registers to possibly in-register arguments *) let args_in_regs, args_in_stack, _ = List.fold_left @@ -392,8 +388,8 @@ and code_for_args env arg_list regs = c ++ cla reg addr ++ sw reg areg (pos, fp) else let tt, r2 = crb reg c addr in - tt ++ sw r2 areg (pos, fp) - ) ++ (mk_code_callz e2 more_args) ++ lw reg areg (pos, fp) + tt ++ sw r2 areg (pos, fp)) + ++ (mk_code_callz e2 more_args) ++ lw reg areg (pos, fp) in let code_reg_do_call = mk_code_callz kenv arg_reg_do_call in let code_reg_dont_call, _ = @@ -416,7 +412,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 code, reg = crb v0 c a in + let c, reg = crb v0 c a 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 @@ -428,12 +424,13 @@ let rec gen_stmt env = function ++ label l_end, d_then ++ d_else, env | TSWhile(cond, body) -> let c, a = gen_expr_v0 env cond in + let c, reg = crb v0 c a 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 v0 a ++ bnez v0 l_begin, d_body, env + ++ label l_cond ++ c ++ bnez reg l_begin, d_body, env | TSFor(before, cond, after, body) -> let l_begin = id "_for_begin" in let l_cond = id "_for_cond" in @@ -443,8 +440,10 @@ let rec gen_stmt env = function (fun code expr -> let c, _ = gen_expr_v0 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_v0 env x in - c ++ cr v0 a ++ bnez v0 l_begin in + | Some x -> + let c, a = gen_expr_v0 env x in + let c, reg = crb v0 c a in + c ++ bnez reg l_begin in let c_body, d_body, _ = gen_stmt env body in comment "for" ++ c_before ++ b l_cond @@ -457,8 +456,8 @@ let rec gen_stmt env = function comment "return" ++ b env.c_ret_lbl, nop, env | TSReturn (Some e) -> let c, a = gen_expr_v0 env e in - comment "return" ++ c - ++ (if env.c_ret_ref then cla v0 a else cr v0 a) + comment "return" + ++ c ++ (if env.c_ret_ref then cla v0 a else cr v0 a) ++ b env.c_ret_lbl, nop, env | TSDeclare (ty, id) -> let s = type_size env.c_penv ty in @@ -503,10 +502,10 @@ let rec gen_stmt env = function ), nop, env_add_var id (if ref then VStackByRef pos else VStack pos) env2 | TSWriteCout(sl) -> - let save_code, restore_code, env2 = saver env (if List.mem a0 env.c_save_regs then [a0] else []) in + let save_code, restore_code, env2 = saver env + (if List.mem a0 env.c_save_regs then [a0] else []) in let text1, data1 = List.fold_left - (fun (text, data) s -> - match s with + (fun (text, data) -> function | TSEExpr(e) -> let t, a = gen_expr env2 (a0::use_regs) (env2.c_save_regs) e in text ++ t ++ cr a0 a ++ li v0 1 ++ syscall, data @@ -518,13 +517,15 @@ let rec gen_stmt env = function 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<<..." ++ save_code ++ text1 ++ restore_code, data1, env + text ++ la a0 alab l ++ li v0 4 ++ syscall, data ++ d) + (nop, nop) sl in + comment "cout<<..." + ++ save_code ++ text1 ++ restore_code, 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) + let tt, dd, ee = gen_stmt e s in + t ++ tt, d ++ dd, ee) (nop, nop, env) b in text, data @@ -535,20 +536,21 @@ 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 regs_for_args = match proto.tp_class with | None -> [ a0; a1; a2; a3 ] | Some k -> [ a1; a2; a3 ] in - let env0 = match proto.tp_class with | None -> !globals_env | Some _ -> Smap.add "this" (VRegister a0) !globals_env in + let regs_for_args, env0 = match proto.tp_class with + | None -> [ a0; a1; a2; a3 ], !globals_env + | Some k -> [ a1; a2; a3 ], Smap.add "this" (VRegister a0) !globals_env + in let need_fp = ref false 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 - | [] -> need_fp := true; - Smap.add id (if r then VStackByRef p else VStack p) env, p + 4, regs - ) - (env0, 0, regs_for_args) proto.tp_args in + (fun (env, p, regs) ((ty, r), id) -> + assert (r || type_size tenv ty = 4); + match regs with + | reg::more_regs -> + Smap.add id (if r then VRegisterByRef reg else VRegister reg) env, p, more_regs + | [] -> need_fp := true; + Smap.add id (if r then VStackByRef p else VStack p) env, p + 4, regs + ) + (env0, 0, regs_for_args) proto.tp_args in let env = { c_penv = tenv; c_names = names; @@ -561,7 +563,8 @@ let gen_decl tenv decl = match decl with 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 - la sp areg (-8, fp) ++ jal (cls_name ^ "0"), true in + la sp areg (-8, fp) ++ jal (cls_name ^ "0"), true + in let code_for_virtual = match proto.tp_virtual with | Some (c, _) when c.h_pos <> 0 -> la a0 areg (-c.h_pos, a0) @@ -574,27 +577,30 @@ let gen_decl tenv decl = match decl with in let text, data = gen_block env2 block in label proto.tp_unique_ident - ++ sw fp areg (-4, sp) ++ sw ra areg (-8, sp) ++ move fp sp - ++ code_for_virtual ++ save_code ++ code_for_constructor ++ text ++ label env.c_ret_lbl - ++ move sp fp ++ lw fp areg (-4, sp) ++ lw ra areg (-8, sp) ++ jr ra, data + ++ sw fp areg (-4, sp) ++ sw ra areg (-8, sp) ++ move fp sp + ++ code_for_virtual ++ save_code ++ code_for_constructor ++ text + ++ label env.c_ret_lbl ++ move sp fp ++ lw fp areg (-4, sp) ++ lw ra areg (-8, sp) + ++ jr ra, data else let text, data = gen_block env block in label proto.tp_unique_ident - ++ (if !need_fp then sw fp areg (-4, sp) ++ move fp sp else nop) - ++ code_for_virtual ++ text ++ label env.c_ret_lbl - ++ (if !need_fp then move sp fp ++ lw fp areg (-4, sp) else nop) ++ jr ra, data + ++ (if !need_fp then sw fp areg (-4, sp) ++ move fp sp else nop) + ++ code_for_virtual ++ text + ++ label env.c_ret_lbl ++ (if !need_fp then move sp fp ++ lw fp areg (-4, sp) else nop) + ++ jr ra, data | TDClass(c) -> - let calls_something = ref false in + let constructor_calls_something = ref false in (* 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 - calls_something := true; + let proto = List.find + (fun p -> p.tp_ret_type = None && p.tp_args = [] && p.tp_name = cn) + c.tc_methods in + constructor_calls_something := true; 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 (-12, fp) else nop) - ) + ++ jal proto.tp_unique_ident ++ (if parent.h_pos <> 0 then lw a0 areg (-12, fp) else nop)) nop c.tc_hier.h_supers in (* Build vtables and build constructor *) let rec make_vtables hh = @@ -624,27 +630,30 @@ let gen_decl tenv decl = match decl with (* Initialize members *) let init_code_proper = Smap.fold (fun _ (ty, pos) code -> - (match ty with + 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 - calls_something := true; - (if pos <> 0 then la a0 areg (pos, a0) else nop) - ++ la sp areg (-12, fp) - ++ jal proto.tp_unique_ident ++ (if pos <> 0 then lw a0 areg (-12, fp) else nop) - | _ -> sw zero areg (pos, a0) - ) ++ code) c.tc_members nop + let proto = List.find + (fun p -> p.tp_ret_type = None && p.tp_args = [] && p.tp_name = s) + cs.tc_methods in + constructor_calls_something := true; + (if pos <> 0 then la a0 areg (pos, a0) else nop) + ++ la sp areg (-12, fp) + ++ jal proto.tp_unique_ident + ++ (if pos <> 0 then lw a0 areg (-12, fp) else nop) + | _ -> sw zero areg (pos, a0))) + c.tc_members nop in (* Put it all together *) label (c.tc_name ^ "0") - ++ (if !calls_something then - sw fp areg (-4, sp) ++ move fp sp ++ - sw ra areg (-8, fp) ++ sw a0 areg (-12, fp) ++ la sp areg (-12, fp) - else nop) - ++ code_parents ++ vtable_init_code ++ init_code_proper - ++ (if !calls_something then - lw ra areg (-8, fp) ++ move sp fp ++ lw fp areg (-4, sp) - else nop) - ++ jr ra, vtables + ++ (if !constructor_calls_something then + sw fp areg (-4, sp) ++ move fp sp ++ sw ra areg (-8, fp) + ++ sw a0 areg (-12, fp) ++ la sp areg (-12, fp) + else nop) + ++ code_parents ++ vtable_init_code ++ init_code_proper + ++ (if !constructor_calls_something then + lw ra areg (-8, fp) ++ move sp fp ++ lw fp areg (-4, sp) + else nop) + ++ jr ra, vtables let generate p = @@ -653,10 +662,11 @@ let generate p = 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 "_nothing" ++ jr ra ++ - text in + label "main" + ++ jal p.prog_main + ++ li v0 10 ++ syscall + ++ label "_nothing" ++ jr ra + ++ text in { text = text; data = data } with @@ -668,3 +678,5 @@ let generate p = "(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")) + + |