[sledge] Do not regenerate symbol name when updating loc in Frontend

Summary:
Sometimes symbols are added to the symbol table multiple times during
translation from LLVM to LLAIR. For example, this happens when a
`llvm.dbg.declare` instruction is encountered that attaches a debug
location to a symbol. Currently when this happens, the symbol name is
regenerated unnecessarily. This is not economical, and since counters
are used in some cases to avoid clashes, this can cause visible
changes to names.

This diff fixes this, and also makes the location update more robust
by not relying on the location added last being the best.

Reviewed By: jvillard

Differential Revision: D26250542

fbshipit-source-id: 5d52ce193

sledge/cli/frontend.ml

@@ -123,51 +123,57 @@ open struct
       in
       match maybe_scope with
       | None -> ()
-      | Some scope ->
+      | Some scope -> (
-          let next, void_tbl =
+        match SymTbl.find sym_tbl llv with
-            ScopeTbl.find_or_add scope_tbl scope ~default:(fun () ->
+        | Some (name, loc0) ->
-                (ref 0, String.Tbl.create ()) )
+            if Loc.equal loc0 Loc.none then
-          in
+              SymTbl.set sym_tbl ~key:llv ~data:(name, loc)
-          let name =
+        | None ->
-            if
+            let next, void_tbl =
-              Poly.(
+              ScopeTbl.find_or_add scope_tbl scope ~default:(fun () ->
-                Llvm.classify_value llv = Instruction Call
+                  (ref 0, String.Tbl.create ()) )
-                && Llvm.classify_type (Llvm.type_of llv) = Void)
+            in
-            then (
+            let name =
-              (* LLVM does not give unique names to the result of
+              if
-                 void-returning function calls. We need unique names for
+                Poly.(
-                 these as they determine the labels of newly-created return
+                  Llvm.classify_value llv = Instruction Call
-                 blocks. *)
+                  && Llvm.classify_type (Llvm.type_of llv) = Void)
-              let fname =
+              then (
-                match
+                (* LLVM does not give unique names to the result of
-                  Llvm.(value_name (operand llv (num_operands llv - 1)))
+                   void-returning function calls. We need unique names for
-                with
+                   these as they determine the labels of newly-created
-                | "" -> Int.to_string (!next - 1)
+                   return blocks. *)
-                | s -> s
+                let fname =
-              in
+                  match
-              match String.Tbl.find void_tbl fname with
+                    Llvm.(value_name (operand llv (num_operands llv - 1)))
-              | None ->
+                  with
-                  String.Tbl.set void_tbl ~key:fname ~data:1 ;
+                  | "" -> Int.to_string (!next - 1)
-                  fname ^ ".void"
+                  | s -> s
-              | Some count ->
+                in
-                  String.Tbl.set void_tbl ~key:fname ~data:(count + 1) ;
+                match String.Tbl.find void_tbl fname with
-                  String.concat ~sep:""
+                | None ->
-                    [fname; ".void."; Int.to_string count] )
+                    String.Tbl.set void_tbl ~key:fname ~data:1 ;
-            else
+                    fname ^ ".void"
-              match Llvm.value_name llv with
+                | Some count ->
-              | "" ->
+                    String.Tbl.set void_tbl ~key:fname ~data:(count + 1) ;
-                  (* anonymous values take the next SSA name *)
+                    String.concat ~sep:""
-                  let name = !next in
+                      [fname; ".void."; Int.to_string count] )
-                  next := name + 1 ;
+              else
-                  Int.to_string name
+                match Llvm.value_name llv with
-              | name -> (
+                | "" ->
-                match Int.of_string name with
+                    (* anonymous values take the next SSA name *)
-                | Some _ ->
+                    let name = !next in
-                    (* escape to avoid clash with names of anonymous values *)
+                    next := name + 1 ;
-                    "\"" ^ name ^ "\""
+                    Int.to_string name
-                | None -> name )
+                | name -> (
-          in
+                  match Int.of_string name with
-          SymTbl.set sym_tbl ~key:llv ~data:(name, loc)
+                  | Some _ ->
+                      (* escape to avoid clash with names of anonymous
+                         values *)
+                      "\"" ^ name ^ "\""
+                  | None -> name )
+            in
+            SymTbl.set sym_tbl ~key:llv ~data:(name, loc) )
   end
 
   let scan_names_and_locs : Llvm.llmodule -> unit =

sledge/nonstdlib/hashTable.ml

@@ -21,12 +21,13 @@ module Make (Key : HashedType) = struct
     update tbl ~k:key ~f:(fun _ -> function
       | None -> Some [data] | Some datas -> Some (data :: datas) )
 
+  let update tbl key ~f = update tbl ~k:key ~f:(fun _ dat -> f dat)
   let find_exn = find
   let find = find_opt
 
   let find_or_add tbl key ~default =
     let found = ref None in
-    update tbl ~k:key ~f:(fun _ -> function
+    update tbl key ~f:(function
       | None ->
           let v = default () in
           found := Some v ;

sledge/nonstdlib/hashTable_intf.ml

@@ -15,6 +15,7 @@ module type S = sig
   val create : ?size:int -> unit -> 'a t
   val set : 'a t -> key:key -> data:'a -> unit
   val add_multi : 'a list t -> key:key -> data:'a -> unit
+  val update : 'a t -> key -> f:('a option -> 'a option) -> unit
   val find_exn : 'a t -> key -> 'a
   val find : 'a t -> key -> 'a option
   val find_or_add : 'a t -> key -> default:(unit -> 'a) -> 'a