diff --git a/compiler/polymorphism_info.m b/compiler/polymorphism_info.m index 4dbaac81d..a92080d3b 100644 --- a/compiler/polymorphism_info.m +++ b/compiler/polymorphism_info.m @@ -50,32 +50,108 @@ :- func var_and_maybe_csa_to_var(var_and_maybe_csa) = prog_var. -%--------------------% +%---------------------% + % These two types together describe a two-stage map from a type + % to the type_info describing that type. The two stages specify + % + % - the type_ctor of the type, and + % - its argument types. + % + % The type_info will in general be a heap cell consisting of + % + % - a pointer to the statically allocated type_ctor_info for + % the type_ctor (which will contain the arity, amongs other things), and + % - the type_info for each argument type. + % + % (The in-general part is there because for zero-arity type_ctors, + % we do not allocate a heap cell.) + % + % The result of the two-stage map will be the program variable + % holding the type_info, and, if the type contains no type variables, + % then also a reference to the constant form of the type_info. + % :- type type_to_type_info_map == map(type_ctor, type_ctor_to_type_info_map). :- type type_ctor_to_type_info_map == map(list(mer_type), var_and_maybe_csa). -:- type typeclass_info_map == - map(class_name, typeclass_info_class_map). -:- type typeclass_info_class_map == - map(list(mer_type), typeclass_info_map_entry). -:- type typeclass_info_map_entry - ---> typeclass_info_map_entry( - % The cons_id representing the base_typeclass_info. - cons_id, +%---------------------% - % Maps the arguments of the typeclass_info_cell_constructor - % after the base_typeclass_info to the variable that holds the - % typeclass_info for that cell. - tci_args_map - ). + % These three types together describe a three-stage map from a typeclass + % constraint to the to the typeclass_info describing that type. + % The first two stages specify + % + % - the class_id of the typeclass constraint, and + % - its argument types. + % + % The third stage is needed because the general form of a typeclass_info + % does NOT consist of just + % + % - a pointer to the statically allocated base_typeclass_info for + % the typeclass, and + % - the type_info for each type, + % + % but also has two kinds of differences. + % + % The first difference is that a typeclass_info also contains references + % to other typeclass_infos (both from the context of the relevant + % instance declaration, and for the applicable superclasses). + % + % Part of the second difference is that a typeclass_info contains + % type_infos not for the argument types of the class, but for the types + % occurring in the instance declaration, which may be different. + % The rest of the second difference is that the place of these type_infos + % in the typeclass_info depends on whether the type variables that + % they represent are constrained or not. + % + % This is why the third stage map specifies exactly the second-and-later + % arguments of the typeclass_info_cell_constructor in a typeclass info cell + % (the base_typeclass_info arg is always the first). In general, some + % of these arguments will be type_infos, and some will be typeclass_infos. + % Each argument may be a constant, or a variable. + % + % The result of the three-stage map will be the program variable + % holding the typeclass_info, and, if all the arguments are constants, + % then also a reference to the constant form of the typeclass_info. + % + % XXX I (zs) am not sure whether the second stage of the three-stage map + % is actually required (the first and third stages should suffice), + % though I am pretty sure that including them made the initial + % implementation of the relevant code much easier to debug. + % + % On the other hand, it may be that the key to the second stage + % (the list of the class name's argument types) uniquely determines + % the key to the third stage, making the third stage redundant. + % (The code that computes the list of const_or_var_args is so long + % that answering that question is not at all easy.) + % + % XXX We should consider replacing the key type of the tci_args_map + % with a structure containing not one but FOUR lists of const_or_var_args. + % At the moment, make_typeclass_info_from_proof_instance computes + % the one list like this: + % + % ArgVarsMCAs = ArgUnconstrainedTypeInfoVarsMCAs ++ + % ArgTypeClassInfoVarsMCAs ++ + % ArgSuperClassVarsMCAs ++ ArgTypeInfoVarsMCAs, + % + % Instead of ArgVarsMCAs, we could store its four components. + % This should make it easier to debug any future changeover + % to the design documented in runtime/mercury_typeclass_info.h. + % +:- type class_to_typeclass_info_map == + map(class_id, class_id_to_typeclass_info_map). +:- type class_id_to_typeclass_info_map == + map(list(mer_type), tci_args_map). :- type tci_args_map == map(list(const_or_var_arg), var_and_maybe_csa). +%---------------------% + :- type int_const_map == map(int, prog_var). +%---------------------% + % If the value that can be a constant structure argument is currently % available in a variable, give the id of that variable. % @@ -85,17 +161,17 @@ :- type poly_info. - % Init_poly_info initializes a poly_info from a pred_info and clauses_info. + % This predicate initializes a poly_info from a pred_info and clauses_info. % (See also create_poly_info.) % :- pred init_poly_info(module_info::in, pred_info::in, clauses_info::in, poly_info::out) is det. - % Extract some fields from a pred_info and proc_info and use them to - % create a poly_info, for use by the polymorphism transformation. + % Extract some fields from a pred_info and proc_info, and use them + % to create a poly_info, for use by the polymorphism transformation. % -:- pred create_poly_info(module_info::in, pred_info::in, - proc_info::in, poly_info::out) is det. +:- pred create_poly_info(module_info::in, pred_info::in, proc_info::in, + poly_info::out) is det. % Update the fields in a pred_info and proc_info with % the values in a poly_info. @@ -126,8 +202,8 @@ constraint_map::out) is det. :- pred poly_info_get_type_to_type_info_map(poly_info::in, type_to_type_info_map::out) is det. -:- pred poly_info_get_typeclass_info_map(poly_info::in, - typeclass_info_map::out) is det. +:- pred poly_info_get_class_to_typeclass_info_map(poly_info::in, + class_to_typeclass_info_map::out) is det. :- pred poly_info_get_int_const_map(poly_info::in, int_const_map::out) is det. :- pred poly_info_get_const_struct_var_map(poly_info::in, @@ -155,7 +231,8 @@ poly_info::in, poly_info::out) is det. :- pred poly_info_set_type_to_type_info_map(type_to_type_info_map::in, poly_info::in, poly_info::out) is det. -:- pred poly_info_set_typeclass_info_map(typeclass_info_map::in, +:- pred poly_info_set_class_to_typeclass_info_map( + class_to_typeclass_info_map::in, poly_info::in, poly_info::out) is det. :- pred poly_info_set_int_const_map(int_const_map::in, poly_info::in, poly_info::out) is det. @@ -174,11 +251,11 @@ :- type cache_maps ---> cache_maps( - cm_snapshot_num :: int, - cm_type_to_type_info_map :: type_to_type_info_map, - cm_typeclass_info_map :: typeclass_info_map, - cm_int_const_map :: int_const_map, - cm_const_struct_var_map :: const_struct_var_map + cm_snapshot_num :: int, + cm_type_to_type_info_map :: type_to_type_info_map, + cm_class_to_typeclass_info_map :: class_to_typeclass_info_map, + cm_int_const_map :: int_const_map, + cm_const_struct_var_map :: const_struct_var_map ). :- pred get_cache_maps_snapshot(string::in, cache_maps::out, @@ -288,7 +365,7 @@ var_and_maybe_csa_to_var(var_and_maybe_csa(V, _)) = V. % fourth map. The integers are in the third map. % The fourth map also caches typeclass_infos for instance ids. poly_type_to_type_info_map :: type_to_type_info_map, - poly_typeclass_info_map :: typeclass_info_map, + poly_class_to_typeclass_info_map:: class_to_typeclass_info_map, poly_int_const_map :: int_const_map, poly_const_struct_var_map :: const_struct_var_map, poly_num_reuses :: int, @@ -388,7 +465,7 @@ poly_info_extract(Info, Specs, !PredInfo, !ProcInfo, !:ModuleInfo) :- :- pragma inline(pred(poly_info_get_proof_map/2)). :- pragma inline(pred(poly_info_get_constraint_map/2)). :- pragma inline(pred(poly_info_get_type_to_type_info_map/2)). -:- pragma inline(pred(poly_info_get_typeclass_info_map/2)). +:- pragma inline(pred(poly_info_get_class_to_typeclass_info_map/2)). :- pragma inline(pred(poly_info_get_const_struct_var_map/2)). :- pragma inline(pred(poly_info_get_int_const_map/2)). :- pragma inline(pred(poly_info_get_num_reuses/2)). @@ -411,8 +488,8 @@ poly_info_get_constraint_map(PI, X) :- X = PI ^ poly_constraint_map. poly_info_get_type_to_type_info_map(PI, X) :- X = PI ^ poly_type_to_type_info_map. -poly_info_get_typeclass_info_map(PI, X) :- - X = PI ^ poly_typeclass_info_map. +poly_info_get_class_to_typeclass_info_map(PI, X) :- + X = PI ^ poly_class_to_typeclass_info_map. poly_info_get_int_const_map(PI, X) :- X = PI ^ poly_int_const_map. poly_info_get_const_struct_var_map(PI, X) :- @@ -434,7 +511,7 @@ poly_info_get_errors(PI, X) :- :- pragma inline(pred(poly_info_set_typevarset/3)). :- pragma inline(pred(poly_info_set_proof_map/3)). :- pragma inline(pred(poly_info_set_type_to_type_info_map/3)). -:- pragma inline(pred(poly_info_set_typeclass_info_map/3)). +:- pragma inline(pred(poly_info_set_class_to_typeclass_info_map/3)). :- pragma inline(pred(poly_info_set_int_const_map/3)). :- pragma inline(pred(poly_info_set_const_struct_var_map/3)). :- pragma inline(pred(poly_info_set_num_reuses/3)). @@ -462,16 +539,21 @@ poly_info_set_proof_map(X, !PI) :- !PI ^ poly_proof_map := X ). poly_info_set_type_to_type_info_map(X, !PI) :- - ( if private_builtin.pointer_equal(X, !.PI ^ poly_type_to_type_info_map) then + ( if + private_builtin.pointer_equal(X, !.PI ^ poly_type_to_type_info_map) + then true else !PI ^ poly_type_to_type_info_map := X ). -poly_info_set_typeclass_info_map(X, !PI) :- - ( if private_builtin.pointer_equal(X, !.PI ^ poly_typeclass_info_map) then +poly_info_set_class_to_typeclass_info_map(X, !PI) :- + ( if + private_builtin.pointer_equal(X, + !.PI ^ poly_class_to_typeclass_info_map) + then true else - !PI ^ poly_typeclass_info_map := X + !PI ^ poly_class_to_typeclass_info_map := X ). poly_info_set_int_const_map(X, !PI) :- ( if private_builtin.pointer_equal(X, !.PI ^ poly_int_const_map) then @@ -515,7 +597,7 @@ poly_info_set_errors(X, !PI) :- % 6 14812 3980 4058 49.515% proof_map % 7 3030093 0 0 constraint_map % 8 811687 776589 288951 72.882% type_to_type_info_map -% 9 385071 863384 6104 99.298% typeclass_info_map +% 9 385071 863384 6104 99.298% class_to_typeclass_info_map % 10 385706 863310 8464 99.029% int_const_map % 11 253310 331092 41528 88.855% num_reuses % 12 2559364 25821 15631 62.291% const_struct_db @@ -626,7 +708,7 @@ poly_info_set_errors(X, !PI) :- get_cache_maps_snapshot(Name, CacheMaps, !Info) :- poly_info_get_type_to_type_info_map(!.Info, TypeInfoVarMap), - poly_info_get_typeclass_info_map(!.Info, TypeClassInfoMap), + poly_info_get_class_to_typeclass_info_map(!.Info, TypeClassInfoMap), poly_info_get_int_const_map(!.Info, IntConstMap), poly_info_get_const_struct_var_map(!.Info, ConstStructVarMap), @@ -662,7 +744,7 @@ set_cache_maps_snapshot(Name, CacheMaps, !Info) :- private_builtin.pointer_equal(TypeInfoVarMap, !.Info ^ poly_type_to_type_info_map), private_builtin.pointer_equal(TypeClassInfoMap, - !.Info ^ poly_typeclass_info_map), + !.Info ^ poly_class_to_typeclass_info_map), private_builtin.pointer_equal(IntConstMap, !.Info ^ poly_int_const_map), private_builtin.pointer_equal(ConstStructVarMap, @@ -672,7 +754,7 @@ set_cache_maps_snapshot(Name, CacheMaps, !Info) :- else !:Info = ((((!.Info ^ poly_type_to_type_info_map := TypeInfoVarMap) - ^ poly_typeclass_info_map := TypeClassInfoMap) + ^ poly_class_to_typeclass_info_map := TypeClassInfoMap) ^ poly_int_const_map := IntConstMap) ^ poly_const_struct_var_map := ConstStructVarMap) ), @@ -696,9 +778,10 @@ set_cache_maps_snapshot(Name, CacheMaps, !Info) :- io.format(Stream, "%stype_to_type_info_map ", [s(IndentStr)], !IO), io.write_line(Stream, CacheMaps ^ cm_type_to_type_info_map, !IO), - io.format(Stream, "%stypeclass_info_map ", + io.format(Stream, "%sclass_to_typeclass_info_map ", [s(IndentStr)], !IO), - io.write_line(Stream, CacheMaps ^ cm_typeclass_info_map, !IO), + io.write_line(Stream, CacheMaps ^ cm_class_to_typeclass_info_map, + !IO), io.format(Stream, "%sstruct_var_map ", [s(IndentStr)], !IO), io.write_line(Stream, CacheMaps ^ cm_const_struct_var_map, !IO), @@ -710,7 +793,7 @@ set_cache_maps_snapshot(Name, CacheMaps, !Info) :- empty_cache_maps(!Info) :- poly_info_set_type_to_type_info_map(map.init, !Info), - poly_info_set_typeclass_info_map(map.init, !Info), + poly_info_set_class_to_typeclass_info_map(map.init, !Info), poly_info_set_int_const_map(map.init, !Info), poly_info_set_const_struct_var_map(map.init, !Info). @@ -759,9 +842,10 @@ set_var_maps_snapshot(Name, VarMaps, !Info) :- io.format(Stream, "%stype_to_type_info_map ", [s(IndentStr)], !IO), io.write_line(Stream, CacheMaps ^ cm_type_to_type_info_map, !IO), - io.format(Stream, "%stypeclass_info_map ", + io.format(Stream, "%sclass_to_typeclass_info_map ", [s(IndentStr)], !IO), - io.write_line(Stream, CacheMaps ^ cm_typeclass_info_map, !IO), + io.write_line(Stream, CacheMaps ^ cm_class_to_typeclass_info_map, + !IO), io.format(Stream, "%sstruct_var_map ", [s(IndentStr)], !IO), io.write_line(Stream, CacheMaps ^ cm_const_struct_var_map, !IO), diff --git a/compiler/polymorphism_type_class_info.m b/compiler/polymorphism_type_class_info.m index bcbc5021b..ec5dd69cd 100644 --- a/compiler/polymorphism_type_class_info.m +++ b/compiler/polymorphism_type_class_info.m @@ -156,7 +156,7 @@ make_typeclass_info_var(ExistQVars, Context, Seen, Constraint, TypeClassInfoVar = OldTypeClassInfoVar, TypeClassInfoVarMCA = var_and_maybe_csa(TypeClassInfoVar, no), Goals = [], - record_constructed_typeclass_info_var("rtti_varmaps", + log_constructed_typeclass_info_var("rtti_varmaps", do_not_dump_all_tables, 0, Constraint, TypeClassInfoVar, no, no, !Info) else if @@ -165,6 +165,8 @@ make_typeclass_info_var(ExistQVars, Context, Seen, Constraint, poly_info_get_proof_map(!.Info, ProofMap), map.search(ProofMap, Constraint, Proof) then + % make_typeclass_info_from_proof will call + % log_constructed_typeclass_info_var. make_typeclass_info_from_proof(ExistQVars, Context, Seen, Constraint, Proof, TypeClassInfoVarMCA, Goals, !Info) else @@ -178,7 +180,7 @@ make_typeclass_info_var(ExistQVars, Context, Seen, Constraint, poly_info_set_rtti_varmaps(RttiVarMaps, !Info), TypeClassInfoVarMCA = var_and_maybe_csa(TypeClassInfoVar, no), Goals = [], - record_constructed_typeclass_info_var("for later", + log_constructed_typeclass_info_var("for later", do_not_dump_all_tables, 0, Constraint, TypeClassInfoVar, no, no, !Info) ). @@ -196,6 +198,8 @@ make_typeclass_info_from_proof(ExistQVars, Context, Seen, % XXX MR_Dictionary should have MR_Dictionaries for superclass % We have to extract the typeclass_info from another one. Proof = superclass(SubClassConstraint), + % get_or_make_typeclass_info_from_proof_subclass will call + % log_constructed_typeclass_info_var. get_or_make_typeclass_info_from_proof_subclass(ExistQVars, Context, Seen, Constraint, SubClassConstraint, TypeClassInfoVarMCA, Goals, !Info) @@ -203,6 +207,8 @@ make_typeclass_info_from_proof(ExistQVars, Context, Seen, % We have to construct the typeclass_info using an instance % declaration. Proof = apply_instance(InstanceNum), + % get_or_make_typeclass_info_from_proof_instance will call + % log_constructed_typeclass_info_var. get_or_make_typeclass_info_from_proof_instance(ExistQVars, Context, Seen, Constraint, InstanceNum, TypeClassInfoVarMCA, Goals, !Info) ). @@ -313,7 +319,7 @@ get_or_make_typeclass_info_from_proof_subclass(ExistQVars, Context, Seen, Goals, !Info), TypeClassInfoVarMCA = var_and_maybe_csa(TypeClassInfoVar, yes(SelectedArg)), - record_constructed_typeclass_info_var("subclass constant", + log_constructed_typeclass_info_var("subclass constant", do_not_dump_all_tables, -1, Constraint, TypeClassInfoVar, yes(SelectedArg), MaybeConsId, !Info) else @@ -335,7 +341,7 @@ get_or_make_typeclass_info_from_proof_subclass(ExistQVars, Context, Seen, instmap_delta_bind_no_var, only_mode, detism_det, purity_pure, [], Context, SuperClassGoal), Goals = SubClassVarGoals ++ IndexGoals ++ [SuperClassGoal], - record_constructed_typeclass_info_var("subclass computed", + log_constructed_typeclass_info_var("subclass computed", do_not_dump_all_tables, -1, Constraint, TypeClassInfoVar, no, no, !Info) ). @@ -436,36 +442,32 @@ get_or_make_typeclass_info_from_proof_instance(ExistQVars, Context, Seen, Goals = [_ | _], ResultStr = "instance cached result" ), - record_constructed_typeclass_info_var(ResultStr, + log_constructed_typeclass_info_var(ResultStr, do_not_dump_all_tables, -1, Constraint, TypeClassInfoVar, yes(CSA), MaybeConsId, !Info) else + % make_typeclass_info_from_proof_instance will call + % log_constructed_typeclass_info_var. make_typeclass_info_from_proof_instance(ExistQVars, Context, - ConstInstanceId, TypeClassInfoVarMCA, BaseConsId, Goals, !Info), - TypeClassInfoVarMCA = var_and_maybe_csa(TypeClassInfoVar, MaybeCSA), - record_constructed_typeclass_info_var("instance computed", - dump_all_tables, -1, Constraint, - TypeClassInfoVar, MaybeCSA, yes(BaseConsId), !Info) + ConstInstanceId, TypeClassInfoVarMCA, Goals, !Info) ). :- pred make_typeclass_info_from_proof_instance(existq_tvars::in, - prog_context::in, const_instance_id::in, - var_and_maybe_csa::out, cons_id::out, + prog_context::in, const_instance_id::in, var_and_maybe_csa::out, list(hlds_goal)::out, poly_info::in, poly_info::out) is det. make_typeclass_info_from_proof_instance(ExistQVars, Context, - ConstInstanceId, TypeClassInfoVarMCA, BaseConsId, Goals, !Info) :- + ConstInstanceId, TypeClassInfoVarMCA, Goals, !Info) :- poly_info_get_module_info(!.Info, ModuleInfo), - module_info_get_class_table(ModuleInfo, ClassTable), module_info_get_instance_table(ModuleInfo, InstanceTable), poly_info_get_typevarset(!.Info, TypeVarSet), poly_info_get_proof_map(!.Info, ProofMap0), ConstInstanceId = ciid(InstanceNum, Constraint, Seen), - Constraint = constraint(ClassName, ConstrainedTypes), + Constraint = constraint(ClassSymName, ClassArgTypes), - list.length(ConstrainedTypes, ClassArity), - ClassId = class_id(ClassName, ClassArity), + list.length(ClassArgTypes, ClassArity), + ClassId = class_id(ClassSymName, ClassArity), map.lookup(InstanceTable, ClassId, InstanceList), list.det_index1(InstanceList, InstanceNum, ProofInstanceDefn), @@ -487,8 +489,7 @@ make_typeclass_info_from_proof_instance(ExistQVars, Context, % when we call type_list_subsumes then apply the resulting bindings. tvarset_merge_renaming(TypeVarSet, InstanceTVarset, _NewTVarset, Renaming), apply_renaming_to_types(Renaming, InstanceTypes, RenamedInstanceTypes), - type_list_subsumes_det(RenamedInstanceTypes, ConstrainedTypes, - InstanceSubst), + type_list_subsumes_det(RenamedInstanceTypes, ClassArgTypes, InstanceSubst), apply_renaming_to_prog_constraints(Renaming, InstanceConstraints, RenamedInstanceConstraints), apply_rec_subst_to_prog_constraints(InstanceSubst, @@ -515,7 +516,7 @@ make_typeclass_info_from_proof_instance(ExistQVars, Context, % Make the type_infos for the types that are constrained by this. % These are packaged in the typeclass_info. - polymorphism_do_make_type_info_vars(Context, ConstrainedTypes, + polymorphism_do_make_type_info_vars(Context, ClassArgTypes, ArgTypeInfoVarsMCAs, TypeInfoGoals, !Info), % Make the typeclass_infos for the constraints from the context of the @@ -531,9 +532,9 @@ make_typeclass_info_from_proof_instance(ExistQVars, Context, %---------------------% + module_info_get_class_table(ModuleInfo, ClassTable), map.lookup(ClassTable, ClassId, ClassDefn), - - get_arg_superclass_vars(ClassDefn, ConstrainedTypes, ProofMap, + get_arg_superclass_vars(ClassDefn, ClassArgTypes, ProofMap, ExistQVars, Context, ArgSuperClassVarsMCAs, SuperClassGoals, !Info), PrevGoals = UnconstrainedTypeInfoGoals ++ TypeInfoGoals ++ @@ -544,24 +545,27 @@ make_typeclass_info_from_proof_instance(ExistQVars, Context, ArgSuperClassVarsMCAs ++ ArgTypeInfoVarsMCAs, list.map(make_const_or_var_arg, ArgVarsMCAs, ArgCOVAs), - Constraint = constraint(ConstraintClassName, ConstraintArgTypes), - poly_info_get_typeclass_info_map(!.Info, TypeClassInfoMap0), + poly_info_get_class_to_typeclass_info_map(!.Info, TypeClassInfoMap0), ( if - map.search(TypeClassInfoMap0, ConstraintClassName, ClassNameMap0), - map.search(ClassNameMap0, ConstraintArgTypes, OldEntry0), - OldEntry0 = typeclass_info_map_entry(BaseConsIdPrime, ArgsMap0), + map.search(TypeClassInfoMap0, ClassId, ClassIdMap0), + map.search(ClassIdMap0, ClassArgTypes, ArgsMap0), map.search(ArgsMap0, ArgCOVAs, OldTypeClassInfoVarMCA0) then TypeClassInfoVarMCA = OldTypeClassInfoVarMCA0, - BaseConsId = BaseConsIdPrime, Goals = [], set_var_maps_snapshot("make_typeclass_info", InitialVarMapsSnapshot, !Info), poly_info_get_num_reuses(!.Info, NumReuses), - poly_info_set_num_reuses(NumReuses + 2, !Info) + poly_info_set_num_reuses(NumReuses + 2, !Info), + + TypeClassInfoVarMCA = + var_and_maybe_csa(TypeClassInfoVar, TypeClassInfoMCA), + log_constructed_typeclass_info_var("instance recorded", + dump_all_tables, -1, Constraint, + TypeClassInfoVar, TypeClassInfoMCA, no, !Info) else - get_base_typeclass_info_cons_id(!.Info, InstanceTable, Constraint, - instance_id(InstanceNum), InstanceTypes, BaseConsId), + get_base_typeclass_info_cons_id(!.Info, ClassId, InstanceNum, + ProofInstanceDefn, InstanceTypes, BaseConsId), materialize_base_typeclass_info_var(Context, Constraint, BaseConsId, BaseVar, BaseGoals, !Info), construct_typeclass_info(Context, Constraint, @@ -573,37 +577,35 @@ make_typeclass_info_from_proof_instance(ExistQVars, Context, % We must start the search from scratch, since construct_typeclass_info % may have reset all the cache maps. - poly_info_get_typeclass_info_map(!.Info, TypeClassInfoMap1), + poly_info_get_class_to_typeclass_info_map(!.Info, TypeClassInfoMap1), ( if - map.search(TypeClassInfoMap1, ConstraintClassName, ClassNameMap1) + map.search(TypeClassInfoMap1, ClassId, ClassIdMap1) then - ( if map.search(ClassNameMap1, ConstraintArgTypes, OldEntry1) then - OldEntry1 = typeclass_info_map_entry(BaseConsId1, ArgsMap1), - expect(unify(BaseConsId1, BaseConsId), $pred, - "BaseConsId1 != BaseConsId"), + ( if map.search(ClassIdMap1, ClassArgTypes, ArgsMap1) then map.det_insert(ArgCOVAs, TypeClassInfoVarMCA, ArgsMap1, ArgsMap), - Entry = typeclass_info_map_entry(BaseConsId, ArgsMap), - map.det_update(ConstraintArgTypes, Entry, - ClassNameMap1, ClassNameMap), - map.det_update(ConstraintClassName, ClassNameMap, + map.det_update(ClassArgTypes, ArgsMap, + ClassIdMap1, ClassIdMap), + map.det_update(ClassId, ClassIdMap, TypeClassInfoMap1, TypeClassInfoMap) else ArgsMap = map.singleton(ArgCOVAs, TypeClassInfoVarMCA), - Entry = typeclass_info_map_entry(BaseConsId, ArgsMap), - map.det_insert(ConstraintArgTypes, Entry, - ClassNameMap1, ClassNameMap), - map.det_update(ConstraintClassName, ClassNameMap, + map.det_insert(ClassArgTypes, ArgsMap, + ClassIdMap1, ClassIdMap), + map.det_update(ClassId, ClassIdMap, TypeClassInfoMap1, TypeClassInfoMap) ) else ArgsMap = map.singleton(ArgCOVAs, TypeClassInfoVarMCA), - Entry = typeclass_info_map_entry(BaseConsId, ArgsMap), - ClassNameMap = map.singleton(ConstraintArgTypes, Entry), - map.det_insert(ConstraintClassName, ClassNameMap, + ClassIdMap = map.singleton(ClassArgTypes, ArgsMap), + map.det_insert(ClassId, ClassIdMap, TypeClassInfoMap1, TypeClassInfoMap) ), - poly_info_set_typeclass_info_map(TypeClassInfoMap, !Info) + poly_info_set_class_to_typeclass_info_map(TypeClassInfoMap, !Info), + + log_constructed_typeclass_info_var("instance computed", + dump_all_tables, -1, Constraint, + TypeClassInfoVar, TypeClassInfoMCA, yes(BaseConsId), !Info) ), ( if @@ -1060,18 +1062,13 @@ materialize_typeclass_info_var(Context, Constraint, InstanceIdConstNum, % Given a type_ctor, return the cons_id that represents its type_ctor_info. % -:- pred get_base_typeclass_info_cons_id(poly_info::in, instance_table::in, - prog_constraint::in, instance_id::in, list(mer_type)::in, +:- pred get_base_typeclass_info_cons_id(poly_info::in, + class_id::in, int::in, hlds_instance_defn::in, list(mer_type)::in, cons_id::out) is det. -get_base_typeclass_info_cons_id(Info, InstanceTable, Constraint, InstanceId, +get_base_typeclass_info_cons_id(Info, ClassId, InstanceNum, ProofInstanceDefn, InstanceTypes, ConsId) :- - Constraint = constraint(ClassSymName, ConstraintArgTypes), - ClassId = class_id(ClassSymName, list.length(ConstraintArgTypes)), - map.lookup(InstanceTable, ClassId, InstanceList), - InstanceId = instance_id(InstanceNum), - list.det_index1(InstanceList, InstanceNum, InstanceDefn), - InstanceModuleName = InstanceDefn ^ instdefn_module, + InstanceModuleName = ProofInstanceDefn ^ instdefn_module, % NOTE The InstanceString ignores all parts of the InstanceTypes % except for the top type_ctor of each type. make_instance_string(InstanceTypes, InstanceString), @@ -1090,13 +1087,13 @@ get_base_typeclass_info_cons_id(Info, InstanceTable, Constraint, InstanceId, poly_info_get_debug_stream(Info, Stream, !IO), poly_info_get_indent_level(Level, !IO), IndentStr = string.duplicate_char(' ', Level * 4), - poly_info_get_typevarset(Info, TVarSet), - ConstraintStr = trace_constraint_to_string(TVarSet, Constraint), + ClassId = class_id(ClassSymName, ClassArity), + ClassSymNameStr = sym_name_to_string(ClassSymName), ConsIdStr = unqual_cons_id_and_arity_to_string(ConsId), io.format(Stream, "%sget_base_typeclass_info_cons_id:\n", [s(IndentStr)], !IO), - io.format(Stream, "%s %s\n", - [s(IndentStr), s(ConstraintStr)], !IO), + io.format(Stream, "%s %s/%d\n", + [s(IndentStr), s(ClassSymNameStr), i(ClassArity)], !IO), io.format(Stream, "%s %s\n\n", [s(IndentStr), s(ConsIdStr)], !IO), io.flush_output(Stream, !IO) @@ -1111,13 +1108,13 @@ get_base_typeclass_info_cons_id(Info, InstanceTable, Constraint, InstanceId, ---> do_not_dump_all_tables ; dump_all_tables. -:- pred record_constructed_typeclass_info_var(string::in, +:- pred log_constructed_typeclass_info_var(string::in, maybe_dump_all_tables::in, int::in, prog_constraint::in, prog_var::in, maybe(const_struct_arg)::in, maybe(cons_id)::in, poly_info::in, poly_info::out) is det. -record_constructed_typeclass_info_var(Where, MaybeDumpAll, LevelStep, - Constraint, TypeClassInfoVar, MaybeCSA, MaybeConsId, Info, Info) :- +log_constructed_typeclass_info_var(Where, MaybeDumpAll, LevelStep, + Constraint, TypeClassInfoVar, MaybeCSA, MaybeBaseConsId, Info, Info) :- trace [ compile_time(flag("debug_poly_caches")), run_time(env("DEBUG_POLY_CACHES")), @@ -1146,23 +1143,25 @@ record_constructed_typeclass_info_var(Where, MaybeDumpAll, LevelStep, CSAStr = "no const_struct_arg" ), ( - MaybeConsId = yes(ConsId), - ConsIdStr = unqual_cons_id_and_arity_to_string(ConsId) + MaybeBaseConsId = yes(BaseConsId), + BaseConsIdStr = unqual_cons_id_and_arity_to_string(BaseConsId) ; - MaybeConsId = no, - ConsIdStr = "no cons_id" + MaybeBaseConsId = no, + BaseConsIdStr = "no base_cons_id" ), io.format(Stream, "%sFOR CONSTRAINT %s,\n%s%s returns %s\n", [s(IndentStr), s(ConstraintStr), s(IndentStr), s(Where), s(VarStr)], !IO), io.format(Stream, "%s %s\n%s %s\n\n", - [s(IndentStr), s(CSAStr), s(IndentStr), s(ConsIdStr)], !IO), + [s(IndentStr), s(CSAStr), s(IndentStr), s(BaseConsIdStr)], + !IO), ( MaybeDumpAll = do_not_dump_all_tables ; MaybeDumpAll = dump_all_tables, write_type_to_type_info_map(Stream, Info, IndentStr, !IO), - write_typeclass_info_map(Stream, Info, IndentStr, !IO), + write_class_to_typeclass_info_map(Stream, Info, + IndentStr, !IO), write_constr_struct_var_map(Stream, Info, IndentStr, !IO) ), io.nl(Stream, !IO), @@ -1186,9 +1185,9 @@ write_type_to_type_info_map(Stream, Info, IndentStr, !IO) :- NextIndentStr), TypeInfoVarMap, !IO). -:- pred write_type_ctor_to_type_info_map(io.text_output_stream::in, tvarset::in, - var_table::in, string::in, type_ctor::in, type_ctor_to_type_info_map::in, - io::di, io::uo) is det. +:- pred write_type_ctor_to_type_info_map(io.text_output_stream::in, + tvarset::in, var_table::in, string::in, type_ctor::in, + type_ctor_to_type_info_map::in, io::di, io::uo) is det. write_type_ctor_to_type_info_map(Stream, TVarSet, VarTable, IndentStr, TypeCtor, TypeInfoVarMapEntry, !IO) :- @@ -1216,14 +1215,14 @@ write_type_ctor_to_type_info_map_entry(Stream, TVarSet, VarTable, IndentStr, %---------------------------------------------------------------------------% -:- pred write_typeclass_info_map(io.text_output_stream::in, +:- pred write_class_to_typeclass_info_map(io.text_output_stream::in, poly_info::in, string::in, io::di, io::uo) is det. -write_typeclass_info_map(Stream, Info, IndentStr, !IO) :- - poly_info_get_typeclass_info_map(Info, TypeClassInfoMap), +write_class_to_typeclass_info_map(Stream, Info, IndentStr, !IO) :- + poly_info_get_class_to_typeclass_info_map(Info, TypeClassInfoMap), poly_info_get_typevarset(Info, TVarSet), poly_info_get_var_table(Info, VarTable), - io.format(Stream, "%stypeclass_info_map\n", [s(IndentStr)], !IO), + io.format(Stream, "%sclass_to_typeclass_info_map\n", [s(IndentStr)], !IO), NextIndentStr = IndentStr ++ " ", map.foldl( write_typeclass_info_top_map_entry(Stream, TVarSet, VarTable, @@ -1232,30 +1231,30 @@ write_typeclass_info_map(Stream, Info, IndentStr, !IO) :- :- pred write_typeclass_info_top_map_entry(io.text_output_stream::in, tvarset::in, var_table::in, string::in, - class_name::in, typeclass_info_class_map::in, io::di, io::uo) is det. + class_id::in, class_id_to_typeclass_info_map::in, io::di, io::uo) is det. write_typeclass_info_top_map_entry(Stream, TVarSet, VarTable, IndentStr, - ClassSymName, TypeClassInfoClassMap, !IO) :- + ClassId, TypeClassInfoClassMap, !IO) :- + ClassId = class_id(ClassSymName, ClassArity), ClassName = unqualify_name(ClassSymName), - io.format(Stream, "%sclass name %s\n", [s(IndentStr), s(ClassName)], !IO), + io.format(Stream, "%sclass id %s/%d\n", + [s(IndentStr), s(ClassName), i(ClassArity)], !IO), NextIndentStr = IndentStr ++ " ", map.foldl( - write_typeclass_info_class_map_entry(Stream, TVarSet, VarTable, + write_typeclass_info_args(Stream, TVarSet, VarTable, NextIndentStr), TypeClassInfoClassMap, !IO). -:- pred write_typeclass_info_class_map_entry(io.text_output_stream::in, +:- pred write_typeclass_info_args(io.text_output_stream::in, tvarset::in, var_table::in, string::in, - list(mer_type)::in, typeclass_info_map_entry::in, io::di, io::uo) is det. + list(mer_type)::in, tci_args_map::in, io::di, io::uo) is det. -write_typeclass_info_class_map_entry(Stream, TVarSet, VarTable, IndentStr, - Types, Entry, !IO) :- +write_typeclass_info_args(Stream, TVarSet, VarTable, IndentStr, + Types, CVAMap, !IO) :- TypeStrs = list.map(trace_type_to_string(TVarSet), Types), TypesStr = string.join_list(", ", TypeStrs), - Entry = typeclass_info_map_entry(ConsId, CVAMap), - ConsIdStr = unqual_cons_id_and_arity_to_string(ConsId), io.format(Stream, "%stypes [%s]:\n", [s(IndentStr), s(TypesStr)], !IO), - io.format(Stream, "%s%s:\n", [s(IndentStr), s(ConsIdStr)], !IO), + io.format(Stream, "%s:\n", [s(IndentStr)], !IO), NextIndentStr = IndentStr ++ " ", map.foldl( write_typeclass_info_cva_map_entry(Stream, TVarSet, VarTable,