From 548338bb4e5a1555be148d16ba6c2c5113beeb4b Mon Sep 17 00:00:00 2001 From: Josh Berdine Date: Thu, 8 Sep 2016 06:00:32 -0700 Subject: [PATCH] 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 | 24 ++++++++++++++++++++++++ infer/src/IR/Tenv.rei | 13 +++++++++++++ infer/src/IR/Typ.re | 2 +- infer/src/IR/Typ.rei | 2 +- infer/src/backend/prover.ml | 2 +- infer/src/backend/rearrange.ml | 13 +++++-------- infer/src/backend/symExec.ml | 11 ++++------- infer/src/clang/cField_decl.ml | 6 ++---- infer/src/clang/cFrontend_utils.ml | 5 ++--- infer/src/clang/cTrans.ml | 3 +-- infer/src/clang/cTypes_decl.ml | 17 +++++------------ infer/src/clang/objcCategory_decl.ml | 9 ++++----- infer/src/clang/objcInterface_decl.ml | 10 ++++------ infer/src/clang/objcProtocol_decl.ml | 3 +-- infer/src/eradicate/typeCheck.ml | 2 +- infer/src/java/jTransType.ml | 17 +++++------------ 16 files changed, 74 insertions(+), 65 deletions(-) diff --git a/infer/src/IR/Tenv.re b/infer/src/IR/Tenv.re index e1a648be6..2a6700f50 100644 --- a/infer/src/IR/Tenv.re +++ b/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; diff --git a/infer/src/IR/Tenv.rei b/infer/src/IR/Tenv.rei index f4afbb4d0..79bec0ee4 100644 --- a/infer/src/IR/Tenv.rei +++ b/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; diff --git a/infer/src/IR/Typ.re b/infer/src/IR/Typ.re index 2d081e919..64fda8651 100644 --- a/infer/src/IR/Typ.re +++ b/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=? diff --git a/infer/src/IR/Typ.rei b/infer/src/IR/Typ.rei index 9a99a2f70..7902c104c 100644 --- a/infer/src/IR/Typ.rei +++ b/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? => diff --git a/infer/src/backend/prover.ml b/infer/src/backend/prover.ml index 5a3413e46..3bcc365a9 100644 --- a/infer/src/backend/prover.ml +++ b/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) diff --git a/infer/src/backend/rearrange.ml b/infer/src/backend/rearrange.ml index c4d1e4922..ec3057c89 100644 --- a/infer/src/backend/rearrange.ml +++ b/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 (_, _)):: _, _, _ -> diff --git a/infer/src/backend/symExec.ml b/infer/src/backend/symExec.ml index 94cc9dfa6..f10177144 100644 --- a/infer/src/backend/symExec.ml +++ b/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(); diff --git a/infer/src/clang/cField_decl.ml b/infer/src/clang/cField_decl.ml index d5cce054b..193998bdf 100644 --- a/infer/src/clang/cField_decl.ml +++ b/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))] diff --git a/infer/src/clang/cFrontend_utils.ml b/infer/src/clang/cFrontend_utils.ml index 0bfad0a75..845c6c034 100644 --- a/infer/src/clang/cFrontend_utils.ml +++ b/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) = diff --git a/infer/src/clang/cTrans.ml b/infer/src/clang/cTrans.ml index 6dfd3ffd5..f0eef5b65 100644 --- a/infer/src/clang/cTrans.ml +++ b/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 diff --git a/infer/src/clang/cTypes_decl.ml b/infer/src/clang/cTypes_decl.ml index b48a8d778..d51d8097c 100644 --- a/infer/src/clang/cTypes_decl.ml +++ b/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 diff --git a/infer/src/clang/objcCategory_decl.ml b/infer/src/clang/objcCategory_decl.ml index 5c3e9faf9..2cf8238ff 100644 --- a/infer/src/clang/objcCategory_decl.ml +++ b/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 diff --git a/infer/src/clang/objcInterface_decl.ml b/infer/src/clang/objcInterface_decl.ml index f696020cc..b509f8f0b 100644 --- a/infer/src/clang/objcInterface_decl.ml +++ b/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 diff --git a/infer/src/clang/objcProtocol_decl.ml b/infer/src/clang/objcProtocol_decl.ml index 467ebcdd0..14a35dd56 100644 --- a/infer/src/clang/objcProtocol_decl.ml +++ b/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 diff --git a/infer/src/eradicate/typeCheck.ml b/infer/src/eradicate/typeCheck.ml index 78d019d2a..a097805bf 100644 --- a/infer/src/eradicate/typeCheck.ml +++ b/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) diff --git a/infer/src/java/jTransType.ml b/infer/src/java/jTransType.ml index f87d9ce18..8c52b089a 100644 --- a/infer/src/java/jTransType.ml +++ b/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 =