let rec asm_of_proc name proc lex_pos =
let pos_in_proc = ref (-1) in
let get_lex_pos () =
incr pos_in_proc;
!pos_in_proc :: lex_pos
in
let handle_defs defs =
let proc_defs = ref [] in
let handle_def d =
match d.def_value with
| Constant c ->
let cd =
{
Asm_ast.vd_pos = 0;
Asm_ast.vd_size = sizeof c.expr_type;
Asm_ast.vd_value = Some (eval_expr c);
Asm_ast.vd_by_ref = false;
Asm_ast.vd_on_the_stack = false;
}
in
d.def_asm <- Asm_var cd; Asm_var cd
| Variable ->
let v =
Asm_var {
Asm_ast.vd_pos = 0;
Asm_ast.vd_size = sizeof d.def_type;
Asm_ast.vd_value = None;
Asm_ast.vd_by_ref = false;
Asm_ast.vd_on_the_stack = true;
}
in
d.def_asm <- v; v
| Variable_ref ->
let v =
Asm_var {
Asm_ast.vd_pos = 0;
Asm_ast.vd_size = 4;
Asm_ast.vd_value = None;
Asm_ast.vd_by_ref = true;
Asm_ast.vd_on_the_stack = true;
}
in
d.def_asm <- v; v
| Procedure p ->
let pd, pasm = asm_of_proc d.def_name p (get_lex_pos ()) in
d.def_asm <- Asm_proc pasm;
proc_defs := pd @ [pasm] @ !proc_defs;
Asm_proc pasm
| Type _ -> raise (Asm_error "internal error in handle_def (trying to get the asm for a type)")
in
let vars =
List.fold_left
(
fun l d ->
match handle_def d with
| Asm_var v -> v :: l
| _ -> l
) [] defs
in
vars, !proc_defs
in
let asm_of_block block =
let var_with_def d =
{
Asm_ast.var_reg = None;
Asm_ast.var_def = d;
Asm_ast.var_spilled = true;
Asm_ast.var_to_spill = true;
}
in
let fresh_int_var_def () =
{
Asm_ast.vd_pos = 0;
Asm_ast.vd_size = sizeof Integer;
Asm_ast.vd_value = None;
Asm_ast.vd_by_ref = false;
Asm_ast.vd_on_the_stack = false;
}
in
let fresh_int_var () =
let vd = fresh_int_var_def ()
in
vd, {
Asm_ast.var_reg = Some (fresh_reg ());
Asm_ast.var_def = vd;
Asm_ast.var_spilled = true;
Asm_ast.var_to_spill = true;
}
in
let get_var_asm v =
match v.var_def with
| Some d ->
(
match d.def_asm with
| Asm_var v -> v
| _ -> raise (Asm_error ("internal error in get_var_asm (with variable " ^ v.var_name ^ ")"))
)
| None -> raise (Asm_error ("internal error in get_var_asm (with variable " ^ v.var_name ^ ")"))
in
let get_proc_name v =
match v.var_def with
| Some d -> d.def_name
| None -> raise (Asm_error "internal error in get_proc_name")
in
let rec get_expr_asm e =
let vd, res = fresh_int_var () in
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_ast.Addi(res, v1, v2)], res
| Int i ->
vd.Asm_ast.vd_value <- Some (Asm_ast.Integer i); [vd], [], res
| Var(v, []) ->
res.Asm_ast.var_def <- get_var_asm v; [], [], res
in
let new_bb i mi =
{
Asm_ast.bb_block = i;
Asm_ast.bb_link = mi;
}
in
let add_to_bb bb i =
bb.Asm_ast.bb_block <- i @ bb.Asm_ast.bb_block
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_ast.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(v, e) ->
(
match v.var_type with
| Integer ->
let d, i, s = get_expr_asm e in
add_to_bb bbs (i @ [Asm_ast.Movi(var_with_def (get_var_asm v), s)]);
d @ bbd, bbs
)
| Proc(p, a) ->
let defs = ref [] in
let i, s =
List.fold_left
(
fun (i, a) e ->
let d', i', a' = get_expr_asm e in
defs := d' @ !defs;
i' :: i, a' :: a
) ([], []) a
in
let i = List.concat (List.rev i) in
add_to_bb bbs (i @ [Asm_ast.Call(get_proc_name p, s)]); !defs @ bbd, bbs
| ExtProc(n, a) ->
let defs = ref [] in
let i, s =
List.fold_left
(
fun (i, a) e ->
let d', i', a' = get_expr_asm e in
defs := d' @ !defs;
i' :: i, a' :: a
) ([], []) a
in
let i = List.concat (List.rev i) in
add_to_bb bbs (i @ [Asm_ast.ExtCall(n, 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
add_to_bb bbs ae;
de @ ds1 @ ds2 @ bbd, new_bb [] (Asm_ast.If(re, as1, as2, bbs))
| Compound cstts ->
asm_of_stts (cstts @ statements)
| 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 args, block = proc in
let vars, pd = handle_defs (List.map (fun (x, y) -> y) block.block_env) in
let vars = (remove_args args vars) in
let nvars, asm = asm_of_block block in
pd,
{
Asm_ast.proc_name = name;
Asm_ast.proc_vars = nvars @ vars;
Asm_ast.proc_value = asm;
}