diff options
Diffstat (limited to 'src/codegen.ml')
| -rw-r--r-- | src/codegen.ml | 769 |
1 files changed, 567 insertions, 202 deletions
diff --git a/src/codegen.ml b/src/codegen.ml index 1d6d026..3849bfa 100644 --- a/src/codegen.ml +++ b/src/codegen.ml @@ -3,241 +3,547 @@ open Typing exception Very_bad_error of string +exception Reference_register of register + +(* 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 (rien de particulier pour un constructeur) + - v0-v1, t0-t9, s0-s1 : utilisés pour les calculs + - fp contient un pointeur de frame mis à jour pour chaque appel + de fonction + - sp n'est pas tenu à jour en fonction de l'état de la pile, par contre il est + utilisé lors d'un appel de fonction pour pouvoir définir le nouvea fp, + il est donc mis à jour avant chaque appel de fonction pour effectivement refléter + l'état d'utilisation de la pile (pile sur laquelle il peut d'ailleurs y avoir + des arguments excedentaires) + Tous les registres doivent être sauvés par l'appellant sauf fp + 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 *) type whereis_var = | VGlobal | 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_ret_lbl : string; c_fp_used : int; + c_need_fp : bool ref; + c_save_regs : register list; + c_free_regs : register list; } +let env_push n e = + if n <> 0 then e.c_need_fp := true; + let kk = e.c_fp_used + n in + { e with c_fp_used = kk }, -kk + +let env_add_var vid vv e = + { e with c_names = Smap.add vid vv e.c_names } + +let env_get_free_reg e = + let r, more = List.hd e.c_free_regs, List.tl e.c_free_regs in + { e with + c_free_regs = more; + c_save_regs = r::e.c_save_regs }, r + let globals_env = ref Smap.empty +(* Chaînes de caractères utilisées dans le programme *) let strings = Hashtbl.create 12 (* string -> label *) -(* Identifiants uniques pour les machins - essentiellement labels *) +(* Identifiants uniques pour divers objets - essentiellement labels *) let id = let last = ref 0 in fun prefix -> (last := !last + 1; prefix ^ (string_of_int !last)) +(* Doit-on se préparer à faire des appels de fonction ? Ie sauvegarder $ra *) +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 *) +(* La génération de code, enfin ! *) -let cr a = if a then lw a0 areg (0, a0) else nop (* conditionnally read *) +(* Arguments de la fonction gen_expr : + - un environnement : permet de savoir plein de choses, par exemple combien de place est + utilisée sur la pile en-dessous de $fp + - une liste de registres disponnibles pour faire le calcul + *qui doit toujours contenir au moins un registre* + - une liste de registres à sauvegarder dans tous les cas + - l'expression pour laquelle on veut générer du code -(* 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 + À l'issue d'un appel à gen_expr, il y a plusieurs possibilités, exprimées + par le type union expr_type décrit ci-dessus : + - le premier registre de la liste des registres disponnibles (noté r) contient + une adresse qui est l'adresse de la valeur dénotée par l'expression + - la valeur dénotée est stockée dans x(reg) pour un certain reg et un certain x + - la valeur est stockée dans un certain registre a, qui est son + "registre de référence", ie si on doit affecter à cette valeur on peut + modifier ce registre + - la valeur est stockée dans le registre r + Dans tous les cas sauf le dernier, on peut modifier la valeur dénotée par + l'expression (par exemple lors d'une affectation). + Si le typage nous garantit que l'expression ne peut pas être affectée, on peut + utiliser l'artifice de dire qu'une valeur est placée dans un registre comme + "registre de référence" même lorsque ce n'est pas le cas (= jouer avec le feu). +*) + +(* possibilités pour ce qui est généré par gen_expr *) +type expr_type = + | Addr (* top register contains address of value *) + | AddrByReg of int * register (* value at int(register) *) + | Value of register (* other register is home to the value *) + | Copy (* top register contains copy of value *) + +(* on a fait un appel à gen_expr, maintenant on veut être sûr d'avoir + soit l'adresse soit la valeur dans tel ou tel registre *) +let cla r a = match a with + | Addr -> nop + | AddrByReg(x, rg) -> la r areg (x, rg) + | Value r -> raise (Reference_register r) + | _ -> assert false +let cr r a = match a with (* conditionnally read *) + | Addr -> lw r areg (0, r) + | AddrByReg(x, rg) -> lw r areg (x, rg) + | Copy -> nop + | Value k -> if r <> k then move r k else nop +let crb r q a = match a with + | Value k -> q, k + | _ -> q ++ cr r a, r + +let spare_reg = s0 +let spare_reg2 = s1 + +(* Cette fonction prévoit de l'espace sur la pile pour enregistrer les + valeurs de tous les registres save_regs à sauvegarder (elle donne un nouvel + environnement où la place nécessaire est réservée) et génère le code + nécessaire à la sauvegarde et à la restauration. + Le nouvel environnement est également modifié de manière à ce que de futurs + appels à des valeurs qui devaient être enregistrées dans des registres sauvegardés + soient maintenant fait en prenant en compte la relocalisation de ces valeurs + sur la pile. *) +let saver env save_regs = + 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 + env.c_need_fp := true; + code ++ sw r areg (pos, fp), lw r areg (pos, fp) ++ more_code, + { env with + 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_fp_used = new_fp_used; + c_save_regs = (List.filter ((<>) r) env.c_save_regs) } + ) + (nop, nop, env) save_regs + +(* + renvoie le résultat dans le premier registre de free_regs + ou autre (cf ci-dessus) +*) +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 + (* generate the code... *) + match e.te_desc with + | TEInt(k) -> li r k, Copy + | TENull -> nop, Value zero + | TEThis -> (* convention : this is always the first argument, so in a0 *) + begin match Smap.find "this" env.c_names with + | VRegister(k) when k <> r -> nop, Value k + | VStack(i) -> nop, AddrByReg(i, fp) + | _ -> assert false + end | 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 + | VGlobal -> la r alab i, Addr + | VStack(i) -> nop, AddrByReg(i, fp) + | VStackByRef(i) -> lw r areg (i, fp), Addr + | VRegister(k) -> nop, Value k + | VRegisterByRef(k) -> nop, AddrByReg(0, k) 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 + begin match more with + | [] -> + let t1, ae1 = gen_expr env free_regs save_regs e1 in + let env2, tspot = env_push 4 env in + let t2, ae2 = gen_expr env2 free_regs save_regs e2 in + let t2 = t2 ++ cr r ae2 in + begin match ae1 with + | Addr -> t1 ++ sw r areg (tspot, fp) ++ t2 ++ lw spare_reg areg (tspot, fp) ++ sw r areg (0, spare_reg), Copy + | AddrByReg (x, rg) when t1 = nop -> t2 ++ sw r areg (x, rg), Copy + | Value k when t1 = nop && k <> r -> t2 ++ move k r, Copy + | _ -> assert false + 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, r2 = crb r t2 ae2 in + let tr = if r2 = r then Copy else Value r2 in + begin match ae1 with + | Addr -> t2 ++ t1 ++ sw r2 areg (0, b), tr + | AddrByReg (x, rg) when t1 = nop -> t2 ++ sw r2 areg (x, rg), tr + | Value k when t1 = nop && k <> r2 -> t2 ++ move k r2, tr + | _ -> assert false + end + end | 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 + let keep_result_in_v0 = (not (List.mem v0 save_regs)) || r = v0 in + let code_save_regs, code_restore_regs, env_regs_saved = saver env save_regs in + let args_code, _, env_args = code_for_args env_regs_saved args [ a0; a1; a2; a3 ] in + code_save_regs + ++ args_code + ++ la sp areg (-env_args.c_fp_used, fp) ++ jal id + ++ (if keep_result_in_v0 then nop else move r v0) + ++ code_restore_regs, + if b + then (if keep_result_in_v0 then AddrByReg (0, v0) else Addr) + else (if keep_result_in_v0 then Value(v0) else Copy) | 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 + let keep_result_in_v0 = (not (List.mem v0 save_regs)) || r = v0 in + let code_save_regs, code_restore_regs, env_regs_saved = saver env save_regs in + let args_code, sr, env_args = code_for_args env_regs_saved ((obj, true)::args) [ a0; a1; a2; a3 ] in + code_save_regs + ++ args_code + ++ lw v0 areg (0, a0) ++ lw v0 areg (fi, v0) + ++ la sp areg (-env_args.c_fp_used, fp) ++ jalr v0 + ++ (if keep_result_in_v0 then nop else move r v0) + ++ code_restore_regs, + if b + then (if keep_result_in_v0 then AddrByReg (0, v0) else Addr) + else (if keep_result_in_v0 then Value(v0) else Copy) | TEUnary (x, e) -> - let t, a = gen_expr env e in + let t, a = gen_expr env free_regs save_regs 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 + | Ast.Deref -> + begin match a with + | Value r -> t, AddrByReg (0, r) + | _ -> t ++ cr r a, Addr + end + | Ast.Ref -> + t ++ cla r a, Copy + | 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.PreDecr -> + let delta = if x = Ast.PreIncr then 1 else -1 in + begin match a with + | 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.PostIncr | Ast.PostDecr -> + let delta = if x = Ast.PostIncr then 1 else -1 in + begin match a with + | 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 - | 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 + | TEBinary(e1, op, e2) when op <> Ast.Lor && op <> Ast.Land -> + let rs, rb, precode = match more with + | [] -> + 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, 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 + let t1, rs = crb r t1 ae1 in + let t2, rb = crb b t2 ae2 in + rs, rb, t1 ++ t2 + in + precode ++ (match op with + | Ast.Add -> add r rs oreg rb + | Ast.Sub -> sub r rs oreg rb + | Ast.Mul -> mul r rs oreg rb + | Ast.Div -> div r rs oreg rb + | Ast.Modulo -> rem r rs oreg rb + | Ast.Equal -> seq r rs rb + | Ast.NotEqual -> sne r rs rb + | Ast.Lt -> slt r rs rb + | Ast.Le -> sle r rs rb + | Ast.Gt -> sgt r rs rb + | Ast.Ge -> sge r rs rb + | _ -> assert false + ), Copy + | TEBinary(e1, op, e2) (* when op = Ast.Lor || op = Ast.Land *) -> + let t1, ae1 = gen_expr 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 + 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 | TEMember(e, i) -> - let c, a = gen_expr env e in + let c, a = gen_expr env free_regs save_regs e in if i <> 0 then begin - assert a; - c ++ la a0 areg (i, a0), true + match a with + | Addr -> c ++ la r areg (i, r), Addr + | AddrByReg (k, rg) when c = nop -> nop, AddrByReg (k + i, rg) + | _ -> assert false 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 + 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, 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 code_save_regs, code_restore_regs, env_regs_saved = saver env save_regs in + 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 +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 + (fun (ir, is, fr) (arg, byref) -> + match fr with + | [] -> ir, (arg, byref)::is, [] + | r::nfr -> (r, (arg, byref))::ir, is, nfr) + ([], [], regs) arg_list in + (* allocate stack for remaining args *) + let stack_use = 4 * List.length args_in_stack in + let kenv, _ = env_push stack_use env in + (* make code for in-stack arguments *) + let args_in_stack = List.rev args_in_stack in + let code_for_stack, _ = List.fold_left + (fun (code, u) (arg, byref) -> + let c, addr = gen_expr kenv (v0::kenv.c_free_regs) [] arg in + (if byref then + c ++ cla v0 addr ++ sw v0 areg (-kenv.c_fp_used + u, fp) ++ code, u+4 + else + let c, freg = crb v0 c addr in + c ++ sw freg areg (-kenv.c_fp_used + u, fp) ++ code, u+4 + ) + ) (nop, 0) args_in_stack in + (* make code for in-register arguments *) + let arg_reg_do_call, arg_reg_dont_call = + List.partition (fun (_, (e, _)) -> expr_does_call e) args_in_regs in + let rec mk_code_callz e = function + | [] -> nop + | (reg, (expr, byref))::more_args -> + let c, addr = gen_expr e (reg::kenv.c_free_regs) [] expr in + if more_args = [] then + c ++ (if byref then cla reg addr else cr reg addr) + else + let e2, pos = env_push 4 e in + (if byref then + 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) + in + let code_reg_do_call = mk_code_callz kenv arg_reg_do_call in + let code_reg_dont_call, _ = + List.fold_left + (fun (code, ur) (reg, (expr, byref)) -> + let c, addr = gen_expr kenv (reg::kenv.c_free_regs) ur expr in + code ++ c ++ (if byref then cla reg addr else cr reg addr), reg::ur) + (nop, []) arg_reg_dont_call + in + let code = code_for_stack ++ code_reg_do_call ++ code_reg_dont_call + in code, (List.map fst args_in_regs), kenv + + +let gen_expr_dr dr env = gen_expr env (dr::env.c_free_regs) env.c_save_regs +let gen_expr_v0 = gen_expr_dr v0 -let rec gen_stmt env = function - | TSEmpty -> nop, nop, env +let rec gen_stmt alloc_vars_in_regs env = function + | TSEmpty -> nop, env | TSExpr(e) -> - comment "expr" ++ (fst (gen_expr env e)), nop, env + comment "expr" ++ (fst (gen_expr_v0 env e)), env | TSIf(cond, s1, s2) -> - let c, a = gen_expr env cond in - let l_else = id "_cond_then" in + let c, a = gen_expr_v0 env cond 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 - 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 + let c_then = gen_block env [s1] in + let c_else = gen_block env [s2] in + comment "if" + ++ c ++ beqz reg l_else + ++ c_then ++ b l_end + ++ label l_else ++ c_else + ++ label l_end, env | TSWhile(cond, body) -> - let c, a = gen_expr env cond in + 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 a ++ bnez a0 l_begin, d_body, env + let c_body = gen_block env [body] in + comment "while" ++ b l_cond + ++ label l_begin ++ c_body + ++ label l_cond ++ c ++ bnez reg l_begin, 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 + (fun code expr -> let c, _ = gen_expr_v0 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 + (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 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 + | 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 = gen_block env [body] in + comment "for" + ++ c_before ++ b l_cond + ++ label l_begin ++ c_body ++ c_after + ++ label l_cond ++ c_cond, env | TSBlock(b) -> - let c, d = gen_block env b in - comment "block" ++ c, d, env + let c = gen_block env b in + comment "block" ++ c, env | TSReturn (None) -> - comment "return" ++ b "_return", nop, env + comment "return" ++ b env.c_ret_lbl, 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 + 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) + ++ b env.c_ret_lbl, 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, - { env with - c_names = Smap.add id (VStack pos) env.c_names; - c_fp_used = new_fp_used } + if num ty && alloc_vars_in_regs && List.length env.c_free_regs > 5 then + (* allocate variable in register *) + let env2, reg = env_get_free_reg env in + comment ("declare " ^ id) ++ move reg zero, + env_add_var id (VRegister reg) env2 + else + let s = type_size env.c_penv ty in + let env2, pos = env_push s env 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 + let code_save_regs, code_restore_regs, env_regs_saved = saver env2 env.c_save_regs in + code_save_regs + ++ la a0 areg (pos, fp) + ++ la sp areg (-env_regs_saved.c_fp_used, fp) ++ jal cproto.tp_unique_ident + ++ code_restore_regs + | _ -> sw zero areg (pos, fp) + in + comment ("declare " ^ id) ++ code, + env_add_var id (VStack pos) env2 | TSDeclareAssignConstructor(cls, id, constr, args) -> - let new_fp_used = env.c_fp_used + cls.tc_size in - let pos = - new_fp_used in + let env2, pos = env_push cls.tc_size env 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)) + let code_save_regs, code_restore_regs, env_regs_saved = saver env2 env.c_save_regs in + let args_code, _, env_args = code_for_args env_regs_saved args [ a1; a2; a3 ] in + code_save_regs + ++ args_code ++ la a0 areg(pos, fp) + ++ la sp areg (-env_args.c_fp_used, fp) ++ jal constr + ++ code_restore_regs in - comment ("declare " ^ id) ++ code, nop, - { env with - c_names = Smap.add id (VStack pos) env.c_names; - 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, - { env with - c_names = Smap.add id (if r then VStackByRef pos else VStack pos) env.c_names; - c_fp_used = new_fp_used } + comment ("declare " ^ id) ++ code, + env_add_var id (VStack pos) env2 + | TSDeclareAssignExpr ((ty, ref), id, e) -> + assert (ref || num ty); + if alloc_vars_in_regs && List.length env.c_free_regs > 5 then + (* allocate variable in register *) + let env2, reg = env_get_free_reg env in + let code, a = gen_expr env (reg::env2.c_free_regs) env.c_save_regs e in + comment ("declare " ^ id) + ++ code ++ (if ref then cla reg a else cr reg a), + env_add_var id (if ref then VRegisterByRef reg else VRegister reg) env2 + else + let code, a = gen_expr_v0 env e in + let env2, pos = env_push 4 env in + comment ("declare " ^ id) + ++ (if ref then + code ++ cla v0 a ++ sw v0 areg (pos, fp) + else + let k, b = crb v0 code a in + k ++ sw b areg (pos, fp) + ), + env_add_var id (if ref then VStackByRef pos else VStack pos) env2 | TSWriteCout(sl) -> - let text1, data1 = List.fold_left - (fun (text, data) s -> - match s with + let save_code, restore_code, env2 = saver env + (if List.mem a0 env.c_save_regs then [a0] else []) in + let text1 = List.fold_left + (fun text -> function | TSEExpr(e) -> - let t, a = gen_expr env e in - text ++ t ++ cr a ++ li v0 1 ++ syscall, data + let t, a = gen_expr_dr a0 env2 e in + text ++ t ++ cr a0 a ++ li v0 1 ++ syscall | TSEStr(s) -> - let l, d = + let l = if Hashtbl.mem strings s then - Hashtbl.find strings s, nop + Hashtbl.find strings s else let l = id "_s" in Hashtbl.add strings s l; - l, label l ++ asciiz s + l in - text ++ la a0 alab l ++ li v0 4 ++ syscall, data ++ d) (nop, nop) sl in - comment "cout<<..." ++ text1, data1, env + text ++ la a0 alab l ++ li v0 4 ++ syscall) + nop sl in + comment "cout<<..." + ++ save_code ++ text1 ++ restore_code, 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 + let rec fold env = function + | [] -> nop + | stmt::next -> + let does_call_after = List.exists stmt_does_call next in + try + let tt, ee = gen_stmt (not does_call_after) env stmt in + let more_code = fold ee next in + tt ++ more_code + with Reference_register _ -> + let tt, ee = gen_stmt false env stmt in + let more_code = fold ee next in + tt ++ more_code in - let n = (fin_env.c_fp_used - env.c_fp_used) in - text ++ (if n = 0 then nop else popn n), data + fold env b let gen_decl tenv decl = match decl with | TDGlobal(ty, id) -> @@ -245,39 +551,80 @@ 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, 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) -> + 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; c_ret_ref = (match proto.tp_ret_type with | None -> false | Some(_, r) -> r); - c_fp_used = 0; + c_ret_lbl = "_return_" ^ proto.tp_unique_ident; + c_fp_used = 8; + c_need_fp = need_fp; + c_free_regs = [ t0; t1; t2; t3; t4; t5; t6; t7; t8; t9; v1 ]; + 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 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 + 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 -> - 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 + if does_calls + then + let save_code, unsave_code, env2 = + saver env (List.filter (fun x -> x <> a0 || proto.tp_class = None) env.c_save_regs) + in + let text = 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, nop + else + let rec bb_fp e = + try + gen_block e block + with Reference_register r -> + let save_code, _, env2 = saver env [r] in + save_code ++ bb_fp env2 + in + let text = bb_fp env 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, nop | TDClass(c) -> + 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 - code ++ lw v0 areg(0, sp) ++ la v0 areg(parent.h_pos, v0) ++push v0 ++ jal proto.tp_unique_ident ++ popn 4) + 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)) 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 *) @@ -292,10 +639,10 @@ let gen_decl tenv decl = match decl with 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 *) + then nop + 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 -> let mvt, mcc = make_vtables sup in @@ -303,20 +650,33 @@ let gen_decl tenv decl = match decl with (vtable, constructor_code) hh.h_supers in let vtables, vtable_init_code = make_vtables c.tc_hier in + (* 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 - 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 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 !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 = @@ -325,13 +685,16 @@ 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 "_return" ++ move sp fp ++ pop ra ++ pop fp ++ - label "_nothing" ++ jr ra ++ - text in + label "main" + ++ jal p.prog_main + ++ li v0 10 ++ syscall + ++ label "_nothing" ++ jr ra + ++ text in + let str = Hashtbl.fold + (fun str lbl data -> data ++ label lbl ++ asciiz str) + strings nop in { text = text; - data = data } + data = data ++ str } with | Assert_failure (k, a, b) -> raise (Very_bad_error ( "(unexpected) Assertion failure: "^k^" at "^(string_of_int a)^":"^(string_of_int b))) @@ -341,3 +704,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")) + + |