pghs975uc
/
infer_clone
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

[sledge] Improve using extended open

Browse Source 
Summary:
OCaml 4.08 supports `open` of arbitrary module expressions. This
enables some code simplifications.

Reviewed By: ngorogiannis

Differential Revision: D18736381

fbshipit-source-id: c729dcfbd
master
Josh Berdine 5 years ago committed by Facebook Github Bot
parent 7ed8a6a260
commit cfbbacf9f1
1 changed files with 94 additions and 90 deletions
Show Stats Download Patch File Download Diff File

184
sledge/src/llair/frontend.ml
Unescape View File

@ -37,92 +37,93 @@ let scope_tbl :
Hashtbl.t = Hashtbl.t =
Hashtbl.Poly.create ~size:32_768 () Hashtbl.Poly.create ~size:32_768 ()
let ( (scan_names_and_locs : Llvm.llmodule -> unit) open struct
, (find_name : Llvm.llvalue -> string) open struct
, (find_loc : Llvm.llvalue -> Loc.t) ) = let loc_of_global g =
let loc_of_global g = Loc.mk
Loc.mk ?dir:(Llvm.get_debug_loc_directory g)
?dir:(Llvm.get_debug_loc_directory g) ?file:(Llvm.get_debug_loc_filename g)
?file:(Llvm.get_debug_loc_filename g) ~line:(Llvm.get_debug_loc_line g)
~line:(Llvm.get_debug_loc_line g) ?col:None
?col:None
in let loc_of_function f =
let loc_of_function f = Loc.mk
Loc.mk ?dir:(Llvm.get_debug_loc_directory f)
?dir:(Llvm.get_debug_loc_directory f) ?file:(Llvm.get_debug_loc_filename f)
?file:(Llvm.get_debug_loc_filename f) ~line:(Llvm.get_debug_loc_line f)
~line:(Llvm.get_debug_loc_line f) ?col:None
?col:None
in let loc_of_instr i =
let loc_of_instr i = Loc.mk
Loc.mk ?dir:(Llvm.get_debug_loc_directory i)
?dir:(Llvm.get_debug_loc_directory i) ?file:(Llvm.get_debug_loc_filename i)
?file:(Llvm.get_debug_loc_filename i) ~line:(Llvm.get_debug_loc_line i)
~line:(Llvm.get_debug_loc_line i) ~col:(Llvm.get_debug_loc_column i)
~col:(Llvm.get_debug_loc_column i)
in let add_sym llv loc =
let add_sym llv loc = let maybe_scope =
let maybe_scope = match Llvm.classify_value llv with
match Llvm.classify_value llv with | Argument -> Some (`Fun (Llvm.param_parent llv))
| Argument -> Some (`Fun (Llvm.param_parent llv)) | BasicBlock ->
| BasicBlock -> Some (`Fun (Llvm.block_parent (Llvm.block_of_value llv)))
Some (`Fun (Llvm.block_parent (Llvm.block_of_value llv))) | Instruction _ ->
| Instruction _ -> Some (`Fun (Llvm.block_parent (Llvm.instr_parent llv)))
Some (`Fun (Llvm.block_parent (Llvm.instr_parent llv))) | GlobalVariable | Function -> Some (`Mod (Llvm.global_parent llv))
| GlobalVariable | Function -> Some (`Mod (Llvm.global_parent llv)) | UndefValue -> None
| UndefValue -> None | ConstantExpr -> None
| ConstantExpr -> None | ConstantPointerNull -> None
| ConstantPointerNull -> None | _ ->
| _ -> warn "Unexpected type of llv, might crash: %a" pp_llvalue llv () ;
warn "Unexpected type of llv, might crash: %a" pp_llvalue llv () ; Some (`Mod (Llvm.global_parent llv))
Some (`Mod (Llvm.global_parent llv)) in
in match maybe_scope with
match maybe_scope with | None -> ()
| None -> () | Some scope ->
| Some scope -> let next, void_tbl =
let next, void_tbl = Hashtbl.find_or_add scope_tbl scope ~default:(fun () ->
Hashtbl.find_or_add scope_tbl scope ~default:(fun () -> (ref 0, Hashtbl.Poly.create ()) )
(ref 0, Hashtbl.Poly.create ()) ) in
in let name =
let name = match Llvm.classify_type (Llvm.type_of llv) with
match Llvm.classify_type (Llvm.type_of llv) with | Void -> (
| Void -> ( let fname =
let fname = match Llvm.classify_value llv with
match Llvm.classify_value llv with | Instruction (Call | Invoke) -> (
| Instruction (Call | Invoke) -> ( match
match Llvm.value_name
Llvm.value_name (Llvm.operand llv (Llvm.num_operands llv - 1))
(Llvm.operand llv (Llvm.num_operands llv - 1)) with
with | "" -> Int.to_string (!next - 1)
| "" -> Int.to_string (!next - 1) | s -> s )
| s -> s ) | _ -> "void"
| _ -> "void" in
in match Hashtbl.find void_tbl fname with
match Hashtbl.find void_tbl fname with | None ->
| None -> Hashtbl.set void_tbl ~key:fname ~data:1 ;
Hashtbl.set void_tbl ~key:fname ~data:1 ; fname ^ ".void"
fname ^ ".void" | Some count ->
| Some count -> Hashtbl.set void_tbl ~key:fname ~data:(count + 1) ;
Hashtbl.set void_tbl ~key:fname ~data:(count + 1) ; String.concat_array
String.concat_array [|fname; ".void."; Int.to_string count|] )
[|fname; ".void."; Int.to_string count|] ) | _ -> (
| _ -> ( match Llvm.value_name llv with
match Llvm.value_name llv with | "" ->
| "" -> (* anonymous values take the next SSA name *)
(* anonymous values take the next SSA name *) let name = !next in
let name = !next in next := name + 1 ;
next := name + 1 ; Int.to_string name
Int.to_string name | name -> (
| name -> ( match Int.of_string name with
match Int.of_string name with | _ ->
| _ -> (* escape to avoid clash with names of anonymous values *)
(* escape to avoid clash with names of anonymous values *) String.concat_array [|"\""; name; "\""|]
String.concat_array [|"\""; name; "\""|] | exception _ -> name ) )
| exception _ -> name ) ) in
in Hashtbl.set sym_tbl ~key:llv ~data:(name, loc)
Hashtbl.set sym_tbl ~key:llv ~data:(name, loc) end
in
let scan_names_and_locs m = let scan_names_and_locs : Llvm.llmodule -> unit =
fun m ->
let scan_global g = add_sym g (loc_of_global g) in let scan_global g = add_sym g (loc_of_global g) in
let scan_instr i = let scan_instr i =
let loc = loc_of_instr i in let loc = loc_of_instr i in
@ -152,10 +153,13 @@ let ( (scan_names_and_locs : Llvm.llmodule -> unit)
in in
Llvm.iter_globals scan_global m ; Llvm.iter_globals scan_global m ;
Llvm.iter_functions scan_function m Llvm.iter_functions scan_function m
in
let find_name v = fst (Hashtbl.find_exn sym_tbl v) in let find_name : Llvm.llvalue -> string =
let find_loc v = snd (Hashtbl.find_exn sym_tbl v) in fun v -> fst (Hashtbl.find_exn sym_tbl v)
(scan_names_and_locs, find_name, find_loc)
let find_loc : Llvm.llvalue -> Loc.t =
fun v -> snd (Hashtbl.find_exn sym_tbl v)
end
let label_of_block : Llvm.llbasicblock -> string = let label_of_block : Llvm.llbasicblock -> string =
fun blk -> find_name (Llvm.value_of_block blk) fun blk -> find_name (Llvm.value_of_block blk)

Write Preview
Loading…
Cancel
Save