1101 lines
28 KiB
OCaml
1101 lines
28 KiB
OCaml
open Common;;
|
|
|
|
(* FIXME (issue #1): thread a session object through this eventually. *)
|
|
let log_iltypes = ref false;;
|
|
|
|
(* IL type system, very rudimentary. *)
|
|
|
|
type bits =
|
|
Bits8
|
|
| Bits16
|
|
| Bits32
|
|
| Bits64
|
|
;;
|
|
|
|
type scalar_ty =
|
|
ValTy of bits
|
|
| AddrTy of referent_ty
|
|
|
|
and referent_ty =
|
|
ScalarTy of scalar_ty
|
|
| StructTy of referent_ty array
|
|
| UnionTy of referent_ty array
|
|
| ParamTy of ty_param_idx (* Thing of current-frame type-param #n *)
|
|
| OpaqueTy (* Unknown memory-resident thing. *)
|
|
| CodeTy (* Executable machine code. *)
|
|
| NilTy (* 0 bits of space. *)
|
|
;;
|
|
|
|
let (voidptr_t:scalar_ty) = AddrTy OpaqueTy;;
|
|
let (codeptr_t:scalar_ty) = AddrTy CodeTy;;
|
|
|
|
(* Operands. *)
|
|
|
|
type vreg = int ;;
|
|
type hreg = int ;;
|
|
type label = int ;;
|
|
type spill = int ;;
|
|
|
|
type reg =
|
|
Vreg of vreg
|
|
| Hreg of hreg
|
|
;;
|
|
|
|
type mem =
|
|
Abs of Asm.expr64
|
|
| RegIn of (reg * (Asm.expr64 option))
|
|
| Spill of spill
|
|
;;
|
|
|
|
type typed_reg = (reg * scalar_ty);;
|
|
type typed_mem = (mem * referent_ty);;
|
|
type typed_imm = (Asm.expr64 * ty_mach);;
|
|
type typed_imm_ptr = (fixup * referent_ty);;
|
|
|
|
type cell =
|
|
Reg of typed_reg
|
|
| Mem of typed_mem
|
|
;;
|
|
|
|
(*
|
|
* ImmPtr (a, rty) can be assigned to anything of scalar_ty
|
|
* AddrTy rty; the difference is that ImmAddr carries its value
|
|
* so can be used in cases where we want to have an immediate
|
|
* address constant-propagated through the code to the backend.
|
|
*)
|
|
type operand =
|
|
Cell of cell
|
|
| Imm of typed_imm
|
|
| ImmPtr of typed_imm_ptr
|
|
;;
|
|
|
|
|
|
type code =
|
|
CodeLabel of label (* Index into current quad block. *)
|
|
| CodePtr of operand
|
|
| CodeNone
|
|
;;
|
|
|
|
(* NB: for the most part, we let the register allocator assign spills
|
|
* from vregs, and we permanently allocate aliased slots to stack
|
|
* locations by static aliasing information early, in layout.
|
|
*
|
|
* The one awkward case this doesn't handle is when someone tries to
|
|
* pass a literal-atom to an alias-slot. This *requires* a memory slot
|
|
* but we only realize it rather late, much later than we'd normally
|
|
* have thougt to desugar the literal into a temporary.
|
|
*
|
|
* So in these cases, we let the trans module explicitly demand a
|
|
* "Spill n" operand, which the register allocator mops up before it
|
|
* gets started on the vregs.
|
|
*
|
|
* NOTE: if we were more clever we'd integrate vregs and spills like
|
|
* this together along with the general notion of a temporary way back
|
|
* at the desugaring stage, and use some kind of size-class
|
|
* consolidation so that spills with non-overlapping lifetimes could
|
|
* share memory. But we're not that clever yet.
|
|
*)
|
|
|
|
|
|
(* Helpers. *)
|
|
|
|
let direct_code_ptr fix =
|
|
(CodePtr (ImmPtr (fix, CodeTy)))
|
|
;;
|
|
|
|
let cell_referent_ty c =
|
|
match c with
|
|
Reg (_, st) -> ScalarTy st
|
|
| Mem (_, rt) -> rt
|
|
;;
|
|
|
|
let cell_is_nil c =
|
|
match c with
|
|
Mem (_, NilTy) -> true
|
|
| Reg (_, AddrTy NilTy) -> true
|
|
| _ -> false
|
|
;;
|
|
|
|
let operand_is_nil o =
|
|
match o with
|
|
Cell c -> cell_is_nil c
|
|
| _ -> false
|
|
;;
|
|
|
|
let mem_off (mem:mem) (off:Asm.expr64) : mem =
|
|
let addto e = Asm.ADD (off, e) in
|
|
match mem with
|
|
Abs e -> Abs (addto e)
|
|
| RegIn (r, None) -> RegIn (r, Some off)
|
|
| RegIn (r, Some e) -> RegIn (r, Some (addto e))
|
|
| Spill _ -> bug () "Adding offset to spill slot"
|
|
;;
|
|
|
|
let mem_off_imm (mem:mem) (imm:int64) : mem =
|
|
mem_off mem (Asm.IMM imm)
|
|
;;
|
|
|
|
|
|
(* Quads. *)
|
|
|
|
type binop =
|
|
ADD | SUB
|
|
| IMUL | UMUL
|
|
| IDIV | UDIV
|
|
| IMOD | UMOD
|
|
| AND | OR | XOR
|
|
| LSL | LSR | ASR
|
|
;;
|
|
|
|
type unop =
|
|
NEG | NOT
|
|
| UMOV | IMOV
|
|
| ZERO
|
|
;;
|
|
|
|
type jmpop =
|
|
JE | JNE
|
|
| JZ | JNZ (* FIXME: Synonyms with JE/JNE in x86, others? *)
|
|
| JL | JLE | JG | JGE (* Signed. *)
|
|
| JB | JBE | JA | JAE (* Unsigned. *)
|
|
| JC | JNC | JO | JNO
|
|
| JMP
|
|
;;
|
|
|
|
type binary =
|
|
{
|
|
binary_op: binop;
|
|
binary_dst: cell;
|
|
binary_lhs: operand;
|
|
binary_rhs: operand
|
|
}
|
|
;;
|
|
|
|
type unary =
|
|
{
|
|
unary_op: unop;
|
|
unary_dst: cell;
|
|
unary_src: operand
|
|
}
|
|
;;
|
|
|
|
type cmp =
|
|
{
|
|
cmp_lhs: operand;
|
|
cmp_rhs: operand
|
|
}
|
|
;;
|
|
|
|
type lea =
|
|
{
|
|
lea_dst: cell;
|
|
lea_src: operand
|
|
}
|
|
;;
|
|
|
|
type jmp =
|
|
{
|
|
jmp_op: jmpop;
|
|
jmp_targ: code;
|
|
}
|
|
;;
|
|
|
|
type call =
|
|
{
|
|
call_dst: cell;
|
|
call_targ: code
|
|
}
|
|
|
|
type quad' =
|
|
Binary of binary
|
|
| Unary of unary
|
|
| Lea of lea
|
|
| Cmp of cmp
|
|
| Jmp of jmp
|
|
| Push of operand
|
|
| Pop of cell
|
|
| Call of call
|
|
| Debug (* Debug-break pseudo-instruction. *)
|
|
| Enter of fixup (* Enter-fixup-block pseudo-instruction. *)
|
|
| Leave (* Leave-fixup-block pseudo-instruction. *)
|
|
| Ret (* Return to caller. *)
|
|
| Nop (* Keep this quad here, emit CPU nop. *)
|
|
| Dead (* Keep this quad but emit nothing. *)
|
|
| Regfence (* Clobber all hregs. *)
|
|
| End (* Space past the end of quads to emit. *)
|
|
;;
|
|
|
|
type quad =
|
|
{ quad_fixup: fixup option;
|
|
quad_implicits: label list;
|
|
quad_body: quad'; }
|
|
|
|
type quads = quad array ;;
|
|
|
|
(* Query functions. *)
|
|
|
|
let cell_is_scalar (c:cell) : bool =
|
|
match c with
|
|
Reg (_, _) -> true
|
|
| Mem (_, ScalarTy _) -> true
|
|
| _ -> false
|
|
;;
|
|
|
|
|
|
let bits_of_ty_mach (tm:ty_mach) : bits =
|
|
match tm with
|
|
| TY_u8 -> Bits8
|
|
| TY_i8 -> Bits8
|
|
| TY_u16 -> Bits16
|
|
| TY_i16 -> Bits16
|
|
| TY_u32 -> Bits32
|
|
| TY_i32 -> Bits32
|
|
| TY_u64 -> Bits64
|
|
| TY_i64 -> Bits64
|
|
| TY_f32 -> Bits32
|
|
| TY_f64 -> Bits64
|
|
;;
|
|
|
|
let cell_scalar_ty (c:cell) : scalar_ty =
|
|
match c with
|
|
Reg (_, st) -> st
|
|
| Mem (_, ScalarTy st) -> st
|
|
| _ -> bug () "mem of non-scalar in Il.cell_scalar_ty"
|
|
;;
|
|
|
|
let operand_scalar_ty (op:operand) : scalar_ty =
|
|
match op with
|
|
Cell c -> cell_scalar_ty c
|
|
| Imm (_, t) -> ValTy (bits_of_ty_mach t)
|
|
| ImmPtr (_, t) -> AddrTy t
|
|
;;
|
|
|
|
|
|
let scalar_ty_bits (word_bits:bits) (st:scalar_ty) : bits =
|
|
match st with
|
|
ValTy bits -> bits
|
|
| AddrTy _ -> word_bits
|
|
;;
|
|
|
|
let cell_bits (word_bits:bits) (c:cell) : bits =
|
|
match c with
|
|
Reg (_, st) -> scalar_ty_bits word_bits st
|
|
| Mem (_, ScalarTy st) -> scalar_ty_bits word_bits st
|
|
| Mem _ -> bug () "mem of non-scalar in Il.cell_bits"
|
|
;;
|
|
|
|
let operand_bits (word_bits:bits) (op:operand) : bits =
|
|
match op with
|
|
Cell cell -> cell_bits word_bits cell
|
|
| Imm (_, tm) -> bits_of_ty_mach tm
|
|
| ImmPtr _ -> word_bits
|
|
;;
|
|
|
|
let bits_size (bits:bits) : int64 =
|
|
match bits with
|
|
Bits8 -> 1L
|
|
| Bits16 -> 2L
|
|
| Bits32 -> 4L
|
|
| Bits64 -> 8L
|
|
;;
|
|
|
|
let bits_align (bits:bits) : int64 =
|
|
match bits with
|
|
Bits8 -> 1L
|
|
| Bits16 -> 2L
|
|
| Bits32 -> 4L
|
|
| Bits64 -> 8L
|
|
;;
|
|
|
|
let scalar_ty_size (word_bits:bits) (st:scalar_ty) : int64 =
|
|
bits_size (scalar_ty_bits word_bits st)
|
|
;;
|
|
|
|
let scalar_ty_align (word_bits:bits) (st:scalar_ty) : int64 =
|
|
bits_align (scalar_ty_bits word_bits st)
|
|
;;
|
|
|
|
let rec referent_ty_layout (word_bits:bits) (rt:referent_ty) : (size * size) =
|
|
match rt with
|
|
ScalarTy st -> (SIZE_fixed (scalar_ty_size word_bits st),
|
|
SIZE_fixed (scalar_ty_align word_bits st))
|
|
| StructTy rts ->
|
|
begin
|
|
let accum (off,align) rt : (size * size) =
|
|
let (elt_size, elt_align) = referent_ty_layout word_bits rt in
|
|
let elt_off = align_sz elt_align off in
|
|
(add_sz elt_off elt_size, max_sz elt_align align)
|
|
in
|
|
Array.fold_left accum (SIZE_fixed 0L, SIZE_fixed 1L) rts
|
|
end
|
|
| UnionTy rts ->
|
|
begin
|
|
let accum (sz,align) rt : (size * size) =
|
|
let (elt_size, elt_align) = referent_ty_layout word_bits rt in
|
|
(max_sz sz elt_size, max_sz elt_align align)
|
|
in
|
|
Array.fold_left accum (SIZE_fixed 0L, SIZE_fixed 1L) rts
|
|
end
|
|
| OpaqueTy -> bug () "opaque ty in referent_ty_layout"
|
|
| CodeTy -> bug () "code ty in referent_ty_layout"
|
|
| ParamTy i -> (SIZE_param_size i, SIZE_param_align i)
|
|
| NilTy -> (SIZE_fixed 0L, SIZE_fixed 1L)
|
|
|
|
and referent_ty_size (word_bits:bits) (rt:referent_ty) : size =
|
|
(fst (referent_ty_layout word_bits rt))
|
|
|
|
and referent_ty_align (word_bits:bits) (rt:referent_ty) : size =
|
|
(snd (referent_ty_layout word_bits rt))
|
|
|
|
;;
|
|
|
|
let get_element_offset
|
|
(word_bits:bits)
|
|
(elts:referent_ty array)
|
|
(i:int)
|
|
: size =
|
|
let elts_before = Array.sub elts 0 i in
|
|
let elt_rty = elts.(i) in
|
|
let elts_before_size = referent_ty_size word_bits (StructTy elts_before) in
|
|
let elt_align = referent_ty_align word_bits elt_rty in
|
|
let elt_off = align_sz elt_align elts_before_size in
|
|
elt_off
|
|
;;
|
|
|
|
(* Processor. *)
|
|
|
|
type quad_processor =
|
|
{ qp_reg: (quad_processor -> reg -> reg);
|
|
qp_mem: (quad_processor -> mem -> mem);
|
|
qp_cell_read: (quad_processor -> cell -> cell);
|
|
qp_cell_write: (quad_processor -> cell -> cell);
|
|
qp_code: (quad_processor -> code -> code);
|
|
qp_op: (quad_processor -> operand -> operand); }
|
|
;;
|
|
|
|
let identity_processor =
|
|
let qp_cell = (fun qp c -> match c with
|
|
Reg (r, b) -> Reg (qp.qp_reg qp r, b)
|
|
| Mem (a, b) -> Mem (qp.qp_mem qp a, b))
|
|
in
|
|
{ qp_reg = (fun _ r -> r);
|
|
qp_mem = (fun qp a -> match a with
|
|
RegIn (r, o) -> RegIn (qp.qp_reg qp r, o)
|
|
| Abs _
|
|
| Spill _ -> a);
|
|
qp_cell_read = qp_cell;
|
|
qp_cell_write = qp_cell;
|
|
qp_code = (fun qp c -> match c with
|
|
CodePtr op -> CodePtr (qp.qp_op qp op)
|
|
| CodeLabel _
|
|
| CodeNone -> c);
|
|
qp_op = (fun qp op -> match op with
|
|
Cell c -> Cell (qp.qp_cell_read qp c)
|
|
| ImmPtr _ -> op
|
|
| Imm _ -> op) }
|
|
;;
|
|
|
|
let process_quad (qp:quad_processor) (q:quad) : quad =
|
|
{ q with
|
|
quad_body = match q.quad_body with
|
|
Binary b ->
|
|
Binary { b with
|
|
binary_dst = qp.qp_cell_write qp b.binary_dst;
|
|
binary_lhs = qp.qp_op qp b.binary_lhs;
|
|
binary_rhs = qp.qp_op qp b.binary_rhs }
|
|
| Unary u ->
|
|
Unary { u with
|
|
unary_dst = qp.qp_cell_write qp u.unary_dst;
|
|
unary_src = qp.qp_op qp u.unary_src }
|
|
|
|
| Lea le ->
|
|
Lea { lea_dst = qp.qp_cell_write qp le.lea_dst;
|
|
lea_src = qp.qp_op qp le.lea_src }
|
|
|
|
| Cmp c ->
|
|
Cmp { cmp_lhs = qp.qp_op qp c.cmp_lhs;
|
|
cmp_rhs = qp.qp_op qp c.cmp_rhs }
|
|
|
|
| Jmp j ->
|
|
Jmp { j with
|
|
jmp_targ = qp.qp_code qp j.jmp_targ }
|
|
|
|
| Push op ->
|
|
Push (qp.qp_op qp op)
|
|
|
|
| Pop c ->
|
|
Pop (qp.qp_cell_write qp c)
|
|
|
|
| Call c ->
|
|
Call { call_dst = qp.qp_cell_write qp c.call_dst;
|
|
call_targ = qp.qp_code qp c.call_targ }
|
|
|
|
| Ret -> Ret
|
|
| Nop -> Nop
|
|
| Debug -> Debug
|
|
| Regfence -> Regfence
|
|
| Enter f -> Enter f
|
|
| Leave -> Leave
|
|
| Dead -> Dead
|
|
| End -> End }
|
|
;;
|
|
|
|
let visit_quads (qp:quad_processor) (qs:quads) : unit =
|
|
Array.iter (fun x ->ignore ( process_quad qp x); ()) qs
|
|
;;
|
|
|
|
let process_quads (qp:quad_processor) (qs:quads) : quads =
|
|
Array.map (process_quad qp) qs
|
|
;;
|
|
|
|
let rewrite_quads (qp:quad_processor) (qs:quads) : unit =
|
|
for i = 0 to ((Array.length qs) - 1) do
|
|
qs.(i) <- process_quad qp qs.(i)
|
|
done
|
|
;;
|
|
|
|
|
|
(* A little partial-evaluator to help lowering sizes. *)
|
|
|
|
let rec size_to_expr64 (a:size) : Asm.expr64 option =
|
|
let binary a b f =
|
|
match (size_to_expr64 a, size_to_expr64 b) with
|
|
(Some a, Some b) -> Some (f a b)
|
|
| _ -> None
|
|
in
|
|
match a with
|
|
SIZE_fixed i -> Some (Asm.IMM i)
|
|
| SIZE_fixup_mem_sz f -> Some (Asm.M_SZ f)
|
|
| SIZE_fixup_mem_pos f -> Some (Asm.M_POS f)
|
|
| SIZE_rt_neg s ->
|
|
begin
|
|
match (size_to_expr64 s) with
|
|
None -> None
|
|
| Some s -> Some (Asm.NEG s)
|
|
end
|
|
| SIZE_rt_add (a, b) -> binary a b (fun a b -> Asm.ADD (a,b))
|
|
| SIZE_rt_mul (a, b) -> binary a b (fun a b -> Asm.MUL (a,b))
|
|
| SIZE_rt_max (a, b) -> binary a b (fun a b -> Asm.MAX (a,b))
|
|
| SIZE_rt_align (a, b) -> binary a b (fun a b -> Asm.ALIGN (a,b))
|
|
| _ -> None
|
|
;;
|
|
|
|
|
|
(* Formatters. *)
|
|
|
|
let string_of_bits (b:bits) : string =
|
|
match b with
|
|
Bits8 -> "b8"
|
|
| Bits16 -> "b16"
|
|
| Bits32 -> "b32"
|
|
| Bits64 -> "b64"
|
|
;;
|
|
|
|
let rec string_of_scalar_ty (s:scalar_ty) : string =
|
|
match s with
|
|
ValTy b -> (string_of_bits b)
|
|
| AddrTy r -> (string_of_referent_ty r) ^ "*"
|
|
|
|
and string_of_referent_ty (r:referent_ty) : string =
|
|
match r with
|
|
ScalarTy s -> (string_of_scalar_ty s)
|
|
| StructTy rs ->
|
|
Printf.sprintf "[%s]"
|
|
(String.concat ","
|
|
(Array.to_list (Array.map string_of_referent_ty rs)))
|
|
| UnionTy rs ->
|
|
Printf.sprintf "(%s)"
|
|
(String.concat "|"
|
|
(Array.to_list (Array.map string_of_referent_ty rs)))
|
|
| ParamTy i -> Printf.sprintf "#%d" i
|
|
| OpaqueTy -> "?"
|
|
| CodeTy -> "!"
|
|
| NilTy -> "()"
|
|
;;
|
|
|
|
|
|
type hreg_formatter = hreg -> string;;
|
|
|
|
let string_of_reg (f:hreg_formatter) (r:reg) : string =
|
|
match r with
|
|
Vreg i -> Printf.sprintf "<v%d>" i
|
|
| Hreg i -> f i
|
|
;;
|
|
|
|
let string_of_off (e:Asm.expr64 option) : string =
|
|
match e with
|
|
None -> ""
|
|
| Some (Asm.IMM i) when (i64_lt i 0L) ->
|
|
Printf.sprintf " - 0x%Lx" (Int64.neg i)
|
|
| Some e' -> " + " ^ (Asm.string_of_expr64 e')
|
|
;;
|
|
|
|
let string_of_mem (f:hreg_formatter) (a:mem) : string =
|
|
match a with
|
|
Abs e ->
|
|
Printf.sprintf "[%s]" (Asm.string_of_expr64 e)
|
|
| RegIn (r, off) ->
|
|
Printf.sprintf "[%s%s]" (string_of_reg f r) (string_of_off off)
|
|
| Spill i ->
|
|
Printf.sprintf "[<spill %d>]" i
|
|
;;
|
|
let string_of_cell (f:hreg_formatter) (c:cell) : string =
|
|
match c with
|
|
Reg (r,ty) ->
|
|
if !log_iltypes
|
|
then
|
|
Printf.sprintf "%s:%s" (string_of_reg f r) (string_of_scalar_ty ty)
|
|
else
|
|
Printf.sprintf "%s" (string_of_reg f r)
|
|
| Mem (a,ty) ->
|
|
if !log_iltypes
|
|
then
|
|
Printf.sprintf "%s:%s"
|
|
(string_of_mem f a) (string_of_referent_ty ty)
|
|
else
|
|
Printf.sprintf "%s" (string_of_mem f a)
|
|
;;
|
|
|
|
let string_of_operand (f:hreg_formatter) (op:operand) : string =
|
|
match op with
|
|
Cell c -> string_of_cell f c
|
|
| ImmPtr (f, ty) ->
|
|
if !log_iltypes
|
|
then
|
|
Printf.sprintf "$<%s>.mpos:%s*"
|
|
f.fixup_name (string_of_referent_ty ty)
|
|
else
|
|
Printf.sprintf "$<%s>.mpos" f.fixup_name
|
|
| Imm (i, ty) ->
|
|
if !log_iltypes
|
|
then
|
|
Printf.sprintf "$%s:%s"
|
|
(Asm.string_of_expr64 i) (string_of_ty_mach ty)
|
|
else
|
|
Printf.sprintf "$%s" (Asm.string_of_expr64 i)
|
|
;;
|
|
|
|
|
|
let string_of_code (f:hreg_formatter) (c:code) : string =
|
|
match c with
|
|
CodeLabel lab -> Printf.sprintf "<label %d>" lab
|
|
| CodePtr op -> string_of_operand f op
|
|
| CodeNone -> "<none>"
|
|
;;
|
|
|
|
|
|
let string_of_binop (op:binop) : string =
|
|
match op with
|
|
ADD -> "add"
|
|
| SUB -> "sub"
|
|
| IMUL -> "imul"
|
|
| UMUL -> "umul"
|
|
| IDIV -> "idiv"
|
|
| UDIV -> "udiv"
|
|
| IMOD -> "imod"
|
|
| UMOD -> "umod"
|
|
| AND -> "and"
|
|
| OR -> "or"
|
|
| XOR -> "xor"
|
|
| LSL -> "lsl"
|
|
| LSR -> "lsr"
|
|
| ASR -> "asr"
|
|
;;
|
|
|
|
let string_of_unop (op:unop) : string =
|
|
match op with
|
|
NEG -> "neg"
|
|
| NOT -> "not"
|
|
| UMOV -> "umov"
|
|
| IMOV -> "imov"
|
|
| ZERO -> "zero"
|
|
;;
|
|
|
|
let string_of_jmpop (op:jmpop) : string =
|
|
match op with
|
|
JE -> "je"
|
|
| JNE -> "jne"
|
|
| JL -> "jl"
|
|
| JLE -> "jle"
|
|
| JG -> "jg"
|
|
| JGE -> "jge"
|
|
| JB -> "jb"
|
|
| JBE -> "jbe"
|
|
| JA -> "ja"
|
|
| JAE -> "jae"
|
|
| JC -> "jc"
|
|
| JNC ->"jnc"
|
|
| JO -> "jo"
|
|
| JNO -> "jno"
|
|
| JZ -> "jz"
|
|
| JNZ ->"jnz"
|
|
| JMP -> "jmp"
|
|
;;
|
|
|
|
let string_of_quad (f:hreg_formatter) (q:quad) : string =
|
|
match q.quad_body with
|
|
Binary b ->
|
|
Printf.sprintf "%s = %s %s %s"
|
|
(string_of_cell f b.binary_dst)
|
|
(string_of_operand f b.binary_lhs)
|
|
(string_of_binop b.binary_op)
|
|
(string_of_operand f b.binary_rhs)
|
|
|
|
| Unary u ->
|
|
Printf.sprintf "%s = %s %s"
|
|
(string_of_cell f u.unary_dst)
|
|
(string_of_unop u.unary_op)
|
|
(string_of_operand f u.unary_src)
|
|
|
|
| Cmp c ->
|
|
Printf.sprintf "cmp %s %s"
|
|
(string_of_operand f c.cmp_lhs)
|
|
(string_of_operand f c.cmp_rhs)
|
|
|
|
| Lea le ->
|
|
Printf.sprintf "lea %s %s"
|
|
(string_of_cell f le.lea_dst)
|
|
(string_of_operand f le.lea_src)
|
|
|
|
| Jmp j ->
|
|
Printf.sprintf "%s %s"
|
|
(string_of_jmpop j.jmp_op)
|
|
(string_of_code f j.jmp_targ)
|
|
|
|
| Push op ->
|
|
Printf.sprintf "push %s"
|
|
(string_of_operand f op)
|
|
|
|
| Pop c ->
|
|
Printf.sprintf "%s = pop"
|
|
(string_of_cell f c)
|
|
|
|
| Call c ->
|
|
Printf.sprintf "%s = call %s"
|
|
(string_of_cell f c.call_dst)
|
|
(string_of_code f c.call_targ)
|
|
|
|
| Ret -> "ret"
|
|
| Nop -> "nop"
|
|
| Dead -> "dead"
|
|
| Debug -> "debug"
|
|
| Regfence -> "regfence"
|
|
| Enter _ -> "enter lexical block"
|
|
| Leave -> "leave lexical block"
|
|
| End -> "---"
|
|
;;
|
|
|
|
|
|
|
|
(* Emitters. *)
|
|
|
|
|
|
type emitter = { mutable emit_pc: int;
|
|
mutable emit_next_vreg: int option;
|
|
mutable emit_next_spill: int;
|
|
emit_preallocator: (quad' -> quad');
|
|
emit_is_2addr: bool;
|
|
mutable emit_quads: quads;
|
|
emit_annotations: (int,string) Hashtbl.t;
|
|
emit_size_cache: ((size,operand) Hashtbl.t) Stack.t;
|
|
emit_node: node_id option;
|
|
}
|
|
|
|
|
|
let badq = { quad_fixup = None;
|
|
quad_implicits = [];
|
|
quad_body = End }
|
|
;;
|
|
|
|
|
|
let deadq = { quad_fixup = None;
|
|
quad_implicits = [];
|
|
quad_body = Dead }
|
|
;;
|
|
|
|
|
|
let new_emitter
|
|
(preallocator:quad' -> quad')
|
|
(is_2addr:bool)
|
|
(vregs_ok:bool)
|
|
(node:node_id option)
|
|
: emitter =
|
|
{
|
|
emit_pc = 0;
|
|
emit_next_vreg = (if vregs_ok then Some 0 else None);
|
|
emit_next_spill = 0;
|
|
emit_preallocator = preallocator;
|
|
emit_is_2addr = is_2addr;
|
|
emit_quads = Array.create 4 badq;
|
|
emit_annotations = Hashtbl.create 0;
|
|
emit_size_cache = Stack.create ();
|
|
emit_node = node;
|
|
}
|
|
;;
|
|
|
|
|
|
let num_vregs (e:emitter) : int =
|
|
match e.emit_next_vreg with
|
|
None -> 0
|
|
| Some i -> i
|
|
;;
|
|
|
|
let next_vreg_num (e:emitter) : vreg =
|
|
match e.emit_next_vreg with
|
|
None -> bug () "Il.next_vreg_num on non-vreg emitter"
|
|
| Some i ->
|
|
e.emit_next_vreg <- Some (i + 1);
|
|
i
|
|
;;
|
|
|
|
let next_vreg (e:emitter) : reg =
|
|
Vreg (next_vreg_num e)
|
|
;;
|
|
|
|
let next_vreg_cell (e:emitter) (s:scalar_ty) : cell =
|
|
Reg ((next_vreg e), s)
|
|
;;
|
|
|
|
let next_spill (e:emitter) : spill =
|
|
let i = e.emit_next_spill in
|
|
e.emit_next_spill <- i + 1;
|
|
i
|
|
;;
|
|
|
|
let next_spill_slot (e:emitter) (r:referent_ty) : typed_mem =
|
|
(Spill (next_spill e), r);
|
|
;;
|
|
|
|
|
|
let grow_if_necessary e =
|
|
let len = Array.length e.emit_quads in
|
|
if e.emit_pc >= len - 1
|
|
then
|
|
let n = Array.create (2 * len) badq in
|
|
Array.blit e.emit_quads 0 n 0 len;
|
|
e.emit_quads <- n
|
|
;;
|
|
|
|
|
|
let binary (op:binop) (dst:cell) (lhs:operand) (rhs:operand) : quad' =
|
|
Binary { binary_op = op;
|
|
binary_dst = dst;
|
|
binary_lhs = lhs;
|
|
binary_rhs = rhs }
|
|
;;
|
|
|
|
let unary (op:unop) (dst:cell) (src:operand) : quad' =
|
|
Unary { unary_op = op;
|
|
unary_dst = dst;
|
|
unary_src = src }
|
|
|
|
let jmp (op:jmpop) (targ:code) : quad' =
|
|
Jmp { jmp_op = op;
|
|
jmp_targ = targ; }
|
|
;;
|
|
|
|
|
|
let lea (dst:cell) (src:operand) : quad' =
|
|
Lea { lea_dst = dst;
|
|
lea_src = src; }
|
|
;;
|
|
|
|
let cmp (lhs:operand) (rhs:operand) : quad' =
|
|
Cmp { cmp_lhs = lhs;
|
|
cmp_rhs = rhs; }
|
|
;;
|
|
|
|
let call (dst:cell) (targ:code) : quad' =
|
|
Call { call_dst = dst;
|
|
call_targ = targ; }
|
|
;;
|
|
|
|
let umov (dst:cell) (src:operand) : quad' =
|
|
if (cell_is_nil dst || operand_is_nil src)
|
|
then Dead
|
|
else unary UMOV dst src
|
|
;;
|
|
|
|
let zero (dst:cell) (count:operand) : quad' =
|
|
unary ZERO dst count
|
|
;;
|
|
|
|
let is_mov uop =
|
|
match uop with
|
|
UMOV | IMOV -> true
|
|
| _ -> false
|
|
;;
|
|
|
|
let mk_quad (q':quad') : quad =
|
|
{ quad_body = q';
|
|
quad_implicits = [];
|
|
quad_fixup = None }
|
|
;;
|
|
|
|
let emit_full
|
|
(e:emitter)
|
|
(fix:fixup option)
|
|
(implicits:label list)
|
|
(q':quad')
|
|
: unit =
|
|
let fixup = ref fix in
|
|
let emit_quad_bottom q' =
|
|
grow_if_necessary e;
|
|
e.emit_quads.(e.emit_pc) <- { quad_body = q';
|
|
quad_implicits = implicits;
|
|
quad_fixup = (!fixup) };
|
|
fixup := None;
|
|
e.emit_pc <- e.emit_pc + 1
|
|
in
|
|
|
|
let emit_quad (q':quad') : unit =
|
|
(* re-decay any freshly generated mem-mem movs. *)
|
|
match q' with
|
|
Unary { unary_dst = Mem (dst_mem, ScalarTy src_st);
|
|
unary_src = Cell (Mem (src_mem, ScalarTy dst_st));
|
|
unary_op = op }
|
|
when is_mov op ->
|
|
let v = next_vreg_cell e dst_st in
|
|
emit_quad_bottom
|
|
(unary op v (Cell (Mem (src_mem, ScalarTy src_st))));
|
|
emit_quad_bottom
|
|
(unary op (Mem (dst_mem, ScalarTy dst_st)) (Cell v))
|
|
| _ -> emit_quad_bottom q'
|
|
in
|
|
|
|
let default_mov =
|
|
match q' with
|
|
Binary b ->
|
|
begin
|
|
match b.binary_op with
|
|
IDIV | IMUL | IMOD -> IMOV
|
|
| _ -> UMOV
|
|
end
|
|
| Unary u ->
|
|
begin
|
|
match u.unary_op with
|
|
IMOV -> IMOV
|
|
| _ -> UMOV
|
|
end
|
|
| _ -> UMOV
|
|
in
|
|
|
|
let emit_mov (dst:cell) (src:operand) : unit =
|
|
emit_quad (unary default_mov dst src)
|
|
in
|
|
|
|
let mov_if_operands_differ
|
|
(old_op:operand) (new_op:operand)
|
|
: unit =
|
|
if (new_op <> old_op)
|
|
then
|
|
match new_op with
|
|
(Cell new_cell) ->
|
|
emit_mov new_cell old_op
|
|
| _ -> ()
|
|
in
|
|
|
|
let mov_if_two_operands_differ
|
|
(old_lhs_op:operand) (new_lhs_op:operand)
|
|
(old_rhs_op:operand) (new_rhs_op:operand)
|
|
: unit =
|
|
(*
|
|
* This is sufficiently obscure that it deserves an explanation.
|
|
*
|
|
* The main idea here is to do two "mov_if_operands_differ" calls,
|
|
* such as one might have when setting up a binary quad.
|
|
*
|
|
* The problem comes when you happen to hit a case like X86 div,
|
|
* which preallocates *both* operands. Preallocating both means we
|
|
* have to potentially issue two movs into the preallocated regs,
|
|
* and the second of those movs might be a problem. Specifically:
|
|
* the second mov-to-prealloc might make be moving from a
|
|
* register-indirect mem cell based on a vreg, and that vreg may
|
|
* wind up being assigned to an hreg that we just loaded with the
|
|
* first mov. In other words, the second mov may retask the
|
|
* preallocated hreg we set up in the first mov.
|
|
*
|
|
* You laugh, but of course this actually happens.
|
|
*
|
|
* So here we do a conservative thing and check to see if either
|
|
* operand is memory-indirect at all. If either is, then for either
|
|
* of the 'old' operands we're *about* to mov into a prealloc reg,
|
|
* we first bounce them off a spill slot. Spill slots, thankfully,
|
|
* we can always count on being able to address irrespective of the
|
|
* opinions of the RA, as they are all just fp-relative.
|
|
*
|
|
* A slightly more aggressive version of this would only bounce
|
|
* cases that are not fp-relative already, though doing so would
|
|
* require threading the notion of what fp *is* through to
|
|
* here. Possibly tighten this up in the future (or just
|
|
* ... destroy this backend ASAP).
|
|
*
|
|
*)
|
|
let has_reg_indirect op =
|
|
match op with
|
|
Cell (Mem _) -> true
|
|
| _ -> false
|
|
in
|
|
let either_old_op_has_reg_indirect =
|
|
(has_reg_indirect old_lhs_op) || (has_reg_indirect old_rhs_op)
|
|
in
|
|
let old_lhs_op =
|
|
if either_old_op_has_reg_indirect && (new_lhs_op <> old_lhs_op)
|
|
then
|
|
let tmp =
|
|
Mem (next_spill_slot e
|
|
(ScalarTy (operand_scalar_ty old_lhs_op)))
|
|
in
|
|
emit_mov tmp old_lhs_op;
|
|
Cell tmp
|
|
else
|
|
old_lhs_op
|
|
in
|
|
let old_rhs_op =
|
|
if either_old_op_has_reg_indirect && (new_rhs_op <> old_rhs_op)
|
|
then
|
|
let tmp =
|
|
Mem (next_spill_slot e
|
|
(ScalarTy (operand_scalar_ty old_rhs_op)))
|
|
in
|
|
emit_mov tmp old_rhs_op;
|
|
Cell tmp
|
|
else
|
|
old_rhs_op
|
|
in
|
|
mov_if_operands_differ old_lhs_op new_lhs_op;
|
|
mov_if_operands_differ old_rhs_op new_rhs_op;
|
|
in
|
|
|
|
let mov_if_cells_differ (old_cell:cell) (new_cell:cell) : unit =
|
|
if not (new_cell = old_cell)
|
|
then
|
|
emit_mov old_cell (Cell new_cell)
|
|
in
|
|
|
|
let emit_decayed_quad q' =
|
|
match (q', e.emit_preallocator q') with
|
|
(Binary b, Binary b') ->
|
|
begin
|
|
mov_if_two_operands_differ
|
|
b.binary_lhs b'.binary_lhs
|
|
b.binary_rhs b'.binary_rhs;
|
|
if e.emit_is_2addr &&
|
|
(not (b'.binary_lhs = (Cell b'.binary_dst)))
|
|
then
|
|
begin
|
|
emit_mov b'.binary_dst b'.binary_lhs;
|
|
emit_quad (Binary { b' with
|
|
binary_lhs = (Cell b'.binary_dst) })
|
|
end
|
|
else
|
|
emit_quad (Binary b');
|
|
mov_if_cells_differ b.binary_dst b'.binary_dst
|
|
end
|
|
|
|
| (Unary u, Unary u') ->
|
|
mov_if_operands_differ u.unary_src u'.unary_src;
|
|
(* Assume '2addr' means '1addr' for unary ops. *)
|
|
if e.emit_is_2addr &&
|
|
(u'.unary_op = NEG || u'.unary_op = NOT) &&
|
|
(not (u'.unary_src = (Cell u'.unary_dst)))
|
|
then
|
|
begin
|
|
emit_mov u'.unary_dst u'.unary_src;
|
|
emit_quad (Unary { u' with unary_src = (Cell u'.unary_dst) })
|
|
end
|
|
else
|
|
emit_quad (Unary u');
|
|
mov_if_cells_differ u.unary_dst u'.unary_dst
|
|
|
|
| (Cmp c, Cmp c') ->
|
|
mov_if_two_operands_differ
|
|
c.cmp_lhs c'.cmp_lhs
|
|
c.cmp_rhs c'.cmp_rhs;
|
|
emit_quad (Cmp c');
|
|
|
|
| (Push op, Push op') ->
|
|
mov_if_operands_differ op op';
|
|
emit_quad (Push op');
|
|
|
|
| (Pop c, Pop c') ->
|
|
emit_quad (Pop c');
|
|
mov_if_cells_differ c c'
|
|
|
|
| (Call c, Call c') ->
|
|
emit_quad (Call c');
|
|
mov_if_cells_differ c.call_dst c'.call_dst
|
|
|
|
| (Lea lea, Lea lea') ->
|
|
emit_quad (Lea lea');
|
|
mov_if_cells_differ lea.lea_dst lea'.lea_dst
|
|
|
|
| (x, y) ->
|
|
assert (x = y);
|
|
emit_quad x
|
|
in
|
|
|
|
(* pre-decay mem-mem movs. *)
|
|
match q' with
|
|
Unary { unary_dst = Mem (dst_mem, ScalarTy src_st);
|
|
unary_src = Cell (Mem (src_mem, ScalarTy dst_st));
|
|
unary_op = op }
|
|
when is_mov op ->
|
|
let v = next_vreg_cell e dst_st in
|
|
emit_decayed_quad
|
|
(unary op v (Cell (Mem (src_mem, ScalarTy src_st))));
|
|
emit_decayed_quad
|
|
(unary op (Mem (dst_mem, ScalarTy dst_st)) (Cell v))
|
|
| _ -> emit_decayed_quad q'
|
|
;;
|
|
|
|
let emit (e:emitter) (q':quad') : unit =
|
|
emit_full e None [] q'
|
|
;;
|
|
|
|
let patch_jump (e:emitter) (jmp:int) (targ:int) : unit =
|
|
let q = e.emit_quads.(jmp) in
|
|
match q.quad_body with
|
|
Jmp j ->
|
|
assert (j.jmp_targ = CodeNone);
|
|
e.emit_quads.(jmp) <-
|
|
{ q with quad_body =
|
|
Jmp { j with jmp_targ = CodeLabel targ } }
|
|
| _ -> ()
|
|
;;
|
|
|
|
(* More query functions. *)
|
|
|
|
let get_element_ptr
|
|
(word_bits:bits)
|
|
(fmt:hreg_formatter)
|
|
(mem_cell:cell)
|
|
(i:int)
|
|
: cell =
|
|
match mem_cell with
|
|
Mem (mem, StructTy elts) when i >= 0 && i < (Array.length elts) ->
|
|
assert ((Array.length elts) != 0);
|
|
begin
|
|
let elt_rty = elts.(i) in
|
|
let elt_off = get_element_offset word_bits elts i in
|
|
match elt_off with
|
|
SIZE_fixed fixed_off ->
|
|
Mem (mem_off_imm mem fixed_off, elt_rty)
|
|
| _ -> bug ()
|
|
"get_element_ptr %d on dynamic-size cell: offset %s"
|
|
i (string_of_size elt_off)
|
|
end
|
|
|
|
| _ -> bug () "get_element_ptr %d on cell %s" i
|
|
(string_of_cell fmt mem_cell)
|
|
;;
|
|
|
|
(*
|
|
* Local Variables:
|
|
* fill-column: 78;
|
|
* indent-tabs-mode: nil
|
|
* buffer-file-coding-system: utf-8-unix
|
|
* compile-command: "make -k -C ../.. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
|
|
* End:
|
|
*)
|