From cfbbacf9f177b0bb1fb91ef349ce8777c8d67ca4 Mon Sep 17 00:00:00 2001 From: Josh Berdine Date: Thu, 28 Nov 2019 12:41:33 -0800 Subject: [PATCH] [sledge] Improve using extended open 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 --- sledge/src/llair/frontend.ml | 184 ++++++++++++++++++----------------- 1 file changed, 94 insertions(+), 90 deletions(-) diff --git a/sledge/src/llair/frontend.ml b/sledge/src/llair/frontend.ml index 13d0319fd..d3bd8b162 100644 --- a/sledge/src/llair/frontend.ml +++ b/sledge/src/llair/frontend.ml @@ -37,92 +37,93 @@ let scope_tbl : Hashtbl.t = Hashtbl.Poly.create ~size:32_768 () -let ( (scan_names_and_locs : Llvm.llmodule -> unit) - , (find_name : Llvm.llvalue -> string) - , (find_loc : Llvm.llvalue -> Loc.t) ) = - let loc_of_global g = - Loc.mk - ?dir:(Llvm.get_debug_loc_directory g) - ?file:(Llvm.get_debug_loc_filename g) - ~line:(Llvm.get_debug_loc_line g) - ?col:None - in - let loc_of_function f = - Loc.mk - ?dir:(Llvm.get_debug_loc_directory f) - ?file:(Llvm.get_debug_loc_filename f) - ~line:(Llvm.get_debug_loc_line f) - ?col:None - in - let loc_of_instr i = - Loc.mk - ?dir:(Llvm.get_debug_loc_directory i) - ?file:(Llvm.get_debug_loc_filename i) - ~line:(Llvm.get_debug_loc_line i) - ~col:(Llvm.get_debug_loc_column i) - in - let add_sym llv loc = - let maybe_scope = - match Llvm.classify_value llv with - | Argument -> Some (`Fun (Llvm.param_parent llv)) - | BasicBlock -> - Some (`Fun (Llvm.block_parent (Llvm.block_of_value llv))) - | Instruction _ -> - Some (`Fun (Llvm.block_parent (Llvm.instr_parent llv))) - | GlobalVariable | Function -> Some (`Mod (Llvm.global_parent llv)) - | UndefValue -> None - | ConstantExpr -> None - | ConstantPointerNull -> None - | _ -> - warn "Unexpected type of llv, might crash: %a" pp_llvalue llv () ; - Some (`Mod (Llvm.global_parent llv)) - in - match maybe_scope with - | None -> () - | Some scope -> - let next, void_tbl = - Hashtbl.find_or_add scope_tbl scope ~default:(fun () -> - (ref 0, Hashtbl.Poly.create ()) ) - in - let name = - match Llvm.classify_type (Llvm.type_of llv) with - | Void -> ( - let fname = - match Llvm.classify_value llv with - | Instruction (Call | Invoke) -> ( - match - Llvm.value_name - (Llvm.operand llv (Llvm.num_operands llv - 1)) - with - | "" -> Int.to_string (!next - 1) - | s -> s ) - | _ -> "void" - in - match Hashtbl.find void_tbl fname with - | None -> - Hashtbl.set void_tbl ~key:fname ~data:1 ; - fname ^ ".void" - | Some count -> - Hashtbl.set void_tbl ~key:fname ~data:(count + 1) ; - String.concat_array - [|fname; ".void."; Int.to_string count|] ) - | _ -> ( - match Llvm.value_name llv with - | "" -> - (* anonymous values take the next SSA name *) - let name = !next in - next := name + 1 ; - Int.to_string name - | name -> ( - match Int.of_string name with - | _ -> - (* escape to avoid clash with names of anonymous values *) - String.concat_array [|"\""; name; "\""|] - | exception _ -> name ) ) - in - Hashtbl.set sym_tbl ~key:llv ~data:(name, loc) - in - let scan_names_and_locs m = +open struct + open struct + let loc_of_global g = + Loc.mk + ?dir:(Llvm.get_debug_loc_directory g) + ?file:(Llvm.get_debug_loc_filename g) + ~line:(Llvm.get_debug_loc_line g) + ?col:None + + let loc_of_function f = + Loc.mk + ?dir:(Llvm.get_debug_loc_directory f) + ?file:(Llvm.get_debug_loc_filename f) + ~line:(Llvm.get_debug_loc_line f) + ?col:None + + let loc_of_instr i = + Loc.mk + ?dir:(Llvm.get_debug_loc_directory i) + ?file:(Llvm.get_debug_loc_filename i) + ~line:(Llvm.get_debug_loc_line i) + ~col:(Llvm.get_debug_loc_column i) + + let add_sym llv loc = + let maybe_scope = + match Llvm.classify_value llv with + | Argument -> Some (`Fun (Llvm.param_parent llv)) + | BasicBlock -> + Some (`Fun (Llvm.block_parent (Llvm.block_of_value llv))) + | Instruction _ -> + Some (`Fun (Llvm.block_parent (Llvm.instr_parent llv))) + | GlobalVariable | Function -> Some (`Mod (Llvm.global_parent llv)) + | UndefValue -> None + | ConstantExpr -> None + | ConstantPointerNull -> None + | _ -> + warn "Unexpected type of llv, might crash: %a" pp_llvalue llv () ; + Some (`Mod (Llvm.global_parent llv)) + in + match maybe_scope with + | None -> () + | Some scope -> + let next, void_tbl = + Hashtbl.find_or_add scope_tbl scope ~default:(fun () -> + (ref 0, Hashtbl.Poly.create ()) ) + in + let name = + match Llvm.classify_type (Llvm.type_of llv) with + | Void -> ( + let fname = + match Llvm.classify_value llv with + | Instruction (Call | Invoke) -> ( + match + Llvm.value_name + (Llvm.operand llv (Llvm.num_operands llv - 1)) + with + | "" -> Int.to_string (!next - 1) + | s -> s ) + | _ -> "void" + in + match Hashtbl.find void_tbl fname with + | None -> + Hashtbl.set void_tbl ~key:fname ~data:1 ; + fname ^ ".void" + | Some count -> + Hashtbl.set void_tbl ~key:fname ~data:(count + 1) ; + String.concat_array + [|fname; ".void."; Int.to_string count|] ) + | _ -> ( + match Llvm.value_name llv with + | "" -> + (* anonymous values take the next SSA name *) + let name = !next in + next := name + 1 ; + Int.to_string name + | name -> ( + match Int.of_string name with + | _ -> + (* escape to avoid clash with names of anonymous values *) + String.concat_array [|"\""; name; "\""|] + | exception _ -> name ) ) + in + Hashtbl.set sym_tbl ~key:llv ~data:(name, loc) + end + + let scan_names_and_locs : Llvm.llmodule -> unit = + fun m -> let scan_global g = add_sym g (loc_of_global g) in let scan_instr i = let loc = loc_of_instr i in @@ -152,10 +153,13 @@ let ( (scan_names_and_locs : Llvm.llmodule -> unit) in Llvm.iter_globals scan_global m ; Llvm.iter_functions scan_function m - in - let find_name v = fst (Hashtbl.find_exn sym_tbl v) in - let find_loc v = snd (Hashtbl.find_exn sym_tbl v) in - (scan_names_and_locs, find_name, find_loc) + + let find_name : Llvm.llvalue -> string = + fun v -> fst (Hashtbl.find_exn sym_tbl v) + + let find_loc : Llvm.llvalue -> Loc.t = + fun v -> snd (Hashtbl.find_exn sym_tbl v) +end let label_of_block : Llvm.llbasicblock -> string = fun blk -> find_name (Llvm.value_of_block blk)