|
|
|
|
@ -14,6 +14,7 @@ let fmt_llvalue ff t = Format.pp_print_string ff (Llvm.string_of_llvalue t)
|
|
|
|
|
let fmt_llblock ff t =
|
|
|
|
|
Format.pp_print_string ff (Llvm.string_of_llvalue (Llvm.value_of_block t))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(* gather debug locations *)
|
|
|
|
|
let (scan_locs : Llvm.llmodule -> unit), (find_loc : Llvm.llvalue -> Loc.t)
|
|
|
|
|
=
|
|
|
|
|
@ -81,6 +82,7 @@ let (scan_locs : Llvm.llmodule -> unit), (find_loc : Llvm.llvalue -> Loc.t)
|
|
|
|
|
in
|
|
|
|
|
(scan_locs, find_loc)
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
let ( (scan_names : Llvm.llmodule -> unit)
|
|
|
|
|
, (find_name : Llvm.llvalue -> string) ) =
|
|
|
|
|
let name_tbl = Hashtbl.Poly.create () in
|
|
|
|
|
@ -156,12 +158,15 @@ let ( (scan_names : Llvm.llmodule -> unit)
|
|
|
|
|
let find_name v = Hashtbl.find_exn name_tbl v in
|
|
|
|
|
(scan_names, find_name)
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
let label_of_block : Llvm.llbasicblock -> string =
|
|
|
|
|
fun blk -> find_name (Llvm.value_of_block blk)
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
let anon_struct_name : (Llvm.lltype, string) Hashtbl.t =
|
|
|
|
|
Hashtbl.Poly.create ()
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
let struct_name : Llvm.lltype -> string =
|
|
|
|
|
fun llt ->
|
|
|
|
|
match Llvm.struct_name llt with
|
|
|
|
|
@ -170,6 +175,7 @@ let struct_name : Llvm.lltype -> string =
|
|
|
|
|
Hashtbl.find_or_add anon_struct_name llt ~default:(fun () ->
|
|
|
|
|
Int.to_string (Hashtbl.length anon_struct_name) )
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
let memo_type : (Llvm.lltype, Typ.t) Hashtbl.t = Hashtbl.Poly.create ()
|
|
|
|
|
|
|
|
|
|
let rec xlate_type : Llvm.lltype -> Typ.t =
|
|
|
|
|
@ -226,12 +232,14 @@ let rec xlate_type : Llvm.lltype -> Typ.t =
|
|
|
|
|
|>
|
|
|
|
|
[%Trace.retn fun pf -> pf "%a" Typ.fmt_defn] )
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
and xlate_type_opt : Llvm.lltype -> Typ.t option =
|
|
|
|
|
fun llt ->
|
|
|
|
|
match Llvm.classify_type llt with
|
|
|
|
|
| Void -> None
|
|
|
|
|
| _ -> Some (xlate_type llt)
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
let rec is_zero : Exp.t -> bool =
|
|
|
|
|
fun exp ->
|
|
|
|
|
match exp with
|
|
|
|
|
@ -241,9 +249,11 @@ let rec is_zero : Exp.t -> bool =
|
|
|
|
|
| App {op; arg} -> is_zero op && is_zero arg
|
|
|
|
|
| _ -> false
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
let suffix_after_space : string -> string =
|
|
|
|
|
fun str -> String.slice str (String.rindex_exn str ' ' + 1) 0
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
let xlate_int : Llvm.llvalue -> Exp.t =
|
|
|
|
|
fun llv ->
|
|
|
|
|
let typ = xlate_type (Llvm.type_of llv) in
|
|
|
|
|
@ -254,12 +264,14 @@ let xlate_int : Llvm.llvalue -> Exp.t =
|
|
|
|
|
in
|
|
|
|
|
Exp.mkInteger data typ
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
let xlate_float : Llvm.llvalue -> Exp.t =
|
|
|
|
|
fun llv ->
|
|
|
|
|
let typ = xlate_type (Llvm.type_of llv) in
|
|
|
|
|
let data = suffix_after_space (Llvm.string_of_llvalue llv) in
|
|
|
|
|
Exp.mkFloat data typ
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
let xlate_name_opt : Llvm.llvalue -> Var.t option =
|
|
|
|
|
fun instr ->
|
|
|
|
|
Option.map
|
|
|
|
|
@ -269,9 +281,11 @@ let xlate_name_opt : Llvm.llvalue -> Var.t option =
|
|
|
|
|
let loc = find_loc instr in
|
|
|
|
|
Var.mk name typ ~loc )
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
let xlate_name : Llvm.llvalue -> Var.t =
|
|
|
|
|
fun instr -> Option.value_exn (xlate_name_opt instr)
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
let xlate_intrinsic_exp : string -> (Exp.t -> Exp.t) option =
|
|
|
|
|
fun name ->
|
|
|
|
|
let i32 = Typ.mkInteger ~bits:32 in
|
|
|
|
|
@ -279,6 +293,7 @@ let xlate_intrinsic_exp : string -> (Exp.t -> Exp.t) option =
|
|
|
|
|
| "llvm.eh.typeid.for" -> Some (fun arg -> Exp.mkCast arg i32)
|
|
|
|
|
| _ -> None
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
let memo_value : (Llvm.llvalue, Exp.t) Hashtbl.t = Hashtbl.Poly.create ()
|
|
|
|
|
|
|
|
|
|
module Llvalue = struct
|
|
|
|
|
@ -368,6 +383,7 @@ let rec xlate_value : Llvm.llvalue -> Exp.t =
|
|
|
|
|
typ' fmt_llvalue llv () ;
|
|
|
|
|
pf "%a" Exp.fmt exp] )
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
and xlate_opcode : Llvm.llvalue -> Llvm.Opcode.t -> Exp.t =
|
|
|
|
|
fun llv opcode ->
|
|
|
|
|
[%Trace.call fun pf -> pf "%a" fmt_llvalue llv]
|
|
|
|
|
@ -529,6 +545,7 @@ and xlate_opcode : Llvm.llvalue -> Llvm.Opcode.t -> Exp.t =
|
|
|
|
|
fmt_llvalue llv () ;
|
|
|
|
|
pf "%a" Exp.fmt exp]
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
and xlate_global : Llvm.llvalue -> Global.t =
|
|
|
|
|
fun llg ->
|
|
|
|
|
let init =
|
|
|
|
|
@ -540,6 +557,7 @@ and xlate_global : Llvm.llvalue -> Global.t =
|
|
|
|
|
let g = xlate_name llg in
|
|
|
|
|
Global.mk (Var.name g) (Var.typ g) ~loc:(Var.loc g) ?init
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
let xlate_global : Llvm.llvalue -> Global.t =
|
|
|
|
|
fun llg ->
|
|
|
|
|
[%Trace.call fun pf -> pf "%a" fmt_llvalue llg]
|
|
|
|
|
@ -548,6 +566,7 @@ let xlate_global : Llvm.llvalue -> Global.t =
|
|
|
|
|
|>
|
|
|
|
|
[%Trace.retn fun pf -> pf "%a" Global.fmt]
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
type pop_thunk = Loc.t -> Llair.inst list
|
|
|
|
|
|
|
|
|
|
let pop_stack_frame_of_function :
|
|
|
|
|
@ -580,6 +599,7 @@ let pop_stack_frame_of_function :
|
|
|
|
|
in
|
|
|
|
|
pop
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(** construct the types involved in landingpads: i32, std::type_info*, and
|
|
|
|
|
__cxa_exception *)
|
|
|
|
|
let landingpad_typs : Llvm.llvalue -> Typ.t * Typ.t * Typ.t =
|
|
|
|
|
@ -607,12 +627,14 @@ let landingpad_typs : Llvm.llvalue -> Typ.t * Typ.t * Typ.t =
|
|
|
|
|
let cxa_exception = Llvm.struct_type llcontext [|tip; dtor|] in
|
|
|
|
|
(i32, xlate_type tip, xlate_type cxa_exception)
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(** construct the argument of a landingpad block, mainly fix the encoding
|
|
|
|
|
scheme for landingpad instruction name to block arg name *)
|
|
|
|
|
let landingpad_arg : Llvm.llvalue -> Var.t =
|
|
|
|
|
fun instr ->
|
|
|
|
|
Var.mk (find_name instr ^ ".exc") Typ.i8p ~loc:(find_loc instr)
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(** [rev_map_phis ~f blk] returns [(retn_arg, rev_args, pos)] by rev_mapping
|
|
|
|
|
over the prefix of [PHI] instructions at the beginning of [blk].
|
|
|
|
|
[retn_arg], if any, is [f] applied to the [PHI] instruction which takes
|
|
|
|
|
@ -669,6 +691,7 @@ let rev_map_phis :
|
|
|
|
|
in
|
|
|
|
|
block_args_ false None [] (Llvm.instr_begin blk)
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(** [trampoline_args jump_instr dest_block] is the actual arguments to which
|
|
|
|
|
the translation of [dest_block] should be partially-applied, to yield a
|
|
|
|
|
trampoline accepting the return parameter of the block and then jumping
|
|
|
|
|
@ -681,6 +704,7 @@ let trampoline_args : Llvm.llvalue -> Llvm.llbasicblock -> Exp.t vector =
|
|
|
|
|
if Poly.equal pred src then Some (xlate_value arg) else None ) )
|
|
|
|
|
|> snd3 |> Vector.of_list_rev
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(** [unique_pred blk] is the unique predecessor of [blk], or [None] if there
|
|
|
|
|
are 0 or >1 predecessors. *)
|
|
|
|
|
let unique_pred : Llvm.llbasicblock -> Llvm.llvalue option =
|
|
|
|
|
@ -692,11 +716,13 @@ let unique_pred : Llvm.llbasicblock -> Llvm.llvalue option =
|
|
|
|
|
| Some _ -> None )
|
|
|
|
|
| None -> None
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(** [return_formal_is_used instr] holds if the return value of [instr] is
|
|
|
|
|
used anywhere. *)
|
|
|
|
|
let return_formal_is_used : Llvm.llvalue -> bool =
|
|
|
|
|
fun instr -> Option.is_some (Llvm.use_begin instr)
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(** [need_return_trampoline instr blk] holds when the return formal of
|
|
|
|
|
[instr] is used, but the returned to block [blk] does not take it as an
|
|
|
|
|
argument (e.g. if it has multiple predecessors and no PHI node). *)
|
|
|
|
|
@ -706,6 +732,7 @@ let need_return_trampoline : Llvm.llvalue -> Llvm.llbasicblock -> bool =
|
|
|
|
|
&& Option.is_none (unique_pred blk)
|
|
|
|
|
&& return_formal_is_used instr
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(** [unique_used_invoke_pred blk] is the unique predecessor of [blk], if it
|
|
|
|
|
is an [Invoke] instruction, whose return value is used. *)
|
|
|
|
|
let unique_used_invoke_pred : Llvm.llbasicblock -> 'a option =
|
|
|
|
|
@ -716,6 +743,7 @@ let unique_used_invoke_pred : Llvm.llbasicblock -> 'a option =
|
|
|
|
|
Some instr
|
|
|
|
|
| _ -> None
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(** formal parameters accepted by a block *)
|
|
|
|
|
let block_formals : Llvm.llbasicblock -> Var.t list * _ Llvm.llpos =
|
|
|
|
|
fun blk ->
|
|
|
|
|
@ -734,6 +762,7 @@ let block_formals : Llvm.llbasicblock -> Var.t list * _ Llvm.llpos =
|
|
|
|
|
(List.rev_append rev_args (Option.to_list instr_arg), pos)
|
|
|
|
|
| At_end blk -> fail "block_formals: %a" fmt_llblock blk ()
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(** actual arguments passed by a jump to a block *)
|
|
|
|
|
let jump_args : Llvm.llvalue -> Llvm.llbasicblock -> Exp.t vector =
|
|
|
|
|
fun jmp dst ->
|
|
|
|
|
@ -752,6 +781,7 @@ let jump_args : Llvm.llvalue -> Llvm.llbasicblock -> Exp.t vector =
|
|
|
|
|
in
|
|
|
|
|
Vector.of_list (List.rev_append rev_args (Option.to_list retn_arg))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(** An LLVM instruction is translated to a sequence of LLAIR instructions
|
|
|
|
|
and a terminator, plus some additional blocks to which it may refer
|
|
|
|
|
(that is, essentially a function body). These are needed since LLVM and
|
|
|
|
|
@ -774,6 +804,7 @@ let fmt_code ff (insts, term, blocks) =
|
|
|
|
|
(list_fmt "@ " Llair.Block.fmt)
|
|
|
|
|
blocks
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
let rec xlate_func_name llv =
|
|
|
|
|
match Llvm.classify_value llv with
|
|
|
|
|
| Function ->
|
|
|
|
|
@ -788,6 +819,7 @@ let rec xlate_func_name llv =
|
|
|
|
|
| InlineAsm -> todo "inline asm: %a" fmt_llvalue llv ()
|
|
|
|
|
| _ -> fail "unknown function: %a" fmt_llvalue llv ()
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
let xlate_instr :
|
|
|
|
|
pop_thunk
|
|
|
|
|
-> Llvm.llvalue
|
|
|
|
|
@ -1173,6 +1205,7 @@ let xlate_instr :
|
|
|
|
|
fail "xlate_instr: %a" fmt_llvalue instr ()
|
|
|
|
|
| PHI | Invalid | Invalid2 | UserOp1 | UserOp2 -> assert false
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
let rec xlate_instrs : pop_thunk -> _ Llvm.llpos -> code =
|
|
|
|
|
fun pop -> function
|
|
|
|
|
| Before instrI ->
|
|
|
|
|
@ -1183,6 +1216,7 @@ let rec xlate_instrs : pop_thunk -> _ Llvm.llpos -> code =
|
|
|
|
|
(instsI, termI, blocksI @ blocksJN) )
|
|
|
|
|
| At_end blk -> fail "xlate_instrs: %a" fmt_llblock blk ()
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
let xlate_block : pop_thunk -> Llvm.llbasicblock -> Llair.block list =
|
|
|
|
|
fun pop blk ->
|
|
|
|
|
[%Trace.call fun pf -> pf "%a" fmt_llblock blk]
|
|
|
|
|
@ -1196,6 +1230,7 @@ let xlate_block : pop_thunk -> Llvm.llbasicblock -> Llair.block list =
|
|
|
|
|
|>
|
|
|
|
|
[%Trace.retn fun pf blocks -> pf "%s" (List.hd_exn blocks).Llair.lbl]
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
let xlate_function : Llvm.llvalue -> Llair.func =
|
|
|
|
|
fun llf ->
|
|
|
|
|
[%Trace.call fun pf -> pf "%a" fmt_llvalue llf]
|
|
|
|
|
@ -1234,6 +1269,7 @@ let xlate_function : Llvm.llvalue -> Llair.func =
|
|
|
|
|
|>
|
|
|
|
|
[%Trace.retn fun pf -> pf "@\n%a" Llair.Func.fmt]
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
let transform : Llvm.llmodule -> unit =
|
|
|
|
|
fun llmodule ->
|
|
|
|
|
let pm = Llvm.PassManager.create () in
|
|
|
|
|
@ -1245,6 +1281,7 @@ let transform : Llvm.llmodule -> unit =
|
|
|
|
|
Llvm.PassManager.run_module llmodule pm |> (ignore : bool -> _) ;
|
|
|
|
|
Llvm.PassManager.dispose pm
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
exception Invalid_llvm of string
|
|
|
|
|
|
|
|
|
|
let invalid_llvm : string -> 'a =
|
|
|
|
|
@ -1256,6 +1293,7 @@ let invalid_llvm : string -> 'a =
|
|
|
|
|
Format.printf "@\n%s@\n" msg ;
|
|
|
|
|
raise (Invalid_llvm first_line)
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
let translate : string -> Llair.t =
|
|
|
|
|
fun file ->
|
|
|
|
|
[%Trace.call fun pf -> pf "%s" file]
|
|
|
|
|
|
Josh Berdine
6 years ago
committed by
Facebook Github Bot