Move mk_struct to Tenv

Summary:
Rename Typ.mk_struct to internal_mk_struct, and add Tenv.mk_struct that
ensures types are added to the environment under the right name.

Reviewed By: cristianoc

Differential Revision: D3791865

fbshipit-source-id: fd4b667

infer/src/IR/Tenv.re

@@ -30,6 +30,30 @@ type t = TypenameHash.t Typ.struct_typ;
 let create () => TypenameHash.create 1000;
 
 
+/** Construct a struct type in a type environment */
+let mk_struct
+    tenv
+    default::default=?
+    fields::fields=?
+    statics::statics=?
+    methods::methods=?
+    supers::supers=?
+    annots::annots=?
+    name => {
+  let struct_typ =
+    Typ.internal_mk_struct
+      default::?default
+      fields::?fields
+      statics::?statics
+      methods::?methods
+      supers::?supers
+      annots::?annots
+      name;
+  TypenameHash.replace tenv name struct_typ;
+  struct_typ
+};
+
+
 /** Check if typename is found in tenv */
 let mem tenv name => TypenameHash.mem tenv name;
 

infer/src/IR/Tenv.rei

@@ -58,6 +58,19 @@ let lookup_java_typ_from_string: t => string => option Typ.t;
 let lookup_java_class_from_string: t => string => option Typ.struct_typ;
 
 
+/** Construct a struct_typ, normalizing field types */
+let mk_struct:
+  t =>
+  default::Typ.struct_typ? =>
+  fields::Typ.struct_fields? =>
+  statics::Typ.struct_fields? =>
+  methods::list Procname.t? =>
+  supers::list Typename.t? =>
+  annots::Typ.item_annotation? =>
+  Typename.t =>
+  Typ.struct_typ;
+
+
 /** Return the declaring class type of [pname_java] */
 let proc_extract_declaring_class_typ: t => Procname.java => option Typ.struct_typ;
 

infer/src/IR/Typ.re

@@ -451,7 +451,7 @@ let module Tbl = Hashtbl.Make {
   let hash = Hashtbl.hash;
 };
 
-let mk_struct
+let internal_mk_struct
     default::default=?
     fields::fields=?
     statics::statics=?

infer/src/IR/Typ.rei

@@ -210,7 +210,7 @@ let module Tbl: Hashtbl.S with type key = t;
 
 
 /** Construct a struct_typ, normalizing field types */
-let mk_struct:
+let internal_mk_struct:
   default::struct_typ? =>
   fields::struct_fields? =>
   statics::struct_fields? =>

infer/src/backend/prover.ml

@@ -1479,7 +1479,7 @@ let expand_hpred_pointer tenv calc_index_frame hpred : bool * bool * Sil.hpred =
                  type of contents is known, so construct struct type for single fld:cnt_typ *)
               let struct_typ =
                 Typ.Tstruct
-                  (Typ.mk_struct
+                  (Typ.internal_mk_struct
                      ~fields: [(fld, cnt_typ, Typ.item_annotation_empty)]
                      (TN_csu (Struct, Mangled.from_string "counterfeit"))) in
               Exp.Sizeof (struct_typ, len, st)

infer/src/backend/rearrange.ml

@@ -100,7 +100,7 @@ let rec create_struct_values pname tenv orig_prop footprint_part kind max_stamp
     match Tenv.expand_type tenv t, off with
     | Tstruct _, [] ->
         ([], Sil.Estruct ([], inst), t)
-    | Tstruct ({ fields; statics } as struct_typ ),
+    | Tstruct ({ name; fields; statics } as struct_typ ),
       (Sil.Off_fld (f, _)):: off' ->
         let _, t', _ =
           try
@@ -116,8 +116,7 @@ let rec create_struct_values pname tenv orig_prop footprint_part kind max_stamp
           if Ident.fieldname_equal f f' then (f, res_t', a') else (f', t', a') in
         let fields' =
           IList.sort Typ.fld_typ_ann_compare (IList.map replace_typ_of_f fields) in
-        (atoms', se,
-         Typ.Tstruct (Typ.mk_struct ~default:struct_typ ~fields:fields' struct_typ.name))
+        (atoms', se, Typ.Tstruct (Tenv.mk_struct tenv ~default:struct_typ ~fields:fields' name))
     | Typ.Tstruct _, (Sil.Off_index e):: off' ->
         let atoms', se', res_t' =
           create_struct_values
@@ -206,7 +205,7 @@ let rec _strexp_extend_values
       _strexp_extend_values
         pname tenv orig_prop footprint_part kind max_stamp se typ off_new inst
   | (Sil.Off_fld (f, _)):: off', Sil.Estruct (fsel, inst'),
-    Tstruct ({ fields; statics } as struct_typ) ->
+    Tstruct ({ name; fields; statics } as struct_typ) ->
       let replace_fv new_v fv = if Ident.fieldname_equal (fst fv) f then (f, new_v) else fv in
       let _, typ', _ =
         try
@@ -227,8 +226,7 @@ let rec _strexp_extend_values
             let fields' =
               IList.sort Typ.fld_typ_ann_compare (IList.map replace_fta fields) in
             let struct_typ =
-              Typ.Tstruct
-                (Typ.mk_struct ~default:struct_typ ~fields:fields' struct_typ.name) in
+              Typ.Tstruct (Tenv.mk_struct tenv ~default:struct_typ ~fields:fields' name) in
             (res_atoms', Sil.Estruct (res_fsel', inst'), struct_typ) :: acc in
           IList.fold_left replace [] atoms_se_typ_list'
         with Not_found ->
@@ -240,8 +238,7 @@ let rec _strexp_extend_values
           let fields' =
             IList.sort Typ.fld_typ_ann_compare (IList.map replace_fta fields) in
           let struct_typ =
-            Typ.Tstruct
-              (Typ.mk_struct ~default:struct_typ ~fields:fields' struct_typ.name) in
+            Typ.Tstruct (Tenv.mk_struct tenv ~default:struct_typ ~fields:fields' name) in
           [(atoms', Sil.Estruct (res_fsel', inst'), struct_typ)]
       end
   | (Sil.Off_fld (_, _)):: _, _, _ ->

infer/src/backend/symExec.ml

@@ -141,10 +141,9 @@ let rec apply_offlist
   | (Sil.Off_fld (fld, fld_typ)):: offlist', Sil.Estruct (fsel, inst') ->
       begin
         let typ' = Tenv.expand_type tenv typ in
-        let struct_typ =
+        let { Typ.name; fields; } as struct_typ =
           match typ' with
-          | Typ.Tstruct struct_typ ->
-              struct_typ
+          | Tstruct struct_typ -> struct_typ
           | _ -> assert false in
         let t' = unroll_type tenv typ (Sil.Off_fld (fld, fld_typ)) in
         try
@@ -158,10 +157,8 @@ let rec apply_offlist
           let res_se = Sil.Estruct (IList.map replace_fse fsel, inst') in
           let replace_fta (f, t, a) =
             if Ident.fieldname_equal fld f then (fld, res_t', a) else (f, t, a) in
-          let fields' = IList.map replace_fta struct_typ.fields in
-          let res_t =
-            Typ.Tstruct
-              (Typ.mk_struct ~default:struct_typ ~fields:fields' struct_typ.name) in
+          let fields' = IList.map replace_fta fields in
+          let res_t = Typ.Tstruct (Tenv.mk_struct tenv ~default:struct_typ ~fields:fields' name) in
           (res_e', res_se, res_t, res_pred_insts_op')
         with Not_found ->
           pp_error();

infer/src/clang/cField_decl.ml

@@ -82,10 +82,8 @@ let add_missing_fields tenv class_name ck missing_fields =
   match Tenv.lookup tenv class_tn_name with
   | Some ({ fields } as struct_typ) ->
       let new_fields = General_utils.append_no_duplicates_fields fields missing_fields in
-      let class_type_info =
-        Typ.mk_struct ~default:struct_typ ~fields:new_fields ~statics:[] class_tn_name in
-      Printing.log_out " Updating info for class '%s' in tenv\n" class_name;
-      Tenv.add tenv class_tn_name class_type_info
+      ignore (Tenv.mk_struct tenv ~default:struct_typ ~fields:new_fields ~statics:[] class_tn_name);
+      Printing.log_out " Updating info for class '%s' in tenv\n" class_name
   | _ -> ()
 
 let modelled_fields_in_classes = [("NSData", "_bytes", Typ.Tptr (Typ.Tvoid, Typ.Pk_pointer))]

infer/src/clang/cFrontend_utils.ml

@@ -525,9 +525,8 @@ struct
 
 
   let sort_fields_tenv tenv =
-    let sort_fields_struct typname ({Typ.name; fields} as st) =
-      Tenv.add tenv typname
-        (Typ.mk_struct ~default:st ~fields:(sort_fields fields) name) in
+    let sort_fields_struct _ ({Typ.name; fields} as st) =
+      ignore (Tenv.mk_struct tenv ~default:st ~fields:(sort_fields fields) name) in
     Tenv.iter sort_fields_struct tenv
 
   let rec collect_list_tuples l (a, a1, b, c, d) =

infer/src/clang/cTrans.ml

@@ -126,9 +126,8 @@ struct
         Printing.log_out "-----> field: '%s'\n" (Ident.fieldname_to_string fn)) fields;
     let mblock = Mangled.from_string block_name in
     let block_name = Typename.TN_csu (Csu.Class Csu.Objc, mblock) in
-    let block_struct_typ = Typ.mk_struct ~fields block_name in
+    let block_struct_typ = Tenv.mk_struct tenv ~fields block_name in
     let block_type = Typ.Tstruct block_struct_typ in
-    Tenv.add tenv block_name block_struct_typ;
     let trans_res =
       CTrans_utils.alloc_trans
         trans_state loc (Ast_expressions.dummy_stmt_info ()) block_type true None in

infer/src/clang/cTypes_decl.ml

@@ -16,14 +16,8 @@ open CFrontend_utils
 module L = Logging
 
 let add_predefined_objc_types tenv =
-  let class_typename = CType_to_sil_type.get_builtin_objc_typename `ObjCClass in
-  let objc_class_type_info =
-    Typ.mk_struct (TN_csu (Struct, Mangled.from_string CFrontend_config.objc_class)) in
-  Tenv.add tenv class_typename objc_class_type_info;
-  let id_typename = CType_to_sil_type.get_builtin_objc_typename `ObjCId in
-  let objc_object_type_info =
-    Typ.mk_struct (TN_csu (Struct, Mangled.from_string CFrontend_config.objc_object)) in
-  Tenv.add tenv id_typename objc_object_type_info
+  ignore (Tenv.mk_struct tenv (CType_to_sil_type.get_builtin_objc_typename `ObjCClass));
+  ignore (Tenv.mk_struct tenv (CType_to_sil_type.get_builtin_objc_typename `ObjCId))
 
 (* Whenever new type are added manually to the translation in ast_expressions, *)
 (* they should be added here too!! *)
@@ -204,9 +198,9 @@ and get_record_declaration_struct_type tenv decl =
         let methods = get_class_methods name decl_list in (* C++ methods only *)
         let supers = get_superclass_list_cpp decl in
         let sil_type =
-          Typ.Tstruct (Typ.mk_struct ~fields ~statics ~methods ~supers ~annots sil_typename) in
+          Typ.Tstruct
+            (Tenv.mk_struct tenv ~fields ~statics ~methods ~supers ~annots sil_typename) in
         Ast_utils.update_sil_types_map type_ptr sil_type;
-        add_struct_to_tenv tenv sil_type;
         sil_type
       ) else (
         match Tenv.lookup tenv sil_typename with
@@ -218,10 +212,9 @@ and get_record_declaration_struct_type tenv decl =
             (* Later, when we see definition, it will be updated with a new value. *)
             (* Note: we know that this type will be wrapped with pointer type because *)
             (* there was no full definition of that type yet. *)
+            ignore (Typ.Tstruct (Tenv.mk_struct tenv ~fields:extra_fields sil_typename));
             let tvar_type = Typ.Tvar sil_typename in
-            let empty_struct_type = Typ.Tstruct (Typ.mk_struct ~fields:extra_fields sil_typename) in
             Ast_utils.update_sil_types_map type_ptr tvar_type;
-            add_struct_to_tenv tenv empty_struct_type;
             tvar_type)
   | _ -> assert false
 

infer/src/clang/objcCategory_decl.ml

@@ -81,11 +81,10 @@ let process_category type_ptr_to_sil_type tenv curr_class decl_info decl_list =
    | Some ({ fields; methods } as struct_typ) ->
        let new_fields = General_utils.append_no_duplicates_fields decl_fields fields in
        let new_methods = General_utils.append_no_duplicates_methods decl_methods methods in
-       let class_type_info =
-         Typ.mk_struct
-           ~default:struct_typ ~fields:new_fields ~statics:[] ~methods:new_methods class_tn_name in
-       Printing.log_out " Updating info for class '%s' in tenv\n" class_name;
-       Tenv.add tenv class_tn_name class_type_info
+       ignore(
+         Tenv.mk_struct tenv
+           ~default:struct_typ ~fields:new_fields ~statics:[] ~methods:new_methods class_tn_name );
+       Printing.log_out " Updating info for class '%s' in tenv\n" class_name
    | _ -> ());
   Typ.Tvar class_tn_name
 

infer/src/clang/objcInterface_decl.ml

@@ -129,10 +129,9 @@ let add_class_to_tenv type_ptr_to_sil_type tenv curr_class decl_info name_info d
   Printing.log_out "Class %s field:\n" class_name;
   IList.iter (fun (fn, _, _) ->
       Printing.log_out "-----> field: '%s'\n" (Ident.fieldname_to_string fn)) all_fields;
-  let interface_type_info =
-    Typ.mk_struct ~fields: all_fields ~supers ~methods ~annots:Typ.objc_class_annotation
-      interface_name in
-  Tenv.add tenv interface_name interface_type_info;
+  ignore(
+    Tenv.mk_struct tenv
+      ~fields: all_fields ~supers ~methods ~annots:Typ.objc_class_annotation interface_name );
   Printing.log_out
     "  >>>Verifying that Typename '%s' is in tenv\n" (Typename.to_string interface_name);
   (match Tenv.lookup tenv interface_name with
@@ -149,8 +148,7 @@ let add_missing_methods tenv class_name ck decl_info decl_list curr_class =
     match Tenv.lookup tenv class_tn_name with
     | Some ({ statics = []; name = TN_csu (Class _, _); methods; } as struct_typ) ->
         let methods = General_utils.append_no_duplicates_methods methods decl_methods in
-        let struct_typ' = Typ.mk_struct ~default:struct_typ ~methods struct_typ.name in
-        Tenv.add tenv class_tn_name struct_typ'
+        ignore( Tenv.mk_struct tenv ~default:struct_typ ~methods class_tn_name )
     | _ -> ()
   end;
   Typ.Tvar class_tn_name

infer/src/clang/objcProtocol_decl.ml

@@ -33,8 +33,7 @@ let protocol_decl type_ptr_to_sil_type tenv decl =
       let decl_key = `DeclPtr decl_info.Clang_ast_t.di_pointer in
       Ast_utils.update_sil_types_map decl_key (Typ.Tvar protocol_name);
       let methods = ObjcProperty_decl.get_methods curr_class decl_list in
-      let protocol_type_info = Typ.mk_struct ~methods protocol_name in
-      Tenv.add tenv protocol_name protocol_type_info;
+      ignore( Tenv.mk_struct tenv ~methods protocol_name );
       add_protocol_super type_ptr_to_sil_type tenv obj_c_protocol_decl_info;
       Typ.Tvar protocol_name
   | _ -> assert false

infer/src/eradicate/typeCheck.ml

@@ -218,7 +218,7 @@ let rec typecheck_expr
           loc in
       let index =
         match EradicateChecks.explain_expr tenv node index_exp with
-        | Some s -> Format.sprintf "%s" s
+        | Some s -> s
         | None -> "?" in
       let fname = Ident.create_fieldname
           (Mangled.from_string index)

infer/src/java/jTransType.ml

@@ -58,7 +58,7 @@ let const_type const =
 
 
 let typename_of_classname cn =
-  Typename.TN_csu (Csu.Class Csu.Java, (Mangled.from_string (JBasics.cn_name cn)))
+  Typename.Java.from_string (JBasics.cn_name cn)
 
 
 let rec get_named_type vt =
@@ -301,7 +301,7 @@ let rec get_all_fields program tenv cn =
 and create_sil_type program tenv cn =
   match JClasspath.lookup_node cn program with
   | None ->
-      Typ.Tstruct (Typ.mk_struct (Typename.Java.from_string (JBasics.cn_name cn)))
+      Typ.Tstruct (Tenv.mk_struct tenv (typename_of_classname cn))
   | Some node ->
       let create_super_list interface_names =
         IList.iter (fun cn -> ignore (get_class_type_no_pointer program tenv cn)) interface_names;
@@ -332,18 +332,11 @@ and create_sil_type program tenv cn =
             (super_classname_list, nonstatics, statics, item_annotation) in
       let methods = IList.map (fun j -> Procname.Java j) (get_class_procnames cn node) in
       Typ.Tstruct
-        (Typ.mk_struct ~fields ~statics ~methods ~supers ~annots
-           (Typename.Java.from_string (JBasics.cn_name cn)))
+        (Tenv.mk_struct tenv ~fields ~statics ~methods ~supers ~annots (typename_of_classname cn))
 
 and get_class_type_no_pointer program tenv cn =
-  let named_type = typename_of_classname cn in
-  match Tenv.lookup tenv named_type with
-  | None ->
-      (match create_sil_type program tenv cn with
-       | (Typ.Tstruct struct_typ) as typ->
-           Tenv.add tenv named_type struct_typ;
-           typ
-       | _ -> assert false)
+  match Tenv.lookup tenv (typename_of_classname cn) with
+  | None -> create_sil_type program tenv cn
   | Some struct_typ -> Typ.Tstruct struct_typ
 
 let get_class_type program tenv cn =