let generate_code prog =
let ret = ref "" in
let next_label = ref 0 in
let get_fresh_label () =
incr next_label;
"L" ^ (string_of_int !next_label)
in
let code_of_proc p =
let string_of_flag f =
(if f.flag_not then "n" else "") ^
(match f.flag_flag with
| Aflag -> "a"
| Bflag -> "b"
| Cflag -> "c"
| Eflag -> "e"
| Gflag -> "g"
| Lflag -> "l"
| Oflag -> "o"
| Pflag -> "p"
| Sflag -> "s"
| Zflag -> "z"
| Vflag _ -> raise (Asm_error "internal error in string_of_flag")
) ^
(if f.flag_eq then "e" else "")
in
let jump_of_flag f =
"j" ^ (string_of_flag f)
in
let get_display lex_depth r =
"\tmovl\t(DISPLAY" ^ (if lex_depth = 0 then "" else "+" ^ string_of_int (4 * lex_depth)) ^ "), " ^ (string_of_register r) ^ "\n"
in
let code_of_instr instr =
let before = ref "" in
let do_before s =
before := !before ^ s
in
let rec string_of_stack_pos base pos =
let rec get_reg_n = function
| Pos_base n ->
string_of_register base, n
| Pos_stack n -> "%esp", n
| Pos_pointed v -> code_of_var v, 0
| Pos_rec _
| Pos_arr _
| Pos_label _
| Pos_none -> raise (Asm_error "internal error in get_reg_n")
in
match pos with
| Pos_label n -> "$" ^ n
| Pos_rec(r, k) ->
(string_of_int k) ^ "(" ^ string_of_register (get_var_reg r) ^ ")"
| Pos_arr(a, v, n0, s) ->
(
let ar, an = string_of_register (get_var_reg a), 0 in
match v.var_def.vd_value with
| Some (Int i) ->
(string_of_int ((i - n0) * s)) ^ "(" ^ ar ^ ")"
| _ ->
let vr = get_var_reg v in
if s = 1 || s = 2 || s = 4 || s = 8 then
(string_of_int (an - n0 * s)) ^ "(" ^ ar ^ "," ^ string_of_register vr ^ "," ^ (string_of_int s) ^ ")"
else
(
do_before
(
"\txor\t%edi, %edi\n" ^
"\tpushl\t%ebp\n" ^
(
let ans = ref "" in
let s = ref s in
for i = 0 to 31
do
if !s mod 2 = 1 then
ans := !ans ^
"\tmovl\t" ^ (string_of_register vr) ^ ", %ebp\n" ^
"\tsall\t$" ^ (string_of_int i) ^ ", %ebp\n" ^
"\taddl\t%ebp, %edi\n";
s := !s lsr 1
done;
!ans
) ^
"\tpopl\t%ebp\n"
);
(string_of_int (an - n0 * s)) ^ "(" ^ ar ^ ",%edi,1)"
)
)
| Pos_none -> "%NOT_OTS"
| Pos_base _
| Pos_stack _
| Pos_pointed _ ->
let r, n = get_reg_n pos in
(if n = 0 then "" else string_of_int n) ^ "(" ^ r ^ ")"
and code_of_var_no_reg v =
match v.var_def.vd_value with
| Some(Int i) -> "$" ^ (string_of_int i)
| Some(Bool false) -> "$0"
| Some(Bool true) -> "$1"
| _ -> string_of_stack_pos ebp (get_var_pos v)
and code_of_var_reg v =
match v.var_reg with
| Some r -> string_of_register r
| None -> code_of_var_no_reg v
and code_of_var v =
if is_constant v then
code_of_var_no_reg v
else
code_of_var_reg v
in
!before ^
match instr with
| Add_i(v1, v2, v3) ->
let r2 = code_of_var_reg v2 in
let r3 = code_of_var v3 in
"\taddl\t" ^ r3 ^ ", " ^ r2 ^ "\n"
| Mult_i(v1, v2, v3) ->
let r2 = code_of_var_reg v2 in
let r3 = code_of_var v3 in
"\timull\t" ^ r3 ^ ", " ^ r2 ^ "\n"
| Mod_i(v1, v2, v3)
| Div_i(v1, v2, v3) ->
let r2 = code_of_var v2 in
let r3 = code_of_var_reg v3 in
"\tcltd\n" ^ "\tidivl\t" ^ r3 ^ "\n"
| Cmp_i(v1, v2, _, v3) ->
let r2 = code_of_var v2 in
let r3 = code_of_var v3 in
"\tcmpl\t" ^ r3 ^ ", " ^ r2 ^ "\n"
| Sub_i(v1, v2, v3) ->
let r2 = code_of_var_reg v2 in
let r3 = code_of_var v3 in
"\tsubl\t" ^ r3 ^ ", " ^ r2 ^ "\n"
| Not(v1, v2)
| Neg_i(v1, v2) ->
let r2 = code_of_var v2 in
"\tnegl\t" ^ r2 ^ "\n"
| And(v1, v2, v3) ->
let r2 = code_of_var_reg v2 in
let r3 = code_of_var v3 in
"\tandl\t" ^ r3 ^ ", " ^ r2 ^ "\n"
| Or(v1, v2, v3) ->
let r2 = code_of_var_reg v2 in
let r3 = code_of_var v3 in
"\torl\t" ^ r3 ^ ", " ^ r2 ^ "\n"
| Mov_b(v1, v2)
| Mov_i(v1, v2) ->
if v2.var_def.vd_value = Some(Int 0) then
let r1 = code_of_var_reg v1 in
"\txor\t" ^ r1 ^ ", " ^ r1 ^ "\n"
else
(
let ans =
let r1 = code_of_var_reg v1 in
let r2 = code_of_var v2 in
"\tmovl\t" ^ r2 ^ ", " ^ r1 ^ "\n"
in
match v1.var_reg with
| Some r1 ->
(
match v2.var_reg with
| Some r2 when r2 = r1 -> ""
| _ -> ans
)
| _ -> ans
)
| New(v1, n) ->
"\tpushl\t$" ^ string_of_int n ^ "\n" ^
"\tcall\tsbrk\n"
| Delete v1 ->
""
| Address_of(v1, v2) ->
let r1 = code_of_var_reg v1 in
get_display (get_var_lex v2) (get_var_reg v1) ^
"\tleal\t" ^ (string_of_stack_pos (get_var_reg v1) (get_var_pos v2)) ^ ", " ^ r1 ^ "\n"
| Unspill(lex_scope, v) ->
if not (get_var_ots v) then ""
else
(
let r' = code_of_var v in
if lex_scope then
match get_var_pos v with
| Pos_base b ->
(
match v.var_reg with
| None -> raise (Asm_error "trying to access a variable in an other lexical scope without being assigned to a reister")
| Some r ->
get_display (get_var_lex v) r ^
"\tmovl\t" ^ (string_of_int b) ^ "(" ^ (string_of_register r) ^ "), " ^ r' ^ "\n"
)
| _ -> raise (Asm_error "trying to unspill a variable not on the stack and not in the same lexical scope")
else
(
let old_reg = v.var_reg in
v.var_reg <- None;
let r = code_of_var v in
v.var_reg <- old_reg;
"\tmovl\t" ^ r ^ ", " ^ r' ^ "\n"
)
)
| Spill(lex_scope, r, vd) ->
if lex_scope then
match !(vd.vd_pos) with
| Pos_base b ->
get_display (get_vd_lex vd) edi ^
"\tmovl\t" ^ (string_of_register r) ^ ", " ^ (string_of_int b) ^ "(" ^ (string_of_register edi) ^ ")\n"
| _ -> raise (Asm_error "trying to spill a variable not on the stack and not in the same lexical scope")
else
"\tmovl\t" ^ (string_of_register r) ^ ", " ^ (string_of_stack_pos ebp (get_vd_pos vd)) ^ "\n"
| Call n -> "\tcall\t" ^ n ^ "\n"
| Set_var(f, v) ->
(
match v.var_reg with
| Some r ->
if r = esi then
let rtmp =
Reg_int
(
match r with
| Reg_int rn -> if rn < 3 then rn + 1 else 0
| _ -> raise (Asm_error "internal error")
)
in
let reg_name = string_of_char (string_of_register rtmp).[2] in
"\tpushl\t" ^ (string_of_register rtmp) ^ "\n" ^
"\tset" ^ (string_of_flag f) ^ "\t%" ^ reg_name ^ "l\n" ^
"\tmovzbl\t%" ^ reg_name ^ "l, " ^ (string_of_register r) ^ "\n" ^
"\tpopl\t" ^ (string_of_register rtmp) ^ "\n"
else
let reg_name = string_of_char (string_of_register r).[2] in
"\tset" ^ (string_of_flag f) ^ "\t%" ^ reg_name ^ "l\n" ^
"\tmovzbl\t%" ^ reg_name ^ "l, " ^ (string_of_register r) ^ "\n"
| None -> raise (Asm_error "internal error")
)
| Nop -> "\tnop\n"
| Push v -> "\tpushl\t" ^ (code_of_var v) ^ "\n"
| Push_o(v, len) ->
let r = code_of_var_reg v in
"\tsubl\t$" ^ (string_of_int len) ^ ", %esp\n" ^
"\tmovl\t" ^ r ^ ", %esi\n" ^
"\tmovl\t%esp, %edi\n" ^
"\tmovl\t$" ^ (string_of_int len) ^ ", %ecx\n" ^
"\trep movsb\n"
| Return v ->
let r = code_of_var_reg v in
"\tmovl\t" ^ r ^ ", %eax\n" ^
"\tmovl\t%ebp, %esp\n" ^
"\tpopl\t%ebp\n" ^
"\tret\n"
| Code c -> c
| Check_avail_with_flags _
| Check_avail _
| Assert_avail _
| Spill_var _
| Spill_all
| Read_flag _
| Proc _
| Fun _ -> raise (Asm_error "internal error in assembly generation")
in
let rec code_of_base_block bb =
(List.fold_left (fun s i -> s ^ code_of_instr i) "" bb.bb_block) ^ code_of_link bb.bb_link;
and code_of_link = function
| If(v, b1, b2, b3) ->
let c1 = code_of_base_block b1
and c2 = code_of_base_block b2
and c3 = code_of_base_block b3 in
let l2 = get_fresh_label () and l3 = get_fresh_label () in
(
match v.var_def.vd_value with
| Some(Bool b) ->
(if b then c1 else c2) ^ c3
| _ ->
(
match v.var_reg with
| Some (Reg_flag f) ->
"\t" ^ (jump_of_flag (neg_flag f)) ^ "\t" ^ l2 ^ "\n"
| Some (Reg_int r) ->
"\tcmpl\t$0, " ^ (string_of_register (Reg_int r)) ^ "\n" ^
"\tje\t" ^ l2 ^ "\n"
| None -> failwith "no value for jump's bool"
) ^
c1 ^ "\tjmp\t" ^ l3 ^ "\n" ^
l2 ^ ":\n" ^ c2 ^
l3 ^ ":\n" ^ c3
)
| While(v, be, b1, b2) ->
let ce = code_of_base_block be
and c1 = code_of_base_block b1
and c2 = code_of_base_block b2 in
let l1 = get_fresh_label () and l2 = get_fresh_label () in
(
match v.var_def.vd_value with
| Some(Bool b) ->
if b then
l1 ^ ":\n" ^ c1 ^ "\tjmp\t" ^ l1 ^ "\n"
else
c2
| _ ->
l1 ^ ":\n" ^ ce ^
(
match v.var_reg with
| Some (Reg_flag f) ->
"\t" ^ (jump_of_flag (neg_flag f)) ^ "\t" ^ l2 ^ "\n"
| Some (Reg_int r) ->
"\tcmpl\t$0, " ^ (string_of_register (Reg_int r)) ^ "\n" ^
"\tje\t" ^ l2 ^ "\n"
| None -> failwith "no value for jump's bool"
) ^
c1 ^ "\tjmp\t" ^ l1 ^ "\n" ^
l2 ^ ":\n" ^ c2
)
| End -> ""
in
ret := !ret ^
".globl " ^ p.proc_name ^ "\n" ^
"\t.type\t" ^ p.proc_name ^ ", @function\n" ^ p.proc_name ^ ":\n" ^
"\tpushl\t%ebp\n" ^ "\tmovl\t%esp, %ebp\n" ^
"\tmovl\t%ebp, (DISPLAY+" ^ (string_of_int (4 * p.proc_lex_depth)) ^ ")\n";
if p.proc_stack_size > 0 then
ret := !ret ^ "\tsubl\t$" ^ (string_of_int p.proc_stack_size) ^ ", %esp\n";
ret := !ret ^ code_of_base_block p.proc_value;
if not p.proc_is_fun then
ret := !ret ^ "\txor\t%eax, %eax\n" ^
"\tmovl\t%ebp, %esp\n" ^
"\tpopl\t%ebp\n" ^
"\tret\n\n"
in
let set_args_pos args =
ignore (List.fold_left (fun s a -> a.vd_pos := Pos_base (s + 8); s + (sizeof (get_vd_type a))) 0 args)
in
let rec get_stack_size pv =
List.fold_left (fun size vd ->
let set_on_the_stack () =
vd.vd_pos := Pos_base (-size - (sizeof (get_vd_type vd)));
size + (sizeof (get_vd_type vd))
in
match (get_vd_pos vd), get_vd_type vd with
| Pos_none, _ when (get_vd_ots vd) ->
set_on_the_stack ()
| _, Other _ ->
set_on_the_stack ()
| _ -> size
) 0 pv
in
List.iter
(fun p ->
set_args_pos p.proc_args;
allocate_registers p.proc_value p.proc_lex_depth;
if !Params.local_opts then
local_opt_base_block p.proc_value;
p.proc_stack_size <- get_stack_size p.proc_vars
) prog.prog_procs;
ret := "\t.file\t\"" ^ prog.prog_source_name ^ "\"\n" ^
"\t.section\t.data\nDISPLAY:\n\t.zero\t" ^ (string_of_int (4 * (prog.prog_max_depth + 1))) ^ "\n";
ret := !ret ^ "\t.text\n";
List.iter (fun p -> code_of_proc p) prog.prog_procs; !ret ^ "\t.size\tmain, .-main\n" ^ "\t.section\t.note.GNU-stack,\"\",@progbits\n" ^ "\t.ident\t\"Bifton 0.1.0\"\n"