355 lines
11 KiB
OCaml
355 lines
11 KiB
OCaml
(* "Sequentialization": from C-- to sequences of pseudo-instructions
|
|
with pseudo-registers. *)
|
|
|
|
open Misc
|
|
open Cmm
|
|
open Reg
|
|
open Selection
|
|
open Mach
|
|
|
|
(* Naming of registers *)
|
|
|
|
let all_regs_anonymous rv =
|
|
try
|
|
for i = 0 to Array.length rv - 1 do
|
|
if String.length rv.(i).name > 0 then raise Exit
|
|
done;
|
|
true
|
|
with Exit ->
|
|
false
|
|
|
|
let name_regs id rv =
|
|
if Array.length rv = 1 then
|
|
rv.(0).name <- Ident.name id
|
|
else
|
|
for i = 0 to Array.length rv - 1 do
|
|
rv.(i).name <- Ident.name id ^ "#" ^ string_of_int i
|
|
done
|
|
|
|
(* Buffering of instruction sequences *)
|
|
|
|
type instruction_sequence = instruction ref
|
|
|
|
let new_sequence() = ref dummy_instr
|
|
|
|
let insert desc arg res seq =
|
|
seq := instr_cons desc arg res !seq
|
|
|
|
let extract_sequence seq =
|
|
let rec extract res i =
|
|
if i == dummy_instr
|
|
then res
|
|
else extract (instr_cons i.desc i.arg i.res res) i.next in
|
|
extract (end_instr()) !seq
|
|
|
|
(* Insert a sequence of moves from one pseudoreg set to another. *)
|
|
|
|
let insert_moves src dst seq =
|
|
for i = 0 to Array.length src - 1 do
|
|
if src.(i).stamp <> dst.(i).stamp then
|
|
insert (Iop Imove) [|src.(i)|] [|dst.(i)|] seq
|
|
done
|
|
|
|
(* Insert moves and stackstores for function arguments and function results *)
|
|
|
|
let insert_move_args arg loc stacksize seq =
|
|
if stacksize <> 0 then insert (Iop(Istackoffset stacksize)) [||] [||] seq;
|
|
insert_moves arg loc seq
|
|
|
|
let insert_move_results loc res stacksize seq =
|
|
if stacksize <> 0 then insert(Iop(Istackoffset(-stacksize))) [||] [||] seq;
|
|
insert_moves loc res seq
|
|
|
|
(* "Join" two instruction sequences, making sure they return their results
|
|
in the same registers. *)
|
|
|
|
let join r1 seq1 r2 seq2 =
|
|
if Array.length r1 = 0 then r2
|
|
else if Array.length r2 = 0 then r1
|
|
else begin insert_moves r2 r1 seq2; r1 end
|
|
|
|
(* Same, for N branches *)
|
|
|
|
let join_array rs =
|
|
let dest = ref [||] in
|
|
for i = 0 to Array.length rs - 1 do
|
|
let (r, s) = rs.(i) in
|
|
if Array.length r > 0 then dest := r
|
|
done;
|
|
if Array.length !dest > 0 then
|
|
for i = 0 to Array.length rs - 1 do
|
|
let (r, s) = rs.(i) in
|
|
if Array.length r > 0 then insert_moves r !dest s
|
|
done;
|
|
!dest
|
|
|
|
(* Add the instructions for the given expression
|
|
at the end of the given sequence *)
|
|
|
|
let rec emit_expr env exp seq =
|
|
match exp with
|
|
Sconst c ->
|
|
let ty =
|
|
match c with
|
|
Const_int n -> typ_int
|
|
| Const_float f -> typ_float
|
|
| Const_symbol s -> typ_addr
|
|
| Const_pointer n -> typ_addr in
|
|
let r = Reg.newv ty in
|
|
insert (Iop(Iconstant c)) [||] r seq;
|
|
r
|
|
| Svar v ->
|
|
begin try
|
|
Tbl.find v env
|
|
with Not_found ->
|
|
fatal_error("Sequence.emit_expr: unbound var " ^ Ident.name v)
|
|
end
|
|
| Slet(v, e1, e2) ->
|
|
emit_expr (emit_let env v e1 seq) e2 seq
|
|
| Sassign(v, e1) ->
|
|
let rv =
|
|
try
|
|
Tbl.find v env
|
|
with Not_found ->
|
|
fatal_error ("Sequence.emit_expr: unbound var " ^ Ident.name v) in
|
|
let r1 = emit_expr env e1 seq in
|
|
insert_moves r1 rv seq;
|
|
[||]
|
|
| Stuple(ev, perm) ->
|
|
let rv = Array.new (Array.length ev) [||] in
|
|
List.iter (fun i -> rv.(i) <- emit_expr env ev.(i) seq) perm;
|
|
Array.concat(Array.to_list rv)
|
|
| Sop(Icall_ind, e1, ty) ->
|
|
Proc.contains_calls := true;
|
|
let r1 = emit_expr env e1 seq in
|
|
let rarg = Array.sub r1 1 (Array.length r1 - 1) in
|
|
let rd = Reg.newv ty in
|
|
let (loc_arg, stack_ofs) = Proc.loc_arguments rarg in
|
|
let loc_res = Proc.loc_results rd in
|
|
insert_move_args rarg loc_arg stack_ofs seq;
|
|
insert (Iop Icall_ind) (Array.append [|r1.(0)|] loc_arg) loc_res seq;
|
|
insert_move_results loc_res rd stack_ofs seq;
|
|
rd
|
|
| Sop(Icall_imm lbl, e1, ty) ->
|
|
Proc.contains_calls := true;
|
|
let r1 = emit_expr env e1 seq in
|
|
let rd = Reg.newv ty in
|
|
let (loc_arg, stack_ofs) = Proc.loc_arguments r1 in
|
|
let loc_res = Proc.loc_results rd in
|
|
insert_move_args r1 loc_arg stack_ofs seq;
|
|
insert (Iop(Icall_imm lbl)) loc_arg loc_res seq;
|
|
insert_move_results loc_res rd stack_ofs seq;
|
|
rd
|
|
| Sop(Iextcall lbl, e1, ty) ->
|
|
Proc.contains_calls := true;
|
|
let r1 = emit_expr env e1 seq in
|
|
let rd = Reg.newv ty in
|
|
let (loc_arg, stack_ofs) = Proc.loc_external_arguments r1 in
|
|
let loc_res = Proc.loc_external_results rd in
|
|
insert_move_args r1 loc_arg stack_ofs seq;
|
|
insert (Iop(Iextcall lbl)) loc_arg loc_res seq;
|
|
insert_move_results loc_res rd stack_ofs seq;
|
|
rd
|
|
| Sop(Iload(Word, addr), e1, ty) ->
|
|
let r1 = emit_expr env e1 seq in
|
|
let rd = Reg.newv ty in
|
|
let a = ref addr in
|
|
for i = 0 to Array.length ty - 1 do
|
|
insert(Iop(Iload(Word, !a))) r1 [|rd.(i)|] seq;
|
|
a := Arch.offset_addressing !a (size_component ty.(i))
|
|
done;
|
|
rd
|
|
| Sop(Istore(Word, addr), e1, _) ->
|
|
let r1 = emit_expr env e1 seq in
|
|
let na = Arch.num_args_addressing addr in
|
|
let ra = Array.sub r1 0 na in
|
|
let a = ref addr in
|
|
for i = na to Array.length r1 - 1 do
|
|
insert(Iop(Istore(Word, !a))) (Array.append [|r1.(i)|] ra) [||] seq;
|
|
a := Arch.offset_addressing !a (size_component r1.(i).typ)
|
|
done;
|
|
[||]
|
|
| Sop(Ialloc _, e1, _) ->
|
|
Proc.contains_calls := true;
|
|
let r1 = emit_expr env e1 seq in
|
|
let rd = Reg.newv typ_addr in
|
|
insert (Iop(Ialloc(Cmm.size_machtype(Array.map (fun r -> r.typ) r1))))
|
|
[||] rd seq;
|
|
let a =
|
|
ref (Arch.offset_addressing Arch.identity_addressing
|
|
(-Arch.size_int)) in
|
|
for i = 0 to Array.length r1 - 1 do
|
|
insert(Iop(Istore(Word, !a))) [|r1.(i); rd.(0)|] [||] seq;
|
|
a := Arch.offset_addressing !a (size_component r1.(i).typ)
|
|
done;
|
|
rd
|
|
| Sop(op, e1, ty) ->
|
|
begin match op with
|
|
Imodify -> Proc.contains_calls := true | _ -> ()
|
|
end;
|
|
let r1 = emit_expr env e1 seq in
|
|
let rd = Reg.newv ty in
|
|
begin try
|
|
(* Offer the processor description an opportunity to insert moves
|
|
before and after the operation, i.e. for two-address instructions,
|
|
or instructions using dedicated registers. *)
|
|
let (rsrc, rdst) = Proc.pseudoregs_for_operation op r1 rd in
|
|
insert_moves r1 rsrc seq;
|
|
insert (Iop op) rsrc rdst seq;
|
|
insert_moves rdst rd seq
|
|
with Proc.Use_default ->
|
|
(* Assume no constraints on arg and res registers *)
|
|
insert (Iop op) r1 rd seq
|
|
end;
|
|
rd
|
|
| Sproj(e1, ofs, len) ->
|
|
let r1 = emit_expr env e1 seq in
|
|
Array.sub r1 ofs len
|
|
| Ssequence(e1, e2) ->
|
|
emit_expr env e1 seq;
|
|
emit_expr env e2 seq
|
|
| Sifthenelse(cond, earg, eif, eelse) ->
|
|
let rarg = emit_expr env earg seq in
|
|
let (rif, sif) = emit_sequence env eif in
|
|
let (relse, selse) = emit_sequence env eelse in
|
|
let r = join rif sif relse selse in
|
|
insert (Iifthenelse(cond, extract_sequence sif, extract_sequence selse))
|
|
rarg [||] seq;
|
|
r
|
|
| Sswitch(esel, index, ecases) ->
|
|
let rsel = emit_expr env esel seq in
|
|
let rscases = Array.map (emit_sequence env) ecases in
|
|
let r = join_array rscases in
|
|
insert (Iswitch(index,
|
|
Array.map (fun (r, s) -> extract_sequence s) rscases))
|
|
rsel [||] seq;
|
|
r
|
|
| Sloop(ebody) ->
|
|
let (rarg, sbody) = emit_sequence env ebody in
|
|
insert (Iloop(extract_sequence sbody)) [||] [||] seq;
|
|
[||]
|
|
| Scatch(e1, e2) ->
|
|
let (r1, s1) = emit_sequence env e1 in
|
|
let (r2, s2) = emit_sequence env e2 in
|
|
let r = join r1 s1 r2 s2 in
|
|
insert (Icatch(extract_sequence s1, extract_sequence s2)) [||] [||] seq;
|
|
r
|
|
| Sexit ->
|
|
insert Iexit [||] [||] seq;
|
|
[||]
|
|
| Strywith(e1, v, e2) ->
|
|
let (r1, s1) = emit_sequence env e1 in
|
|
let rv = Reg.newv typ_addr in
|
|
let (r2, s2) = emit_sequence (Tbl.add v rv env) e2 in
|
|
let r = join r1 s1 r2 s2 in
|
|
insert
|
|
(Itrywith(extract_sequence s1,
|
|
instr_cons (Iop Imove) [|Proc.loc_exn_bucket|] rv
|
|
(extract_sequence s2)))
|
|
[||] [||] seq;
|
|
r
|
|
| Sraise e1 ->
|
|
let r1 = emit_expr env e1 seq in
|
|
insert Iraise r1 [||] seq;
|
|
[||]
|
|
|
|
and emit_sequence env exp =
|
|
let seq = new_sequence() in
|
|
let r = emit_expr env exp seq in
|
|
(r, seq)
|
|
|
|
and emit_let env v e1 seq =
|
|
let r1 = emit_expr env e1 seq in
|
|
if all_regs_anonymous r1 then begin
|
|
name_regs v r1;
|
|
Tbl.add v r1 env
|
|
end else begin
|
|
let rv = Array.new (Array.length r1) Reg.dummy in
|
|
for i = 0 to Array.length r1 - 1 do rv.(i) <- Reg.new r1.(i).typ done;
|
|
name_regs v rv;
|
|
insert_moves r1 rv seq;
|
|
Tbl.add v rv env
|
|
end
|
|
|
|
(* Same, but in tail position *)
|
|
|
|
let emit_return env exp seq =
|
|
let r = emit_expr env exp seq in
|
|
let loc = Proc.loc_results r in
|
|
insert_moves r loc seq;
|
|
insert Ireturn loc [||] seq
|
|
|
|
let rec emit_tail env exp seq =
|
|
match exp with
|
|
Slet(v, e1, e2) ->
|
|
emit_tail (emit_let env v e1 seq) e2 seq
|
|
| Sop(Icall_ind, e1, ty) ->
|
|
let r1 = emit_expr env e1 seq in
|
|
let rarg = Array.sub r1 1 (Array.length r1 - 1) in
|
|
let (loc_arg, stack_ofs) = Proc.loc_arguments rarg in
|
|
if stack_ofs <> 0 then
|
|
emit_return env exp seq
|
|
else begin
|
|
insert_moves rarg loc_arg seq;
|
|
insert (Iop Itailcall_ind) (Array.append [|r1.(0)|] loc_arg) [||] seq
|
|
end
|
|
| Sop(Icall_imm lbl, e1, ty) ->
|
|
let r1 = emit_expr env e1 seq in
|
|
let (loc_arg, stack_ofs) = Proc.loc_arguments r1 in
|
|
if stack_ofs <> 0 then
|
|
emit_return env exp seq
|
|
else begin
|
|
insert_moves r1 loc_arg seq;
|
|
insert (Iop(Itailcall_imm lbl)) loc_arg [||] seq
|
|
end
|
|
| Ssequence(e1, e2) ->
|
|
emit_expr env e1 seq;
|
|
emit_tail env e2 seq
|
|
| Sifthenelse(cond, earg, eif, eelse) ->
|
|
let rarg = emit_expr env earg seq in
|
|
insert (Iifthenelse(cond, emit_tail_sequence env eif,
|
|
emit_tail_sequence env eelse))
|
|
rarg [||] seq
|
|
| Sswitch(esel, index, ecases) ->
|
|
let rsel = emit_expr env esel seq in
|
|
insert (Iswitch(index, Array.map (emit_tail_sequence env) ecases))
|
|
rsel [||] seq
|
|
| Scatch(e1, e2) ->
|
|
insert (Icatch(emit_tail_sequence env e1, emit_tail_sequence env e2))
|
|
[||] [||] seq
|
|
| Sexit ->
|
|
insert Iexit [||] [||] seq
|
|
| Sraise e1 ->
|
|
let r1 = emit_expr env e1 seq in
|
|
let rd = [|Proc.loc_exn_bucket|] in
|
|
insert (Iop Imove) r1 rd seq;
|
|
insert Iraise rd [||] seq
|
|
| _ ->
|
|
emit_return env exp seq
|
|
|
|
and emit_tail_sequence env exp =
|
|
let seq = new_sequence() in
|
|
emit_tail env exp seq;
|
|
extract_sequence seq
|
|
|
|
(* Sequentialization of a function definition *)
|
|
|
|
let fundecl f =
|
|
Proc.contains_calls := false;
|
|
let rargs =
|
|
List.map
|
|
(fun (id, ty) -> let r = Reg.newv ty in name_regs id r; r)
|
|
f.Cmm.fun_args in
|
|
let rarg = Array.concat rargs in
|
|
let loc_arg = Proc.loc_parameters rarg in
|
|
let env =
|
|
List.fold_right2
|
|
(fun (id, ty) r env -> Tbl.add id r env)
|
|
f.Cmm.fun_args rargs Tbl.empty in
|
|
let seq = new_sequence() in
|
|
insert_moves loc_arg rarg seq;
|
|
emit_tail env (Selection.expression f.Cmm.fun_body) seq;
|
|
{ fun_name = f.Cmm.fun_name;
|
|
fun_args = loc_arg;
|
|
fun_body = extract_sequence seq }
|