diff --git a/compiler/polymorphism_clause.m b/compiler/polymorphism_clause.m index ae7c51f00..9cd0f7587 100644 --- a/compiler/polymorphism_clause.m +++ b/compiler/polymorphism_clause.m @@ -40,7 +40,6 @@ :- import_module check_hlds.polymorphism_goal. :- import_module check_hlds.polymorphism_type_class_info. :- import_module check_hlds.polymorphism_type_info. -:- import_module hlds.const_struct. :- import_module hlds.goal_list_util. :- import_module hlds.hlds_class. :- import_module hlds.hlds_goal. @@ -58,11 +57,8 @@ :- import_module parse_tree.set_of_var. :- import_module parse_tree.var_table. -:- import_module assoc_list. :- import_module list. :- import_module map. -:- import_module maybe. -:- import_module pair. :- import_module string. :- import_module term_context. :- import_module varset. @@ -418,7 +414,8 @@ produce_clause_existq_tvars(PredInfo, HeadVars, UnconstrainedTVars, Context = goal_info_get_context(GoalInfo), make_typeclass_info_vars(ActualExistConstraints, ExistQVarsForCall, Context, ExistTypeClassVarsMCAs, ExtraTypeClassGoals, !Info), - assoc_list.keys(ExistTypeClassVarsMCAs, ExistTypeClassVars), + ExistTypeClassVars = + list.map(var_and_maybe_csa_to_var, ExistTypeClassVarsMCAs), poly_info_get_rtti_varmaps(!.Info, RttiVarMaps0), list.foldl(rtti_reuse_typeclass_info_var, ExistTypeClassVars, RttiVarMaps0, RttiVarMaps), @@ -452,7 +449,7 @@ produce_clause_existq_tvars(PredInfo, HeadVars, UnconstrainedTVars, UnconstrainedTVars, ActualTypes), polymorphism_do_make_type_info_vars(Context, ActualTypes, TypeInfoVarsMCAs, ExtraTypeInfoGoals, !Info), - assoc_list.keys(TypeInfoVarsMCAs, TypeInfoVars), + TypeInfoVars = list.map(var_and_maybe_csa_to_var, TypeInfoVarsMCAs), make_complicated_unify_assigns(Context, TypeInfoHeadVars, TypeInfoVars, ExtraTypeInfoUnifyGoals), list.condense([[Goal0 | ExtraTypeClassGoals], ExtraTypeClassUnifyGoals, diff --git a/compiler/polymorphism_goal.m b/compiler/polymorphism_goal.m index d351c0041..1f76404e3 100644 --- a/compiler/polymorphism_goal.m +++ b/compiler/polymorphism_goal.m @@ -44,7 +44,6 @@ :- import_module check_hlds.polymorphism_lambda. :- import_module check_hlds.polymorphism_type_class_info. :- import_module check_hlds.polymorphism_type_info. -:- import_module hlds.const_struct. :- import_module hlds.from_ground_term_util. :- import_module hlds.goal_list_util. :- import_module hlds.goal_util. @@ -642,7 +641,8 @@ polymorphism_process_existq_unify_functor(CtorDefn, IsExistConstr, NumExistentialConstraints, ActualExistentialConstraints), make_typeclass_info_vars(ActualExistentialConstraints, [], Context, ExtraTypeClassVarsMCAs, ExtraTypeClassGoals, !Info), - assoc_list.keys(ExtraTypeClassVarsMCAs, ExtraTypeClassVars) + ExtraTypeClassVars = + list.map(var_and_maybe_csa_to_var, ExtraTypeClassVarsMCAs) ; IsExistConstr = is_not_exist_constr, % Assume it is a deconstruction. @@ -656,7 +656,8 @@ polymorphism_process_existq_unify_functor(CtorDefn, IsExistConstr, % quantified type variables. polymorphism_do_make_type_info_vars(Context, ActualExistentialTypes, ExtraTypeInfoVarsMCAs, ExtraTypeInfoGoals, !Info), - assoc_list.keys(ExtraTypeInfoVarsMCAs, ExtraTypeInfoVars), + ExtraTypeInfoVars = + list.map(var_and_maybe_csa_to_var, ExtraTypeInfoVarsMCAs), % The type_class_info variables go AFTER the type_info variables % (for consistency with the order for argument passing, @@ -1040,7 +1041,8 @@ polymorphism_process_plain_or_foreign_call(CalleePredId, CallArgVars0, CallContext = goal_info_get_context(CallGoalInfo0), make_typeclass_info_vars(ActualUnivConstraints, ActualExistQVars, CallContext, ExtraUnivClassVarsMCAs, ExtraUnivClassGoals, !Info), - assoc_list.keys(ExtraUnivClassVarsMCAs, ExtraUnivClassVars), + ExtraUnivClassVars = + list.map(var_and_maybe_csa_to_var, ExtraUnivClassVarsMCAs), % Make variables to hold any existentially quantified typeclass_infos % in the call, insert them into the typeclass_info map. @@ -1057,7 +1059,8 @@ polymorphism_process_plain_or_foreign_call(CalleePredId, CallArgVars0, polymorphism_do_make_type_info_vars(CallContext, ActualUnconstrainedUnivTypes, ExtraUnivTypeInfoVarsMCAs, ExtraUnivTypeInfoGoals, !Info), - assoc_list.keys(ExtraUnivTypeInfoVarsMCAs, ExtraUnivTypeInfoVars), + ExtraUnivTypeInfoVars = + list.map(var_and_maybe_csa_to_var, ExtraUnivTypeInfoVarsMCAs), % Make variables to hold typeinfos for unconstrained existential type % vars. @@ -1066,7 +1069,8 @@ polymorphism_process_plain_or_foreign_call(CalleePredId, CallArgVars0, polymorphism_do_make_type_info_vars(CallContext, ActualUnconstrainedExistTypes, ExtraExistTypeInfoVarsMCAs, ExtraExistTypeInfoGoals, !Info), - assoc_list.keys(ExtraExistTypeInfoVarsMCAs, ExtraExistTypeInfoVars), + ExtraExistTypeInfoVars = + list.map(var_and_maybe_csa_to_var, ExtraExistTypeInfoVarsMCAs), % Add up the extra vars and goals. ExtraGoals = ExtraUnivClassGoals ++ ExtraExistClassGoals diff --git a/compiler/polymorphism_info.m b/compiler/polymorphism_info.m index 9c0615b1f..4dbaac81d 100644 --- a/compiler/polymorphism_info.m +++ b/compiler/polymorphism_info.m @@ -31,12 +31,10 @@ :- import_module parse_tree.prog_data. :- import_module parse_tree.var_table. -:- import_module assoc_list. :- import_module io. :- import_module list. :- import_module map. :- import_module maybe. -:- import_module pair. %---------------------------------------------------------------------------% @@ -44,10 +42,20 @@ ---> cova_const(const_struct_arg) ; cova_var(prog_var). -:- type type_info_var_map == - map(type_ctor, type_info_var_map_entry). -:- type type_info_var_map_entry == - map(list(mer_type), pair(prog_var, maybe(const_struct_arg))). +:- type var_and_maybe_csa + ---> var_and_maybe_csa( + prog_var, + maybe(const_struct_arg) + ). + +:- func var_and_maybe_csa_to_var(var_and_maybe_csa) = prog_var. + +%--------------------% + +:- 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). @@ -64,7 +72,7 @@ tci_args_map ). :- type tci_args_map == - map(list(const_or_var_arg), pair(prog_var, maybe(const_struct_arg))). + map(list(const_or_var_arg), var_and_maybe_csa). :- type int_const_map == map(int, prog_var). @@ -116,8 +124,8 @@ constraint_proof_map::out) is det. :- pred poly_info_get_constraint_map(poly_info::in, constraint_map::out) is det. -:- pred poly_info_get_type_info_var_map(poly_info::in, - type_info_var_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_int_const_map(poly_info::in, @@ -145,7 +153,7 @@ poly_info::in, poly_info::out) is det. :- pred poly_info_set_proof_map(constraint_proof_map::in, poly_info::in, poly_info::out) is det. -:- pred poly_info_set_type_info_var_map(type_info_var_map::in, +:- 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, poly_info::in, poly_info::out) is det. @@ -167,7 +175,7 @@ :- type cache_maps ---> cache_maps( cm_snapshot_num :: int, - cm_type_info_var_map :: type_info_var_map, + 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 @@ -202,8 +210,7 @@ :- pred get_poly_const(prog_context::in, int::in, prog_var::out, list(hlds_goal)::out, poly_info::in, poly_info::out) is det. -:- pred all_are_const_struct_args( - assoc_list(prog_var, maybe(const_struct_arg))::in, +:- pred all_are_const_struct_args(list(var_and_maybe_csa)::in, list(const_struct_arg)::out) is semidet. :- pred get_inst_of_const_struct_arg(const_struct_db::in, const_struct_arg::in, @@ -242,6 +249,10 @@ %---------------------------------------------------------------------------% +var_and_maybe_csa_to_var(var_and_maybe_csa(V, _)) = V. + +%---------------------------------------------------------------------------% + :- type poly_info ---> poly_info( poly_module_info :: module_info, @@ -276,7 +287,7 @@ % The type_ctor_infos and base_typeclass_infos are in the % fourth map. The integers are in the third map. % The fourth map also caches typeclass_infos for instance ids. - poly_type_info_var_map :: type_info_var_map, + poly_type_to_type_info_map :: type_to_type_info_map, poly_typeclass_info_map :: typeclass_info_map, poly_int_const_map :: int_const_map, poly_const_struct_var_map :: const_struct_var_map, @@ -376,7 +387,7 @@ poly_info_extract(Info, Specs, !PredInfo, !ProcInfo, !:ModuleInfo) :- :- pragma inline(pred(poly_info_get_tvar_kind_map/2)). :- 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_info_var_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_const_struct_var_map/2)). :- pragma inline(pred(poly_info_get_int_const_map/2)). @@ -398,8 +409,8 @@ poly_info_get_proof_map(PI, X) :- X = PI ^ poly_proof_map. poly_info_get_constraint_map(PI, X) :- X = PI ^ poly_constraint_map. -poly_info_get_type_info_var_map(PI, X) :- - X = PI ^ poly_type_info_var_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_int_const_map(PI, X) :- @@ -422,7 +433,7 @@ poly_info_get_errors(PI, X) :- :- pragma inline(pred(poly_info_set_rtti_varmaps/3)). :- pragma inline(pred(poly_info_set_typevarset/3)). :- pragma inline(pred(poly_info_set_proof_map/3)). -:- pragma inline(pred(poly_info_set_type_info_var_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_int_const_map/3)). :- pragma inline(pred(poly_info_set_const_struct_var_map/3)). @@ -450,11 +461,11 @@ poly_info_set_proof_map(X, !PI) :- else !PI ^ poly_proof_map := X ). -poly_info_set_type_info_var_map(X, !PI) :- - ( if private_builtin.pointer_equal(X, !.PI ^ poly_type_info_var_map) then +poly_info_set_type_to_type_info_map(X, !PI) :- + ( if private_builtin.pointer_equal(X, !.PI ^ poly_type_to_type_info_map) then true else - !PI ^ poly_type_info_var_map := X + !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 @@ -503,7 +514,7 @@ poly_info_set_errors(X, !PI) :- % 5 8959328 2116731 988195 68.173% rtti_varmaps % 6 14812 3980 4058 49.515% proof_map % 7 3030093 0 0 constraint_map -% 8 811687 776589 288951 72.882% type_info_var_map +% 8 811687 776589 288951 72.882% type_to_type_info_map % 9 385071 863384 6104 99.298% typeclass_info_map % 10 385706 863310 8464 99.029% int_const_map % 11 253310 331092 41528 88.855% num_reuses @@ -614,7 +625,7 @@ poly_info_set_errors(X, !PI) :- %---------------------------------------------------------------------------% get_cache_maps_snapshot(Name, CacheMaps, !Info) :- - poly_info_get_type_info_var_map(!.Info, TypeInfoVarMap), + poly_info_get_type_to_type_info_map(!.Info, TypeInfoVarMap), poly_info_get_typeclass_info_map(!.Info, TypeClassInfoMap), poly_info_get_int_const_map(!.Info, IntConstMap), poly_info_get_const_struct_var_map(!.Info, ConstStructVarMap), @@ -649,7 +660,7 @@ set_cache_maps_snapshot(Name, CacheMaps, !Info) :- IntConstMap, ConstStructVarMap), ( if private_builtin.pointer_equal(TypeInfoVarMap, - !.Info ^ poly_type_info_var_map), + !.Info ^ poly_type_to_type_info_map), private_builtin.pointer_equal(TypeClassInfoMap, !.Info ^ poly_typeclass_info_map), private_builtin.pointer_equal(IntConstMap, @@ -660,7 +671,7 @@ set_cache_maps_snapshot(Name, CacheMaps, !Info) :- true else !:Info = ((((!.Info - ^ poly_type_info_var_map := TypeInfoVarMap) + ^ poly_type_to_type_info_map := TypeInfoVarMap) ^ poly_typeclass_info_map := TypeClassInfoMap) ^ poly_int_const_map := IntConstMap) ^ poly_const_struct_var_map := ConstStructVarMap) @@ -683,8 +694,8 @@ set_cache_maps_snapshot(Name, CacheMaps, !Info) :- io.format(Stream, "%snum_allocated vars: %d\n\n", [s(IndentStr), i(NumVars)], !IO), - io.format(Stream, "%stype_info_var_map ", [s(IndentStr)], !IO), - io.write_line(Stream, CacheMaps ^ cm_type_info_var_map, !IO), + 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 ", [s(IndentStr)], !IO), io.write_line(Stream, CacheMaps ^ cm_typeclass_info_map, !IO), @@ -698,7 +709,7 @@ set_cache_maps_snapshot(Name, CacheMaps, !Info) :- ). empty_cache_maps(!Info) :- - poly_info_set_type_info_var_map(map.init, !Info), + poly_info_set_type_to_type_info_map(map.init, !Info), poly_info_set_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). @@ -745,9 +756,9 @@ set_var_maps_snapshot(Name, VarMaps, !Info) :- io.format(Stream, "%sset_var_maps_snapshot %d %s\n", [s(IndentStr), i(SnapshotNum), s(Name)], !IO), - io.format(Stream, "%stype_info_var_map ", + io.format(Stream, "%stype_to_type_info_map ", [s(IndentStr)], !IO), - io.write_line(Stream, CacheMaps ^ cm_type_info_var_map, !IO), + io.write_line(Stream, CacheMaps ^ cm_type_to_type_info_map, !IO), io.format(Stream, "%stypeclass_info_map ", [s(IndentStr)], !IO), io.write_line(Stream, CacheMaps ^ cm_typeclass_info_map, !IO), @@ -783,7 +794,7 @@ get_poly_const(Context, IntConst, IntVar, Goals, !Info) :- all_are_const_struct_args([], []). all_are_const_struct_args([VarMCA | VarsMCAs], [ConstArg | ConstArgs]) :- - VarMCA = _Var - MCA, + VarMCA = var_and_maybe_csa(_Var, MCA), MCA = yes(ConstArg), all_are_const_struct_args(VarsMCAs, ConstArgs). diff --git a/compiler/polymorphism_type_class_info.m b/compiler/polymorphism_type_class_info.m index f6a1974d6..bcbc5021b 100644 --- a/compiler/polymorphism_type_class_info.m +++ b/compiler/polymorphism_type_class_info.m @@ -12,14 +12,11 @@ :- import_module check_hlds.polymorphism_info. :- import_module hlds. -:- import_module hlds.const_struct. :- import_module hlds.hlds_goal. :- import_module parse_tree. :- import_module parse_tree.prog_data. -:- import_module assoc_list. :- import_module list. -:- import_module maybe. % Given the list of constraints for a called predicate, create a list of % variables to hold the typeclass_info for those constraints, and create @@ -33,7 +30,7 @@ % :- pred make_typeclass_info_vars(list(prog_constraint)::in, existq_tvars::in, prog_context::in, - assoc_list(prog_var, maybe(const_struct_arg))::out, list(hlds_goal)::out, + list(var_and_maybe_csa)::out, list(hlds_goal)::out, poly_info::in, poly_info::out) is det. %---------------------------------------------------------------------------% @@ -72,6 +69,7 @@ :- implementation. :- import_module check_hlds.polymorphism_type_info. +:- import_module hlds.const_struct. :- import_module hlds.hlds_class. :- import_module hlds.hlds_module. :- import_module hlds.hlds_rtti. @@ -103,6 +101,7 @@ :- import_module int. :- import_module io. :- import_module map. +:- import_module maybe. :- import_module pair. :- import_module pretty_printer. :- import_module require. @@ -123,7 +122,7 @@ make_typeclass_info_vars(Constraints, ExistQVars, Context, % :- pred make_typeclass_info_vars_loop(existq_tvars::in, prog_context::in, list(prog_constraint)::in, list(prog_constraint)::in, - assoc_list(prog_var, maybe(const_struct_arg))::out, list(hlds_goal)::out, + list(var_and_maybe_csa)::out, list(hlds_goal)::out, poly_info::in, poly_info::out) is det. make_typeclass_info_vars_loop(_Context, _ExistQVars, _Seen, @@ -141,7 +140,7 @@ make_typeclass_info_vars_loop(ExistQVars, Context, Seen, :- pred make_typeclass_info_var(existq_tvars::in, prog_context::in, list(prog_constraint)::in, prog_constraint::in, - pair(prog_var, maybe(const_struct_arg))::out, list(hlds_goal)::out, + var_and_maybe_csa::out, list(hlds_goal)::out, poly_info::in, poly_info::out) is det. make_typeclass_info_var(ExistQVars, Context, Seen, Constraint, @@ -155,7 +154,7 @@ make_typeclass_info_var(ExistQVars, Context, Seen, Constraint, % a parameter to the pred or from an existentially quantified goal % that we have already processed. TypeClassInfoVar = OldTypeClassInfoVar, - TypeClassInfoVarMCA = TypeClassInfoVar - no, + TypeClassInfoVarMCA = var_and_maybe_csa(TypeClassInfoVar, no), Goals = [], record_constructed_typeclass_info_var("rtti_varmaps", do_not_dump_all_tables, 0, Constraint, @@ -177,7 +176,7 @@ make_typeclass_info_var(ExistQVars, Context, Seen, Constraint, rtti_reuse_typeclass_info_var(TypeClassInfoVar, RttiVarMaps0, RttiVarMaps), poly_info_set_rtti_varmaps(RttiVarMaps, !Info), - TypeClassInfoVarMCA = TypeClassInfoVar - no, + TypeClassInfoVarMCA = var_and_maybe_csa(TypeClassInfoVar, no), Goals = [], record_constructed_typeclass_info_var("for later", do_not_dump_all_tables, 0, Constraint, @@ -188,8 +187,8 @@ make_typeclass_info_var(ExistQVars, Context, Seen, Constraint, :- pred make_typeclass_info_from_proof(existq_tvars::in, prog_context::in, list(prog_constraint)::in, prog_constraint::in, constraint_proof::in, - pair(prog_var, maybe(const_struct_arg))::out, - list(hlds_goal)::out, poly_info::in, poly_info::out) is det. + var_and_maybe_csa::out, list(hlds_goal)::out, + poly_info::in, poly_info::out) is det. make_typeclass_info_from_proof(ExistQVars, Context, Seen, Constraint, Proof, TypeClassInfoVarMCA, Goals, !Info) :- @@ -213,7 +212,7 @@ make_typeclass_info_from_proof(ExistQVars, Context, Seen, :- pred get_or_make_typeclass_info_from_proof_subclass(existq_tvars::in, prog_context::in, list(prog_constraint)::in, prog_constraint::in, prog_constraint::in, - pair(prog_var, maybe(const_struct_arg))::out, list(hlds_goal)::out, + var_and_maybe_csa::out, list(hlds_goal)::out, poly_info::in, poly_info::out) is det. get_or_make_typeclass_info_from_proof_subclass(ExistQVars, Context, Seen, @@ -267,7 +266,7 @@ get_or_make_typeclass_info_from_proof_subclass(ExistQVars, Context, Seen, % Make the typeclass_info for the subclass. make_typeclass_info_var(ExistQVars, Context, Seen, SubClassConstraint, SubClassVarMCA, SubClassVarGoals, !Info), - SubClassVarMCA = SubClassVar - SubClassMCA, + SubClassVarMCA = var_and_maybe_csa(SubClassVar, SubClassMCA), % Look up the definition of the subclass. poly_info_get_module_info(!.Info, ModuleInfo), @@ -312,7 +311,8 @@ get_or_make_typeclass_info_from_proof_subclass(ExistQVars, Context, Seen, materialize_typeclass_info_var(Context, Constraint, SelectedConstNum, TypeClassInfoVar, MaybeConsId, Goals, !Info), - TypeClassInfoVarMCA = TypeClassInfoVar - yes(SelectedArg), + TypeClassInfoVarMCA = + var_and_maybe_csa(TypeClassInfoVar, yes(SelectedArg)), record_constructed_typeclass_info_var("subclass constant", do_not_dump_all_tables, -1, Constraint, TypeClassInfoVar, yes(SelectedArg), MaybeConsId, !Info) @@ -324,7 +324,7 @@ get_or_make_typeclass_info_from_proof_subclass(ExistQVars, Context, Seen, SubClassMCA = no, new_typeclass_info_var(Constraint, typeclass_info_kind, TypeClassInfoVar, _TypeClassInfoVarType, !Info), - TypeClassInfoVarMCA = TypeClassInfoVar - no, + TypeClassInfoVarMCA = var_and_maybe_csa(TypeClassInfoVar, no), get_poly_const(Context, SuperClassIndex, IndexVar, IndexGoals, !Info), % We extract the superclass typeclass_info by inserting a call @@ -345,7 +345,7 @@ get_or_make_typeclass_info_from_proof_subclass(ExistQVars, Context, Seen, :- pred get_or_make_typeclass_info_from_proof_instance(existq_tvars::in, prog_context::in, list(prog_constraint)::in, prog_constraint::in, instance_id::in, - pair(prog_var, maybe(const_struct_arg))::out, list(hlds_goal)::out, + var_and_maybe_csa::out, list(hlds_goal)::out, poly_info::in, poly_info::out) is det. get_or_make_typeclass_info_from_proof_instance(ExistQVars, Context, Seen, @@ -428,7 +428,7 @@ get_or_make_typeclass_info_from_proof_instance(ExistQVars, Context, Seen, materialize_typeclass_info_var(Context, Constraint, InstanceIdConstNum, TypeClassInfoVar, MaybeConsId, Goals, !Info), CSA = csa_const_struct(InstanceIdConstNum), - TypeClassInfoVarMCA = TypeClassInfoVar - yes(CSA), + TypeClassInfoVarMCA = var_and_maybe_csa(TypeClassInfoVar, yes(CSA)), ( Goals = [], ResultStr = "instance doubly cached result" @@ -442,7 +442,7 @@ get_or_make_typeclass_info_from_proof_instance(ExistQVars, Context, Seen, else make_typeclass_info_from_proof_instance(ExistQVars, Context, ConstInstanceId, TypeClassInfoVarMCA, BaseConsId, Goals, !Info), - TypeClassInfoVarMCA = TypeClassInfoVar - MaybeCSA, + TypeClassInfoVarMCA = var_and_maybe_csa(TypeClassInfoVar, MaybeCSA), record_constructed_typeclass_info_var("instance computed", dump_all_tables, -1, Constraint, TypeClassInfoVar, MaybeCSA, yes(BaseConsId), !Info) @@ -450,7 +450,7 @@ get_or_make_typeclass_info_from_proof_instance(ExistQVars, Context, Seen, :- pred make_typeclass_info_from_proof_instance(existq_tvars::in, prog_context::in, const_instance_id::in, - pair(prog_var, maybe(const_struct_arg))::out, cons_id::out, + var_and_maybe_csa::out, cons_id::out, list(hlds_goal)::out, poly_info::in, poly_info::out) is det. make_typeclass_info_from_proof_instance(ExistQVars, Context, @@ -568,7 +568,8 @@ make_typeclass_info_from_proof_instance(ExistQVars, Context, BaseVar, BaseConsId, ArgVarsMCAs, InitialVarMapsSnapshot, TypeClassInfoVar, TypeClassInfoMCA, BaseGoals ++ PrevGoals, Goals, !Info), - TypeClassInfoVarMCA = TypeClassInfoVar - TypeClassInfoMCA, + TypeClassInfoVarMCA = + var_and_maybe_csa(TypeClassInfoVar, TypeClassInfoMCA), % We must start the search from scratch, since construct_typeclass_info % may have reset all the cache maps. @@ -606,7 +607,7 @@ make_typeclass_info_from_proof_instance(ExistQVars, Context, ), ( if - TypeClassInfoVarMCA = _ - yes(TypeClassInfoConstArg), + TypeClassInfoVarMCA = var_and_maybe_csa(_, yes(TypeClassInfoConstArg)), TypeClassInfoConstArg = csa_const_struct(TypeClassInfoConstArgNum) then poly_info_get_const_struct_db(!.Info, ConstStructDb1), @@ -617,10 +618,10 @@ make_typeclass_info_from_proof_instance(ExistQVars, Context, true ). -:- pred make_const_or_var_arg(pair(prog_var, maybe(const_struct_arg))::in, +:- pred make_const_or_var_arg(var_and_maybe_csa::in, const_or_var_arg::out) is det. -make_const_or_var_arg(Var - MCA, ConstOrVarArg) :- +make_const_or_var_arg(var_and_maybe_csa(Var, MCA), ConstOrVarArg) :- ( MCA = no, ConstOrVarArg = cova_var(Var) @@ -633,7 +634,7 @@ make_const_or_var_arg(Var - MCA, ConstOrVarArg) :- :- pred construct_typeclass_info(prog_context::in, prog_constraint::in, prog_var::in, cons_id::in, - assoc_list(prog_var, maybe(const_struct_arg))::in, var_maps::in, + list(var_and_maybe_csa)::in, var_maps::in, prog_var::out, maybe(const_struct_arg)::out, list(hlds_goal)::in, list(hlds_goal)::out, poly_info::in, poly_info::out) is det. @@ -705,7 +706,7 @@ construct_typeclass_info(Context, Constraint, BaseVar, BaseConsId, ArgVarsMCAs, TypeClassInfoMCA = no, new_typeclass_info_var(Constraint, typeclass_info_kind, TypeClassInfoVar, _TypeClassInfoVarType, !Info), - assoc_list.keys(ArgVarsMCAs, ArgVars), + ArgVars = list.map(var_and_maybe_csa_to_var, ArgVarsMCAs), AllArgVars = [BaseVar | ArgVars], % Create the construction unification to initialize the variable. @@ -751,7 +752,7 @@ construct_typeclass_info(Context, Constraint, BaseVar, BaseConsId, ArgVarsMCAs, :- pred get_arg_superclass_vars(hlds_class_defn::in, list(mer_type)::in, constraint_proof_map::in, existq_tvars::in, prog_context::in, - assoc_list(prog_var, maybe(const_struct_arg))::out, list(hlds_goal)::out, + list(var_and_maybe_csa)::out, list(hlds_goal)::out, poly_info::in, poly_info::out) is det. get_arg_superclass_vars(ClassDefn, InstanceTypes, SuperClassProofMap, @@ -781,7 +782,7 @@ get_arg_superclass_vars(ClassDefn, InstanceTypes, SuperClassProofMap, :- pred make_typeclass_infos_for_superclasses(existq_tvars::in, prog_context::in, list(prog_constraint)::in, - assoc_list(prog_var, maybe(const_struct_arg))::out, + list(var_and_maybe_csa)::out, list(hlds_goal)::out, poly_info::in, poly_info::out) is det. make_typeclass_infos_for_superclasses(_, _, [], [], [], !Info). @@ -1160,7 +1161,7 @@ record_constructed_typeclass_info_var(Where, MaybeDumpAll, LevelStep, MaybeDumpAll = do_not_dump_all_tables ; MaybeDumpAll = dump_all_tables, - write_type_info_var_map(Stream, Info, IndentStr, !IO), + write_type_to_type_info_map(Stream, Info, IndentStr, !IO), write_typeclass_info_map(Stream, Info, IndentStr, !IO), write_constr_struct_var_map(Stream, Info, IndentStr, !IO) ), @@ -1171,25 +1172,25 @@ record_constructed_typeclass_info_var(Where, MaybeDumpAll, LevelStep, %---------------------------------------------------------------------------% -:- pred write_type_info_var_map(io.text_output_stream::in, +:- pred write_type_to_type_info_map(io.text_output_stream::in, poly_info::in, string::in, io::di, io::uo) is det. -write_type_info_var_map(Stream, Info, IndentStr, !IO) :- - poly_info_get_type_info_var_map(Info, TypeInfoVarMap), +write_type_to_type_info_map(Stream, Info, IndentStr, !IO) :- + poly_info_get_type_to_type_info_map(Info, TypeInfoVarMap), poly_info_get_typevarset(Info, TVarSet), poly_info_get_var_table(Info, VarTable), - io.format(Stream, "%stype_info_var_map\n", [s(IndentStr)], !IO), + io.format(Stream, "%stype_to_type_info_map\n", [s(IndentStr)], !IO), NextIndentStr = IndentStr ++ " ", map.foldl( - write_type_info_var_map_entry(Stream, TVarSet, VarTable, + write_type_ctor_to_type_info_map(Stream, TVarSet, VarTable, NextIndentStr), TypeInfoVarMap, !IO). -:- pred write_type_info_var_map_entry(io.text_output_stream::in, tvarset::in, - var_table::in, string::in, type_ctor::in, type_info_var_map_entry::in, +:- 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_info_var_map_entry(Stream, TVarSet, VarTable, IndentStr, +write_type_ctor_to_type_info_map(Stream, TVarSet, VarTable, IndentStr, TypeCtor, TypeInfoVarMapEntry, !IO) :- TypeCtor = type_ctor(TypeCtorSymName, TypeCtorArity), TypeCtorName = unqualify_name(TypeCtorSymName), @@ -1197,21 +1198,19 @@ write_type_info_var_map_entry(Stream, TVarSet, VarTable, IndentStr, [s(IndentStr), s(TypeCtorName), i(TypeCtorArity)], !IO), NextIndentStr = IndentStr ++ " ", map.foldl( - write_type_info_var_map_entry_entry(Stream, TVarSet, VarTable, + write_type_ctor_to_type_info_map_entry(Stream, TVarSet, VarTable, NextIndentStr), TypeInfoVarMapEntry, !IO). -:- pred write_type_info_var_map_entry_entry(io.text_output_stream::in, +:- pred write_type_ctor_to_type_info_map_entry(io.text_output_stream::in, tvarset::in, var_table::in, string::in, - list(mer_type)::in, pair(prog_var, maybe(const_struct_arg))::in, - io::di, io::uo) is det. + list(mer_type)::in, var_and_maybe_csa::in, io::di, io::uo) is det. -write_type_info_var_map_entry_entry(Stream, TVarSet, VarTable, IndentStr, +write_type_ctor_to_type_info_map_entry(Stream, TVarSet, VarTable, IndentStr, Types, VarMaybeCSA, !IO) :- TypeStrs = list.map(trace_type_to_string(TVarSet), Types), TypesStr = string.join_list(", ", TypeStrs), - VarCSAStr = - var_and_maybe_const_struct_arg_to_string(VarTable, VarMaybeCSA), + VarCSAStr = var_and_maybe_csa_to_string(VarTable, VarMaybeCSA), io.format(Stream, "%s[%s] -> %s\n", [s(IndentStr), s(TypesStr), s(VarCSAStr)], !IO). @@ -1265,7 +1264,7 @@ write_typeclass_info_class_map_entry(Stream, TVarSet, VarTable, IndentStr, :- pred write_typeclass_info_cva_map_entry(io.text_output_stream::in, tvarset::in, var_table::in, string::in, - list(const_or_var_arg)::in, pair(prog_var, maybe(const_struct_arg))::in, + list(const_or_var_arg)::in, var_and_maybe_csa::in, io::di, io::uo) is det. write_typeclass_info_cva_map_entry(Stream, TVarSet, VarTable, IndentStr, @@ -1273,8 +1272,7 @@ write_typeclass_info_cva_map_entry(Stream, TVarSet, VarTable, IndentStr, COVAStrs = list.map(const_or_var_arg_to_string(TVarSet, VarTable), ConstOrVarArgs), COVAsStr = string.join_list(", ", COVAStrs), - VarMaybeCSAStr = - var_and_maybe_const_struct_arg_to_string(VarTable, VarMaybeCSA), + VarMaybeCSAStr = var_and_maybe_csa_to_string(VarTable, VarMaybeCSA), io.format(Stream, "%s%s ->\n%s %s\n", [s(IndentStr), s(COVAsStr), s(IndentStr), s(VarMaybeCSAStr)], !IO). @@ -1307,10 +1305,10 @@ write_constr_struct_var_map_entry(Stream, TVarSet, VarTable, IndentStr, %---------------------------------------------------------------------------% -:- func var_and_maybe_const_struct_arg_to_string(var_table, - pair(prog_var, maybe(const_struct_arg))) = string. +:- func var_and_maybe_csa_to_string(var_table, var_and_maybe_csa) = string. -var_and_maybe_const_struct_arg_to_string(VarTable, Var - MaybeCSA) = Str :- +var_and_maybe_csa_to_string(VarTable, var_and_maybe_csa(Var, MaybeCSA)) + = Str :- VarStr = mercury_var_to_string(VarTable, print_name_and_num, Var), string.format("%s - %s", [s(VarStr), s(string(MaybeCSA))], Str). diff --git a/compiler/polymorphism_type_info.m b/compiler/polymorphism_type_info.m index 6d84eae32..94609dde0 100644 --- a/compiler/polymorphism_type_info.m +++ b/compiler/polymorphism_type_info.m @@ -89,7 +89,6 @@ :- import_module check_hlds.polymorphism_info. :- import_module hlds. -:- import_module hlds.const_struct. :- import_module hlds.hlds_goal. :- import_module hlds.hlds_module. :- import_module hlds.hlds_pred. @@ -99,9 +98,7 @@ :- import_module parse_tree.prog_data. :- import_module parse_tree.var_table. -:- import_module assoc_list. :- import_module list. -:- import_module maybe. %---------------------------------------------------------------------------% @@ -127,8 +124,7 @@ % into static data. % :- pred polymorphism_do_make_type_info_vars(prog_context::in, - list(mer_type)::in, - assoc_list(prog_var, maybe(const_struct_arg))::out, list(hlds_goal)::out, + list(mer_type)::in, list(var_and_maybe_csa)::out, list(hlds_goal)::out, poly_info::in, poly_info::out) is det. %---------------------% @@ -246,6 +242,7 @@ :- implementation. +:- import_module hlds.const_struct. :- import_module hlds.instmap. :- import_module hlds.make_goal. :- import_module hlds.pred_table. @@ -263,6 +260,7 @@ :- import_module int. :- import_module map. +:- import_module maybe. :- import_module pair. :- import_module require. :- import_module set. @@ -273,15 +271,15 @@ polymorphism_make_type_info_var(Type, Context, Var, ExtraGoals, !Info) :- polymorphism_do_make_type_info_var(Type, Context, VarMCA, ExtraGoals, !Info), - VarMCA = Var - _. + VarMCA = var_and_maybe_csa(Var, _). polymorphism_make_type_info_vars(Types, Context, Vars, ExtraGoals, !Info) :- polymorphism_do_make_type_info_vars(Types, Context, VarsMCAs, ExtraGoals, !Info), - assoc_list.keys(VarsMCAs, Vars). + Vars = list.map(var_and_maybe_csa_to_var, VarsMCAs). :- pred polymorphism_do_make_type_info_var(term.context::in, mer_type::in, - pair(prog_var, maybe(const_struct_arg))::out, list(hlds_goal)::out, + var_and_maybe_csa::out, list(hlds_goal)::out, poly_info::in, poly_info::out) is det. polymorphism_do_make_type_info_var(Context, Type, VarMCA, ExtraGoals, !Info) :- @@ -319,7 +317,7 @@ polymorphism_do_make_type_info_var(Context, Type, VarMCA, ExtraGoals, !Info) :- poly_get_type_info_locn(TypeVar, TypeInfoLocn, !Info), get_type_info_from_locn(TypeVar, TypeInfoLocn, Context, Var, ExtraGoals, !Info), - VarMCA = Var - no + VarMCA = var_and_maybe_csa(Var, no) ) ). @@ -359,12 +357,12 @@ polymorphism_make_type_info_vars_mi(Types, Context, Vars, ExtraGoals, :- pred polymorphism_make_type_info(prog_context::in, mer_type::in, type_ctor::in, list(mer_type)::in, - type_ctor_is_var_arity::in, pair(prog_var, maybe(const_struct_arg))::out, + type_ctor_is_var_arity::in, var_and_maybe_csa::out, list(hlds_goal)::out, poly_info::in, poly_info::out) is det. polymorphism_make_type_info(Context, Type, TypeCtor, TypeArgs, TypeCtorIsVarArity, TypeInfoVarMCA, ExtraGoals, !Info) :- - poly_info_get_type_info_var_map(!.Info, TypeInfoVarMap0), + poly_info_get_type_to_type_info_map(!.Info, TypeInfoVarMap0), ( if map.search(TypeInfoVarMap0, TypeCtor, TypeCtorVarMap0), map.search(TypeCtorVarMap0, TypeArgs, OldTypeInfoVarMCA) @@ -377,10 +375,10 @@ polymorphism_make_type_info(Context, Type, TypeCtor, TypeArgs, polymorphism_construct_type_info(Context, Type, TypeCtor, TypeArgs, TypeCtorIsVarArity, TypeInfoVar, TypeInfoConstArg, ExtraGoals, !Info), - TypeInfoVarMCA = TypeInfoVar - TypeInfoConstArg, - % We have to get the type_info_var_map again since the call just above - % could have added relevant new entries to it. - poly_info_get_type_info_var_map(!.Info, TypeInfoVarMap1), + TypeInfoVarMCA = var_and_maybe_csa(TypeInfoVar, TypeInfoConstArg), + % We have to get the type_to_type_info_map again, since + % the call just above could have added relevant new entries to it. + poly_info_get_type_to_type_info_map(!.Info, TypeInfoVarMap1), ( if map.search(TypeInfoVarMap1, TypeCtor, TypeCtorVarMap1) then map.det_insert(TypeArgs, TypeInfoVarMCA, TypeCtorVarMap1, TypeCtorVarMap), @@ -391,7 +389,7 @@ polymorphism_make_type_info(Context, Type, TypeCtor, TypeArgs, map.det_insert(TypeCtor, TypeCtorVarMap, TypeInfoVarMap1, TypeInfoVarMap) ), - poly_info_set_type_info_var_map(TypeInfoVarMap, !Info) + poly_info_set_type_to_type_info_map(TypeInfoVarMap, !Info) ). :- pred polymorphism_construct_type_info(prog_context::in, @@ -484,7 +482,7 @@ polymorphism_construct_type_info(Context, Type, TypeCtor, ArgTypes, :- pred polymorphism_maybe_construct_second_type_info_cell(prog_context::in, mer_type::in, type_ctor::in, type_ctor_is_var_arity::in, prog_var::in, cons_id::in, list(hlds_goal)::in, - assoc_list(prog_var, maybe(const_struct_arg))::in, list(hlds_goal)::in, + list(var_and_maybe_csa)::in, list(hlds_goal)::in, var_maps::in, prog_var::out, maybe(const_struct_arg)::out, list(hlds_goal)::out, poly_info::in, poly_info::out) is det. :- pragma inline(pred(polymorphism_maybe_construct_second_type_info_cell/15)). @@ -569,7 +567,7 @@ polymorphism_maybe_construct_second_type_info_cell(Context, Type, TypeCtor, :- pred polymorphism_construct_second_type_info_cell(prog_context::in ,mer_type::in, type_ctor::in, maybe_need_arity::in, prog_var::in, cons_id::in, list(hlds_goal)::in, - assoc_list(prog_var, maybe(const_struct_arg))::in, list(hlds_goal)::in, + list(var_and_maybe_csa)::in, list(hlds_goal)::in, var_maps::in, prog_var::out, maybe(const_struct_arg)::out, list(hlds_goal)::out, poly_info::in, poly_info::out) is det. :- pragma inline(pred(polymorphism_construct_second_type_info_cell/15)). @@ -661,7 +659,8 @@ polymorphism_construct_second_type_info_cell(Context, Type, TypeCtor, ExtraGoals = [TypeInfoGoal] else new_type_info_var(Type, type_info, TypeInfoVar, !Info), - assoc_list.keys(ArgTypeInfoVarsMCAs, ArgTypeInfoVars), + ArgTypeInfoVars = + list.map(var_and_maybe_csa_to_var, ArgTypeInfoVarsMCAs), ( NeedTypeCtorArity = need_arity_in_second_ti_cell, list.length(ArgTypeInfoVars, ActualArity),