let rec asm_of_proc name proc proc_type lex_pos =
let lex_depth = List.length lex_pos in
let pos_in_proc = ref (-1) in
let get_lex_pos () =
incr pos_in_proc;
!pos_in_proc :: lex_pos
in
let new_var_def t =
Asm_ir.new_var_def (asm_type t) lex_depth
in
let addr_of_expr e =
{
expr_val = Address_of e;
expr_type = Pointer e.expr_type;
expr_pos = e.expr_pos;
}
in
let get_var_nature v =
if v.var_nature = Unknown_nature then
v.var_nature <- (get_some v.var_def).def_nature;
v.var_nature
in
let handle_defs defs =
let proc_defs = ref [] in
let rec handle_def d =
match d.def_value with
| Constant c ->
let cd = new_var_def c.expr_type in
cd.Asm_ir.vd_value <- Some (eval_expr c);
d.def_asm <- Asm_var cd; Some (Asm_var cd)
| Variable ->
(
match d.def_asm with
| Asm_none ->
let v = new_var_def d.def_type in
d.def_asm <- Asm_var v; Some (Asm_var v)
| def ->
Some def
)
| Function f ->
if f.func_external || (not f.func_used && !Params.remove_useless_functions) then
None
else
let pd, pasm = asm_of_proc d.def_name f d.def_type (get_lex_pos ()) in
d.def_asm <- Asm_proc pasm;
proc_defs := pd @ [pasm] @ !proc_defs;
Some (Asm_proc pasm)
| Type _ ->
None
in
let vars =
List.fold_left
(
fun l d ->
match handle_def d with
| Some (Asm_var v) -> v :: l
| _ -> l
) [] defs
in
(List.rev vars), !proc_defs
in
let asm_of_block block =
let var_with_def d =
Asm_ir.new_var d
in
let fresh_var t =
let vd = new_var_def t
in
vd, Asm_ir.new_var vd
in
let get_var_def v =
match v.var_def with
| Some d -> d
| _ -> raise (Asm_error ("internal error in get_var_def (unresolved variable definition)"))
in
let get_var_asm v =
match (get_var_def v).def_asm with
| Asm_var v -> v
| _ -> raise (Asm_error ("internal error in get_var_asm (with variable " ^ v.var_name ^ ")"))
in
let get_expr_flag e =
match e.expr_val with
| Lt(_, _) ->
{
Asm_ir.flag_not = false;
Asm_ir.flag_flag = Asm_ir.Lflag;
Asm_ir.flag_eq = false;
}
| Le(_, _) ->
{
Asm_ir.flag_not = false;
Asm_ir.flag_flag = Asm_ir.Lflag;
Asm_ir.flag_eq = true;
}
| Eq(_, _) ->
{
Asm_ir.flag_not = false;
Asm_ir.flag_flag = Asm_ir.Eflag;
Asm_ir.flag_eq = false;
}
| Neq(_, _) ->
{
Asm_ir.flag_not = true;
Asm_ir.flag_flag = Asm_ir.Eflag;
Asm_ir.flag_eq = false;
}
| New _
| Bang _
| Address_of _
| Rec _
| Arr _
| Var _
| Bool _
| Int _
| Not _
| And _
| Mod _
| Div _
| Mult _
| Or _
| Minus _
| Plus _
| Uminus _ -> raise (Asm_error ("internal error in get_expr_flag (expression is not a comparison)"))
in
let rec get_expr_asm e =
let vd, res = fresh_var (e.expr_type) in
if is_constant e then
(
vd.Asm_ir.vd_value <- Some (eval_expr e);
[vd], [], res
)
else
match e.expr_val with
| Plus(e1, e2) ->
let vd1, i1, v1 = get_expr_asm e1 in
let vd2, i2, v2 = get_expr_asm e2 in
vd :: vd1 @ vd2, i1 @ i2 @ [Asm_ir.Add_i(res, v1, v2)], Asm_ir.copy_var res
| Minus(e1, e2) ->
let vd1, i1, v1 = get_expr_asm e1 in
let vd2, i2, v2 = get_expr_asm e2 in
vd :: vd1 @ vd2, i1 @ i2 @ [Asm_ir.Sub_i(res, v1, v2)], Asm_ir.copy_var res
| Mult(e1, e2) ->
let vd1, i1, v1 = get_expr_asm e1 in
let vd2, i2, v2 = get_expr_asm e2 in
vd :: vd1 @ vd2, i1 @ i2 @ [Asm_ir.Mult_i(res, v1, v2)], Asm_ir.copy_var res
| Div(e1, e2) ->
let vd1, i1, v1 = get_expr_asm e1 in
let vd2, i2, v2 = get_expr_asm e2 in
vd :: vd1 @ vd2, i1 @ i2 @ [Asm_ir.Div_i(res, v1, v2)], Asm_ir.copy_var res
| Mod(e1, e2) ->
let vd1, i1, v1 = get_expr_asm e1 in
let vd2, i2, v2 = get_expr_asm e2 in
vd :: vd1 @ vd2, i1 @ i2 @ [Asm_ir.Mod_i(res, v1, v2)], Asm_ir.copy_var res
| Uminus(e1) ->
let vd1, i1, v1 = get_expr_asm e1 in
vd :: vd1, i1 @ [Asm_ir.Neg_i(res, v1)], Asm_ir.copy_var res
| Eq(e1, e2)
| Neq(e1, e2)
| Lt(e1, e2)
| Le(e1, e2) ->
let vd1, i1, v1 = get_expr_asm e1 in
let vd2, i2, v2 = get_expr_asm e2 in
vd :: vd1 @ vd2, i1 @ i2 @ [Asm_ir.Cmp_i(res, v1, get_expr_flag e, v2)], Asm_ir.copy_var res
| And(e1, e2) ->
let vd1, i1, v1 = get_expr_asm e1 in
let vd2, i2, v2 = get_expr_asm e2 in
vd :: vd1 @ vd2, i1 @ i2 @ [Asm_ir.And(res, v1, v2)], Asm_ir.copy_var res
| Or(e1, e2) ->
let vd1, i1, v1 = get_expr_asm e1 in
let vd2, i2, v2 = get_expr_asm e2 in
vd :: vd1 @ vd2, i1 @ i2 @ [Asm_ir.Or(res, v1, v2)], Asm_ir.copy_var res
| Not e1 ->
let vd1, i1, v1 = get_expr_asm e1 in
vd :: vd1, i1 @ [Asm_ir.Not(res, v1)], Asm_ir.copy_var res
| Int i ->
vd.Asm_ir.vd_value <- Some (Asm_ir.Int i); [vd], [], res
| Bool b ->
vd.Asm_ir.vd_value <- Some (Asm_ir.Bool b); [vd], [], res
| New t ->
[vd], [Asm_ir.New(res,sizeof !t)], Asm_ir.copy_var res
| Arr(a, n) ->
let vda, ia, va = get_expr_asm a in
let vdn, i_n, vn = get_expr_asm n in
let t, n0 =
match a.expr_type with
| Array(t, n0, _) -> t, n0
| _ -> raise (Asm_error ("internal error in get_expr_asm (using a variable which is not an array as an array)"))
in
let n0 = eval_expr_int n0 in
vd.Asm_ir.vd_pos := Asm_ir.Pos_arr(va, vn, n0, sizeof t);
vd :: vda @ vdn, ia @ i_n, res
| Rec(r, f) ->
let vdr, ir, vr = get_expr_asm r in
let k =
let rec get_k = function
| (field, t) :: _ when f = field -> 0
| (_, t) :: tl -> (sizeof t) + get_k tl
| [] -> failwith "error"
in
match r.expr_type with
| Record r -> get_k r
| _ -> failwith "error"
in
vd.Asm_ir.vd_pos := Asm_ir.Pos_rec(vr, k);
vd :: vdr, ir, res
| Address_of e1 ->
let vd1, i1, v1 = get_expr_asm e1 in
Asm_ir.set_var_ots v1;
vd :: vd1, i1 @ [Asm_ir.Spill_var(Asm_ir.copy_var v1); Asm_ir.Address_of(res, v1)], Asm_ir.copy_var res
| Bang e1 ->
let vd1, i1, v1 = get_expr_asm e1 in
let vp = Asm_ir.new_var v1.Asm_ir.var_def in
vp.Asm_ir.var_def.Asm_ir.vd_lex_depth := lex_depth;
vd.Asm_ir.vd_pos := Asm_ir.Pos_pointed vp;
vd :: vd1, i1, res
| Var(v, []) when get_var_nature v <> Funct ->
res.Asm_ir.var_def <- get_var_asm v; [], [], res
| Var(v, a) ->
let d, i, s =
List.fold_left2
(
fun (d, i, a) arg e ->
let d', i', a' =
get_expr_asm
(
if arg.def_pass_by_ref then
addr_of_expr e
else
e
)
in
d' @ d, i' :: i, a' :: a
) ([], [], [])
(
match (get_var_def v).def_value with
| Function f -> f.func_args
| _ -> raise (Asm_error ("internal error in get_expr_asm (using a variable which is not an function as a function)"))
) a
in
let i = List.concat (List.rev i) in
let p =
match (get_var_def v).def_value with
| Function f -> f
| _ -> raise (Parse_error("internal error, procedure is not a procedure", v.var_pos))
in
vd :: d, i @ [Asm_ir.Fun(res, p.func_asm_def, s)], Asm_ir.copy_var res
in
let new_bb i mi =
{
Asm_ir.bb_block = i;
Asm_ir.bb_link = mi;
}
in
let add_to_bb bb i =
bb.Asm_ir.bb_block <- i @ bb.Asm_ir.bb_block
in
let append_to_bb bb i =
bb.Asm_ir.bb_block <- bb.Asm_ir.bb_block @ i
in
let get_stts_list stt =
match stt.stt_value with
| Compound c -> c
| _ -> [stt]
in
let rec asm_of_stts statements =
match statements with
| [] -> [], new_bb [] Asm_ir.End
| stt :: stts ->
let bbd, bbs = asm_of_stts stts in
match stt.stt_asm with
| Some(d, mi) -> d @ bbd, new_bb [] mi
| None ->
match stt.stt_value with
| Assign(n, e) ->
let nd, ni, ns = get_expr_asm n in
let d, i, s = get_expr_asm e in
add_to_bb bbs (i @ ni @ [Asm_ir.Mov_i(ns, s)]);
d @ nd @ bbd, bbs
| Proc(v, a) ->
let defs = ref [] in
let i, s =
List.fold_left2
(
fun (i, a) arg e ->
let d', i', a' =
get_expr_asm
(
if arg.def_pass_by_ref then
addr_of_expr e
else
e
)
in
defs := d' @ !defs;
i' :: i, a' :: a
) ([], [])
(
match (get_var_def v).def_value with
| Function f -> f.func_args
| _ -> raise (Asm_error ("internal error in asm_of_stts (using a variable which is not an procedure as a procedure)"))
) a
in
let i = List.concat (List.rev i) in
let p =
match (get_var_def v).def_value with
| Function f -> f
| _ -> raise (Parse_error("internal error, procedure is not a procedure", v.var_pos))
in
add_to_bb bbs (i @ [Asm_ir.Proc(p.func_asm_def, s)]); !defs @ bbd, bbs
| If(e, s1, s2) ->
let de, ae, re = get_expr_asm e
and ds1, as1 = asm_of_stts (get_stts_list s1)
and ds2, as2 = asm_of_stts (get_stts_list s2)
in
let bbr = new_bb [] (Asm_ir.If(re, as1, as2, bbs)) in
add_to_bb bbr ae;
de @ ds1 @ ds2 @ bbd, bbr
| While(e, s1) ->
let de, ae, re = get_expr_asm e
and ds1, as1 = asm_of_stts (get_stts_list s1)
in
let bbr = new_bb [] (Asm_ir.While(re, new_bb ae Asm_ir.End, as1, bbs)) in
de @ ds1 @ bbd, bbr
| Delete e ->
let d, i, s = get_expr_asm e in
add_to_bb bbs (i @ [Asm_ir.Delete s]);
d @ bbd, bbs
| Return e ->
let d, i, s = get_expr_asm e
in
add_to_bb bbs (i @ [Asm_ir.Return s]);
d @ bbd, bbs
| Compound cstts ->
asm_of_stts (cstts @ stts)
| Noop -> bbd, bbs
in
asm_of_stts block.block_stts
in
let rec remove_args args env =
match args, env with
| _ :: a, _ :: e -> remove_args a e
| [], e -> e
| _, [] -> raise (Asm_error "internal error in remove_args")
in
let vars, pd = handle_defs (List.map (snd) proc.func_value.block_env) in
let vars = (remove_args proc.func_args vars) in
let nvars, asm = asm_of_block proc.func_value in
let lex_depth = List.length lex_pos in
List.iter
(fun a ->
match a.def_asm with
| Asm_var vd ->
vd.Asm_ir.vd_lex_depth := lex_depth
| _ -> raise (Asm_error ("internal error in asm_of_proc (arguments of procedure are not variables)"))
) proc.func_args;
proc.func_asm_def.Asm_ir.proc_lex_depth <- lex_depth;
proc.func_asm_def.Asm_ir.proc_vars <- nvars @ vars;
proc.func_asm_def.Asm_ir.proc_value <- asm;
proc.func_asm_def.Asm_ir.proc_is_fun <- proc_type <> Unit;
pd, proc.func_asm_def