From 7770d251f3cf41e04b49067ba4bd6e45d87fd2d1 Mon Sep 17 00:00:00 2001 From: Alex AUVOLAT Date: Fri, 10 Jan 2014 16:28:30 +0100 Subject: Beautify code... --- src/codegen.ml | 123 +++++++++++++++++++++++++++++++++------------------------ 1 file changed, 72 insertions(+), 51 deletions(-) (limited to 'src') diff --git a/src/codegen.ml b/src/codegen.ml index 1d6d026..423e6a6 100644 --- a/src/codegen.ml +++ b/src/codegen.ml @@ -10,13 +10,13 @@ type whereis_var = | VStackByRef of int type cg_env = { - c_penv : env; + c_penv : env; (* environnement du programme (Typing.env) : contient les informations de types *) c_names : whereis_var Smap.t; - c_ret_ref : bool; - c_fp_used : int; + c_ret_ref : bool; (* le résultat est-il renvoyé par référence ? *) + c_fp_used : int; (* nombre d'octets sous $fp utilisés par la fonction *) } -let globals_env = ref Smap.empty +let globals_env = ref Smap.empty (* variables globales *) let strings = Hashtbl.create 12 (* string -> label *) @@ -26,7 +26,19 @@ let id = fun prefix -> (last := !last + 1; prefix ^ (string_of_int !last)) -(* Génération de code des machins *) +(* La génération de code à proprement parler ! + + La valeur d'une expression est générée dans le registre a0, la pile est utilisée + pour les calculs intermédiaires. + + Le plus possible, le générateur de code enregistre dans a0 non pas la valeur + de l'expression mais l'adresse où cette valeur est stockée en mémoire. Évidemment, + une telle adresse n'existe que pour les expressions qui sont typées comme des + références ou des lvalues (c'est essentiellement la même chose). + + La fonction cr effectue donc, dans le cas où on a l'addresse et non pas la valeur, + la lecture mémoire requise pour accéder à la valeur en question. + *) let cr a = if a then lw a0 areg (0, a0) else nop (* conditionnally read *) @@ -34,7 +46,8 @@ let cr a = if a then lw a0 areg (0, a0) else nop (* conditionnally read *) 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 *) + | TEThis -> (* convention : this est toujours le premier argument de la fonction, c'est-à-dire + celui qui est pushé en dernier. on connait donc toujours son adresse *) lw a0 areg (8, fp), false | TEIdent(i) -> begin match Smap.find i env.c_names with @@ -72,12 +85,16 @@ let rec gen_expr env e = match e.te_desc with | 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.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 @@ -126,24 +143,24 @@ let rec gen_expr env e = match e.te_desc with let rec gen_stmt env = function - | TSEmpty -> nop, nop, env + | TSEmpty -> nop, env | TSExpr(e) -> - comment "expr" ++ (fst (gen_expr env e)), nop, env + comment "expr" ++ (fst (gen_expr env e)), 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 + let c_then, _ = gen_stmt env s1 in + let c_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 + label l_else ++ c_else ++ label l_end, 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 + let c_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 + label l_cond ++ c ++ cr a ++ bnez a0 l_begin, env | TSFor(before, cond, after, body) -> let l_begin = id "_for_begin" in let l_cond = id "_for_cond" in @@ -155,18 +172,18 @@ let rec gen_stmt env = function | 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 + let c_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 + ++ 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 "_return", 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 + comment "return" ++ c ++ cr (not env.c_ret_ref && a) ++ b "_return", env | TSDeclare (ty, id) -> let s = type_size env.c_penv ty in let new_fp_used = env.c_fp_used + s in @@ -181,7 +198,7 @@ let rec gen_stmt env = function jal cproto.tp_unique_ident | _ -> push zero in - comment ("declare " ^ id) ++ code, nop, + comment ("declare " ^ id) ++ code, { env with c_names = Smap.add id (VStack pos) env.c_names; c_fp_used = new_fp_used } @@ -197,7 +214,7 @@ let rec gen_stmt env = function 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, + comment ("declare " ^ id) ++ code, { env with c_names = Smap.add id (VStack pos) env.c_names; c_fp_used = new_fp_used; } @@ -208,36 +225,36 @@ let rec gen_stmt env = function 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, + comment ("declare " ^ id) ++ sub sp sp oi 4 ++ code ++ cr (a && not r) ++ sw a0 areg (pos, fp), { env with c_names = Smap.add id (if r then VStackByRef pos else VStack pos) env.c_names; c_fp_used = new_fp_used } | TSWriteCout(sl) -> - let text1, data1 = List.fold_left - (fun (text, data) s -> + let text1 = List.fold_left + (fun text s -> match s with | TSEExpr(e) -> let t, a = gen_expr env e in - text ++ t ++ cr a ++ li v0 1 ++ syscall, data + text ++ t ++ cr 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 + let l = id "_s" in + Hashtbl.add strings s l; 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<<..." ++ text1, 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 text, fin_env = + List.fold_left (fun (t, e) s -> + let tt, e = gen_stmt e s in + t ++ tt, e) + (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 popn n) let gen_decl tenv decl = match decl with | TDGlobal(ty, id) -> @@ -264,10 +281,10 @@ let gen_decl tenv decl = match decl with 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 + let text = 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 + text ++ b "_return", nop | TDClass(c) -> (* Call default constructor of parent classes *) let code_parents = List.fold_left @@ -325,13 +342,17 @@ 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 "_return" ++ move sp fp ++ pop ra ++ pop fp + ++ 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))) -- cgit v1.2.3 From a95f51e847892fe0e358c519cc4bac42382fbbb7 Mon Sep 17 00:00:00 2001 From: Alex AUVOLAT Date: Fri, 10 Jan 2014 18:41:08 +0100 Subject: Correct a typing bug in multiple inheritance (all virtual instances in parents must be updated when virtual method is redefined.) --- src/typing.ml | 78 ++++++++++++++++++++++++++++++----------------------------- 1 file changed, 40 insertions(+), 38 deletions(-) (limited to 'src') diff --git a/src/typing.ml b/src/typing.ml index 2b0be10..105b9d1 100644 --- a/src/typing.ml +++ b/src/typing.ml @@ -678,51 +678,53 @@ let compute_tclass env c = | Some k -> Some (build_type_or_ref k) | None -> None in - (* If method is redefined from a virtual method of a parent class, it becomes virtual with same offset - Else if method is virtual, it gets new offset ! - Else method is not virtual, everything is simple. *) - let rec check_in_super (s:tcls_hier) = - match List.fold_left (fun k s -> - let r = check_in_super s in - match k, r with - | None, None -> None - | None, Some k -> Some k - | Some k, None -> None - | Some k, Some r -> ty_error ("Ambiguous redefinition of " ^ proto.p_name)) - None s.h_supers - with - | Some k -> Some k - | None -> - List.fold_left (fun f (i, p) -> - if (p.tp_name = proto.p_name && (List.map fst p.tp_args) = args_types && p.tp_virtual <> None) - then begin - ty_assert (p.tp_ret_type = ret_type) "Virtual method must be redefined with same return type."; - Some (s, i) - end else f) None s.h_vtable - in let super = match check_in_super hier with - | None -> if virt then - (* allocate new spot in vtable of this object *) - Some (hier, List.fold_left (fun n (x, _) -> max n (x+4)) 0 hier.h_vtable) - else None - | Some k -> Some k - in - - (* Build proto *) + (* Build primitive proto *) let tproto = - { tp_virtual = super; + { tp_virtual = None; tp_name = proto.p_name; tp_unique_ident = proto.p_name ^ (tproto_unique_number()) ; tp_class = Some(cls_name); tp_ret_type = ret_type; tp_args = args; } in - (* Add to vtable *) - begin match super with - | None -> () - | Some (c, i) -> - c.h_vtable <- (i, tproto)::(List.remove_assoc i c.h_vtable) - end; - tproto) in + + (* If method is redefined from a virtual method of a parent class, + it becomes virtual with same offset + If method is redefined from a virtual method of several parent classes, + update vtables for all these parent classes, use any as virtual + class for this class. + Else if method is virtual, it gets new offset ! + Else method is not virtual, everything is simple. *) + let rec check_in_super (s:tcls_hier) = + let c_proto = + try + let (pos, proto) = List.find + (fun (_, p) -> p.tp_name = proto.p_name && (List.map fst p.tp_args) = args_types && p.tp_virtual <> None) + s.h_vtable in + ty_assert (proto.tp_ret_type = ret_type) + "Redefinition of virtual method must be done with same return type."; + let new_proto = { tproto with tp_virtual = Some(s, pos) } in + s.h_vtable <- (pos, new_proto)::(List.remove_assoc pos s.h_vtable); + Some (s, pos) + with | Not_found -> None + in + + List.fold_left (fun k s -> + match check_in_super s with + | None -> k + | r -> r) + c_proto s.h_supers + in + match check_in_super hier with + | None -> if virt then + (* allocate new spot in vtable of this object *) + let pos = List.fold_left (fun n (x, _) -> max n (x+4)) 0 hier.h_vtable in + let proto = { tproto with tp_virtual = Some (hier, pos) } in + hier.h_vtable <- (pos, proto)::hier.h_vtable; + proto + else tproto + | some_super -> { tproto with tp_virtual = some_super } + ) in (mem, mem_u), m::meth ) ((Smap.empty, used), []) c.c_members in (* make sure class has default constructor *) -- cgit v1.2.3