[m-rev.] diff: clean up polymorphism.m
Zoltan Somogyi
zs at cs.mu.OZ.AU
Tue Oct 21 10:45:30 AEST 2003
This diff makes polymorphism.m easier to read and to maintain (as well as
5% shorter), but contains no changes in algorithms whatsoever.
compiler/polymorphism.m:
Bring this module into line with our current coding standards.
Use predmode declarations, field accesses and state variable syntax
when appropriate.
Reorder arguments of predicates where necessary for the use of state
variable syntax, and where this improves readability.
Replace old-style lambdas with new-style lambdas or with partially
applied named procedures.
Replace references to c_code with references to foreign_procs.
Standardize indentation.
compiler/modecheck_unify.m:
compiler/simplify.m:
Conform to the new argument orders of predicates exported by
polymorphism.m.
Zoltan.
cvs diff: Diffing .
Index: modecheck_unify.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/modecheck_unify.m,v
retrieving revision 1.62
diff -u -b -r1.62 modecheck_unify.m
--- modecheck_unify.m 20 Oct 2003 07:29:09 -0000 1.62
+++ modecheck_unify.m 20 Oct 2003 17:27:09 -0000
@@ -174,8 +174,8 @@
convert_pred_to_lambda_goal(Purity, EvalMethod,
X0, PredId, ProcId, ArgVars0, PredArgTypes,
UnifyContext, GoalInfo0, Context,
- ModuleInfo0, VarSet0, VarTypes0,
- Functor0, VarSet, VarTypes),
+ ModuleInfo0, Functor0,
+ VarSet0, VarSet, VarTypes0, VarTypes),
mode_info_set_varset(VarSet, ModeInfo0, ModeInfo1),
mode_info_set_var_types(VarTypes, ModeInfo1, ModeInfo2),
%
@@ -771,7 +771,7 @@
Goal0 = unify(X, Y, Mode, Unification0, FinalUnifyContext)
->
polymorphism__unification_typeinfos(Type, TypeInfoVarMap,
- Unification0, GoalInfo2, Unification, GoalInfo),
+ Unification0, Unification, GoalInfo2, GoalInfo),
Goal = unify(X, Y, Mode, Unification, FinalUnifyContext)
;
error("modecheck_unify__create_var_var_unification")
Index: polymorphism.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/polymorphism.m,v
retrieving revision 1.242
diff -u -b -r1.242 polymorphism.m
--- polymorphism.m 20 Oct 2003 07:29:10 -0000 1.242
+++ polymorphism.m 21 Oct 2003 00:39:22 -0000
@@ -10,7 +10,7 @@
% This module is a pass over the HLDS.
% It does a syntactic transformation to implement polymorphism, including
% typeclasses, by passing extra `type_info' and `typeclass_info' arguments.
-% These arguments are structures that contain, amoung other things,
+% These arguments are structures that contain, amongst other things,
% higher-order predicate terms for the polymorphic procedures or methods.
% See notes/type_class_transformation.html for a description of the
@@ -171,9 +171,8 @@
% Run the polymorphism pass over the whole HLDS.
-:- pred polymorphism__process_module(module_info, module_info,
- io__state, io__state).
-:- mode polymorphism__process_module(in, out, di, uo) is det.
+:- pred polymorphism__process_module(module_info::in, module_info::out,
+ io__state::di, io__state::uo) is det.
% Run the polymorphism pass over a single pred.
% This is used to transform clauses introduced by unify_proc.m
@@ -188,31 +187,30 @@
% which require type_infos or typeclass_infos to be added to
% the argument list.
-:- pred polymorphism__process_generated_pred(pred_id,
- module_info, module_info).
-:- mode polymorphism__process_generated_pred(in, in, out) is det.
+:- pred polymorphism__process_generated_pred(pred_id::in,
+ module_info::in, module_info::out) is det.
% Add the type_info variables for a complicated unification to
% the appropriate fields in the unification and the goal_info.
-:- pred polymorphism__unification_typeinfos(type, map(tvar, type_info_locn),
- unification, hlds_goal_info, unification, hlds_goal_info).
-:- mode polymorphism__unification_typeinfos(in, in, in, in, out, out) is det.
+:- pred polymorphism__unification_typeinfos((type)::in,
+ map(tvar, type_info_locn)::in, unification::in, unification::out,
+ hlds_goal_info::in, hlds_goal_info::out) is det.
% Given a list of types, create a list of variables to hold the type_info
% for those types, and create a list of goals to initialize those type_info
% variables to the appropriate type_info structures for the types.
% Update the varset and vartypes accordingly.
-:- pred polymorphism__make_type_info_vars(list(type),
- term__context, list(prog_var), list(hlds_goal), poly_info, poly_info).
-:- mode polymorphism__make_type_info_vars(in, in, out, out, in, out) is det.
+:- pred polymorphism__make_type_info_vars(list(type)::in,
+ term__context::in, list(prog_var)::out, list(hlds_goal)::out,
+ poly_info::in, poly_info::out) is det.
% Likewise, but for a single type.
-:- pred polymorphism__make_type_info_var(type,
- term__context, prog_var, list(hlds_goal), poly_info, poly_info).
-:- mode polymorphism__make_type_info_var(in, in, out, out, in, out) is det.
+:- pred polymorphism__make_type_info_var((type)::in,
+ term__context::in, prog_var::out, list(hlds_goal)::out,
+ poly_info::in, poly_info::out) is det.
% polymorphism__gen_extract_type_info(TypeVar, TypeClassInfoVar, Index,
% ModuleInfo, Goals, TypeInfoVar, ...):
@@ -227,77 +225,69 @@
% is a fresh variable holding the type_info, and Goals,
% which is the code generated to initialize TypeInfoVar.
%
-:- pred polymorphism__gen_extract_type_info(tvar, prog_var, int, module_info,
- list(hlds_goal), prog_var, prog_varset, map(prog_var, type),
- prog_varset, map(prog_var, type)).
-:- mode polymorphism__gen_extract_type_info(in, in, in, in, out, out,
- in, in, out, out) is det.
+:- pred polymorphism__gen_extract_type_info(tvar::in, prog_var::in, int::in,
+ module_info::in, list(hlds_goal)::out, prog_var::out,
+ prog_varset::in, prog_varset::out,
+ map(prog_var, type)::in, map(prog_var, type)::out) is det.
:- type poly_info.
% 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, pred_info, proc_info, poly_info).
-:- mode create_poly_info(in, in, in, 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.
-:- pred poly_info_extract(poly_info, pred_info, pred_info,
- proc_info, proc_info, module_info).
-:- mode poly_info_extract(in, in, out, in, out, out) is det.
+:- pred poly_info_extract(poly_info::in, pred_info::in, pred_info::out,
+ proc_info::in, proc_info::out, module_info::out) is det.
% Build the type describing the typeclass_info for the
% given class_constraint.
-:- pred polymorphism__build_typeclass_info_type(class_constraint, (type)).
-:- mode polymorphism__build_typeclass_info_type(in, out) is det.
+:- pred polymorphism__build_typeclass_info_type(class_constraint::in,
+ (type)::out) is det.
% From the type of a typeclass_info variable find the class_constraint
% about which the variable carries information, failing if the
% type is not a valid typeclass_info type.
-:- pred polymorphism__typeclass_info_class_constraint((type),
- class_constraint).
-:- mode polymorphism__typeclass_info_class_constraint(in, out) is semidet.
+:- pred polymorphism__typeclass_info_class_constraint((type)::in,
+ class_constraint::out) is semidet.
% From the type of a type_info variable find the type about which
% the type_info or type_ctor_info carries information, failing if the
% type is not a valid type_info or type_ctor_info type.
-:- pred polymorphism__type_info_or_ctor_type((type), (type)).
-:- mode polymorphism__type_info_or_ctor_type(in, out) is semidet.
+:- pred polymorphism__type_info_or_ctor_type((type)::in, (type)::out)
+ is semidet.
% Construct the type of the type_info for the given type.
-:- pred polymorphism__build_type_info_type((type), (type)).
-:- mode polymorphism__build_type_info_type(in, out) is det.
+:- pred polymorphism__build_type_info_type((type)::in, (type)::out) is det.
% Succeed if the predicate is one of the predicates defined in
% library/private_builtin.m to extract type_infos or typeclass_infos
% from typeclass_infos.
-:- pred polymorphism__is_typeclass_info_manipulator(module_info,
- pred_id, typeclass_info_manipulator).
-:- mode polymorphism__is_typeclass_info_manipulator(in, in, out) is semidet.
+:- pred polymorphism__is_typeclass_info_manipulator(module_info::in,
+ pred_id::in, typeclass_info_manipulator::out) is semidet.
:- type typeclass_info_manipulator
---> type_info_from_typeclass_info
; superclass_from_typeclass_info
- ; instance_constraint_from_typeclass_info
- .
+ ; instance_constraint_from_typeclass_info.
% Look up the pred_id and proc_id for a type specific
% unification/comparison/index predicate.
-:- pred polymorphism__get_special_proc(type, special_pred_id,
- module_info, sym_name, pred_id, proc_id).
-:- mode polymorphism__get_special_proc(in, in, in, out, out, out) is semidet.
+:- pred polymorphism__get_special_proc((type)::in, special_pred_id::in,
+ module_info::in, sym_name::out, pred_id::out, proc_id::out) is semidet.
% convert a higher-order pred term to a lambda goal
-:- pred convert_pred_to_lambda_goal(purity, lambda_eval_method,
- prog_var, pred_id, proc_id, list(prog_var), list(type),
- unify_context, hlds_goal_info, context,
- module_info, prog_varset, map(prog_var, type),
- unify_rhs, prog_varset, map(prog_var, type)).
-:- mode convert_pred_to_lambda_goal(in, in, in, in, in, in, in, in,
- in, in, in, in, in, out, out, out) is det.
+:- pred convert_pred_to_lambda_goal(purity::in, lambda_eval_method::in,
+ prog_var::in, pred_id::in, proc_id::in, list(prog_var)::in,
+ list(type)::in, unify_context::in, hlds_goal_info::in, context::in,
+ module_info::in, unify_rhs::out,
+ prog_varset::in, prog_varset::out,
+ map(prog_var, type)::in, map(prog_var, type)::out) is det.
% init_type_info_var(Type, ArgVars, TypeInfoVar, TypeInfoGoal,
- % VarSet0, VarSet, VarTypes0, VarTypes) :-
+ % !VarSet, !VarTypes) :-
%
% Create the unification the constructs the second cell of a type_info
% for Type. ArgVars should contain the arguments of this unification.
@@ -319,7 +309,7 @@
% init_const_type_ctor_info_var(Type, TypeCtor,
% TypeCtorInfoVar, TypeCtorInfoGoal, ModuleInfo,
- % VarSet0, VarSet, VarTypes0, VarTypes):
+ % !VarSet, !VarTypes):
%
% Create the unification (returned as TypeCtorInfoGoal) that binds a
% new variable (returned as TypeCtorInfoVar) to the type_ctor_info
@@ -384,34 +374,24 @@
% the argtypes of the called predicates, and so we need to make
% sure we don't muck them up before we've finished the first pass.
-polymorphism__process_module(ModuleInfo0, ModuleInfo, IO0, IO) :-
- module_info_preds(ModuleInfo0, Preds0),
+polymorphism__process_module(!ModuleInfo, !IO) :-
+ module_info_preds(!.ModuleInfo, Preds0),
map__keys(Preds0, PredIds0),
- polymorphism__process_preds(PredIds0, ModuleInfo0, ModuleInfo1,
- IO0, IO),
- module_info_preds(ModuleInfo1, Preds1),
+ list__foldl2(polymorphism__maybe_process_pred, PredIds0,
+ !ModuleInfo, !IO),
+ module_info_preds(!.ModuleInfo, Preds1),
map__keys(Preds1, PredIds1),
+ list__foldl(polymorphism__fixup_pred, PredIds1, !ModuleInfo),
+ polymorphism__expand_class_method_bodies(!ModuleInfo).
- polymorphism__fixup_preds(PredIds1, ModuleInfo1, ModuleInfo2),
- polymorphism__expand_class_method_bodies(ModuleInfo2, ModuleInfo).
-
-:- pred polymorphism__process_preds(list(pred_id), module_info, module_info,
- io__state, io__state).
-:- mode polymorphism__process_preds(in, in, out, di, uo) is det.
-
-polymorphism__process_preds([], ModuleInfo, ModuleInfo) --> [].
-polymorphism__process_preds([PredId | PredIds], ModuleInfo0, ModuleInfo) -->
- polymorphism__maybe_process_pred(PredId, ModuleInfo0, ModuleInfo1),
- polymorphism__process_preds(PredIds, ModuleInfo1, ModuleInfo).
-
-:- pred polymorphism__maybe_process_pred(pred_id, module_info, module_info,
- io__state, io__state).
-:- mode polymorphism__maybe_process_pred(in, in, out, di, uo) is det.
+:- pred polymorphism__maybe_process_pred(pred_id::in,
+ module_info::in, module_info::out, io__state::di, io__state::uo)
+ is det.
-polymorphism__maybe_process_pred(PredId, ModuleInfo0, ModuleInfo) -->
- { module_info_pred_info(ModuleInfo0, PredId, PredInfo) },
+polymorphism__maybe_process_pred(PredId, !ModuleInfo, !IO) :-
+ module_info_pred_info(!.ModuleInfo, PredId, PredInfo),
+ (
(
- {
% Leave Aditi aggregates alone, since
% calls to them must be monomorphic. This avoids
% unnecessarily creating type_infos in Aditi code,
@@ -428,29 +408,20 @@
pred_info_name(PredInfo, PredName),
pred_info_arity(PredInfo, PredArity),
no_type_info_builtin(PredModule, PredName, PredArity)
- }
+ )
->
% just copy the clauses to the proc_infos
- { copy_module_clauses_to_procs([PredId],
- ModuleInfo0, ModuleInfo) }
+ copy_module_clauses_to_procs([PredId], !ModuleInfo)
;
- polymorphism__process_pred(PredId, ModuleInfo0, ModuleInfo)
+ polymorphism__process_pred(PredId, !ModuleInfo, !IO)
).
%---------------------------------------------------------------------------%
-:- pred polymorphism__fixup_preds(list(pred_id), module_info, module_info).
-:- mode polymorphism__fixup_preds(in, in, out) is det.
-
-polymorphism__fixup_preds(PredIds, ModuleInfo0, ModuleInfo) :-
- list__foldl(polymorphism__fixup_pred,
- PredIds, ModuleInfo0, ModuleInfo).
-
-:- pred polymorphism__fixup_pred(pred_id, module_info, module_info).
-:- mode polymorphism__fixup_pred(in, in, out) is det.
-
-polymorphism__fixup_pred(PredId, ModuleInfo0, ModuleInfo) :-
+:- pred polymorphism__fixup_pred(pred_id::in,
+ module_info::in, module_info::out) is det.
+polymorphism__fixup_pred(PredId, !ModuleInfo) :-
%
% Recompute the arg types by finding the headvars and
% the var->type mapping (from the clauses_info) and
@@ -460,7 +431,7 @@
% we would stuff up the arg types for unification predicates for
% equivalence types.
%
- module_info_preds(ModuleInfo0, PredTable0),
+ module_info_preds(!.ModuleInfo, PredTable0),
map__lookup(PredTable0, PredId, PredInfo0),
pred_info_clauses_info(PredInfo0, ClausesInfo0),
clauses_info_vartypes(ClausesInfo0, VarTypes0),
@@ -526,39 +497,38 @@
),
map__det_update(PredTable0, PredId, PredInfo, PredTable),
- module_info_set_preds(ModuleInfo0, PredTable, ModuleInfo).
+ module_info_set_preds(!.ModuleInfo, PredTable, !:ModuleInfo).
%---------------------------------------------------------------------------%
-:- pred polymorphism__process_pred(pred_id, module_info, module_info,
- io__state, io__state).
-:- mode polymorphism__process_pred(in, in, out, di, uo) is det.
+:- pred polymorphism__process_pred(pred_id::in,
+ module_info::in, module_info::out, io__state::di, io__state::uo)
+ is det.
-polymorphism__process_pred(PredId, ModuleInfo0, ModuleInfo) -->
+polymorphism__process_pred(PredId, !ModuleInfo, !IO) :-
write_pred_progress_message("% Transforming polymorphism for ",
- PredId, ModuleInfo0),
- { polymorphism__process_pred(PredId, ModuleInfo0, ModuleInfo) }.
+ PredId, !.ModuleInfo, !IO),
+ polymorphism__process_pred(PredId, !ModuleInfo).
-polymorphism__process_generated_pred(PredId, ModuleInfo0, ModuleInfo) :-
- polymorphism__process_pred(PredId, ModuleInfo0, ModuleInfo1),
- polymorphism__fixup_pred(PredId, ModuleInfo1, ModuleInfo).
+polymorphism__process_generated_pred(PredId, !ModuleInfo) :-
+ polymorphism__process_pred(PredId, !ModuleInfo),
+ polymorphism__fixup_pred(PredId, !ModuleInfo).
-:- pred polymorphism__process_pred(pred_id, module_info, module_info).
-:- mode polymorphism__process_pred(in, in, out) is det.
+:- pred polymorphism__process_pred(pred_id::in,
+ module_info::in, module_info::out) is det.
-polymorphism__process_pred(PredId, ModuleInfo0, ModuleInfo) :-
- module_info_pred_info(ModuleInfo0, PredId, PredInfo0),
+polymorphism__process_pred(PredId, !ModuleInfo) :-
+ module_info_pred_info(!.ModuleInfo, PredId, PredInfo0),
%
% run the polymorphism pass over the clauses_info,
% updating the headvars, goals, varsets, types, etc.,
% and computing some information in the poly_info.
%
pred_info_clauses_info(PredInfo0, ClausesInfo0),
- polymorphism__process_clause_info(
- ClausesInfo0, PredInfo0, ModuleInfo0,
- ClausesInfo, PolyInfo, ExtraArgModes),
- poly_info_get_module_info(PolyInfo, ModuleInfo1),
- poly_info_get_typevarset(PolyInfo, TypeVarSet),
+ polymorphism__process_clause_info(PredInfo0, !.ModuleInfo,
+ ClausesInfo0, ClausesInfo, Info, ExtraArgModes),
+ poly_info_get_module_info(Info, !:ModuleInfo),
+ poly_info_get_typevarset(Info, TypeVarSet),
pred_info_set_typevarset(PredInfo0, TypeVarSet, PredInfo1),
pred_info_set_clauses_info(PredInfo1, ClausesInfo, PredInfo2),
@@ -569,113 +539,103 @@
%
pred_info_procids(PredInfo2, ProcIds),
pred_info_procedures(PredInfo2, Procs0),
- polymorphism__process_procs(ProcIds, Procs0, PredInfo2, ClausesInfo,
- ExtraArgModes, Procs),
+ list__foldl(polymorphism__process_proc_in_table(PredInfo2, ClausesInfo,
+ ExtraArgModes), ProcIds, Procs0, Procs),
pred_info_set_procedures(PredInfo2, Procs, PredInfo),
- module_info_set_pred_info(ModuleInfo1, PredId, PredInfo,
- ModuleInfo).
+ module_info_set_pred_info(!.ModuleInfo, PredId, PredInfo,
+ !:ModuleInfo).
-:- pred polymorphism__process_clause_info(clauses_info, pred_info, module_info,
- clauses_info, poly_info, list(mode)).
-:- mode polymorphism__process_clause_info(in, in, in, out, out, out) is det.
+:- pred polymorphism__process_clause_info(pred_info::in, module_info::in,
+ clauses_info::in, clauses_info::out, poly_info::out, list(mode)::out)
+ is det.
-polymorphism__process_clause_info(ClausesInfo0, PredInfo0, ModuleInfo0,
- ClausesInfo, PolyInfo, ExtraArgModes) :-
+polymorphism__process_clause_info(PredInfo0, ModuleInfo0,
+ ClausesInfo0, ClausesInfo, Info, ExtraArgModes) :-
- init_poly_info(ModuleInfo0, PredInfo0, ClausesInfo0, PolyInfo0),
+ init_poly_info(ModuleInfo0, PredInfo0, ClausesInfo0, Info0),
clauses_info_headvars(ClausesInfo0, HeadVars0),
- polymorphism__setup_headvars(PredInfo0, HeadVars0,
- HeadVars, ExtraArgModes, _HeadTypeVars,
- UnconstrainedTVars,
+ polymorphism__setup_headvars(PredInfo0, HeadVars0, HeadVars,
+ ExtraArgModes, _HeadTypeVars, UnconstrainedTVars,
ExtraTypeInfoHeadVars, ExistTypeClassInfoHeadVars,
- PolyInfo0, PolyInfo1),
+ Info0, Info1),
clauses_info_clauses(ClausesInfo0, Clauses0),
- list__map_foldl(polymorphism__process_clause(PredInfo0,
+ list__map_foldl(
+ polymorphism__process_clause(PredInfo0,
HeadVars0, HeadVars, UnconstrainedTVars,
ExtraTypeInfoHeadVars,
ExistTypeClassInfoHeadVars),
- Clauses0, Clauses, PolyInfo1, PolyInfo),
+ Clauses0, Clauses, Info1, Info),
%
% set the new values of the fields in clauses_info
%
- poly_info_get_varset(PolyInfo, VarSet),
- poly_info_get_var_types(PolyInfo, VarTypes),
- poly_info_get_type_info_map(PolyInfo, TypeInfoMap),
- poly_info_get_typeclass_info_map(PolyInfo, TypeClassInfoMap),
+ poly_info_get_varset(Info, VarSet),
+ poly_info_get_var_types(Info, VarTypes),
+ poly_info_get_type_info_map(Info, TypeInfoMap),
+ poly_info_get_typeclass_info_map(Info, TypeClassInfoMap),
clauses_info_explicit_vartypes(ClausesInfo0, ExplicitVarTypes),
map__init(TVarNameMap), % This is only used while adding the clauses.
ClausesInfo = clauses_info(VarSet, ExplicitVarTypes, TVarNameMap,
- VarTypes, HeadVars, Clauses,
- TypeInfoMap, TypeClassInfoMap,
+ VarTypes, HeadVars, Clauses, TypeInfoMap, TypeClassInfoMap,
ClausesInfo0 ^ have_foreign_clauses).
-:- pred polymorphism__process_clause(pred_info, list(prog_var), list(prog_var),
- list(tvar), list(prog_var), list(prog_var),
- clause, clause, poly_info, poly_info).
-:- mode polymorphism__process_clause(in, in, in, in, in, in,
- in, out, in, out) is det.
+:- pred polymorphism__process_clause(pred_info::in, list(prog_var)::in,
+ list(prog_var)::in, list(tvar)::in,
+ list(prog_var)::in, list(prog_var)::in,
+ clause::in, clause::out, poly_info::in, poly_info::out) is det.
polymorphism__process_clause(PredInfo0, OldHeadVars, NewHeadVars,
- UnconstrainedTVars,
- ExtraTypeInfoHeadVars, ExistTypeClassInfoHeadVars,
- Clause0, Clause) -->
- (
- { pred_info_is_imported(PredInfo0) }
- ->
- { Clause = Clause0 }
+ UnconstrainedTVars, ExtraTypeInfoHeadVars,
+ ExistTypeClassInfoHeadVars, !Clause, !Info) :-
+ ( pred_info_is_imported(PredInfo0) ->
+ true
;
- { Clause0 = clause(ProcIds, Goal0, Lang, Context) },
+ !.Clause = clause(ProcIds, Goal0, Lang, Context),
%
% process any polymorphic calls inside the goal
%
- polymorphism__process_goal(Goal0, Goal1),
+ polymorphism__process_goal(Goal0, Goal1, !Info),
%
% generate code to construct the type-class-infos
% and type-infos for existentially quantified type vars
%
- polymorphism__produce_existq_tvars(
- PredInfo0, OldHeadVars,
+ polymorphism__produce_existq_tvars(PredInfo0, OldHeadVars,
UnconstrainedTVars, ExtraTypeInfoHeadVars,
- ExistTypeClassInfoHeadVars,
- Goal1, Goal2),
+ ExistTypeClassInfoHeadVars, Goal1, Goal2, !Info),
- { pred_info_get_exist_quant_tvars(PredInfo0, ExistQVars) },
+ pred_info_get_exist_quant_tvars(PredInfo0, ExistQVars),
polymorphism__fixup_quantification(NewHeadVars, ExistQVars,
- Goal2, Goal),
- { Clause = clause(ProcIds, Goal, Lang, Context) }
+ Goal2, Goal, !Info),
+ !:Clause = clause(ProcIds, Goal, Lang, Context)
).
-:- pred polymorphism__process_procs(list(proc_id), proc_table,
- pred_info, clauses_info, list(mode), proc_table).
-:- mode polymorphism__process_procs(in, in, in, in, in, out) is det.
-
-polymorphism__process_procs([], Procs, _, _, _, Procs).
-polymorphism__process_procs([ProcId | ProcIds], Procs0, PredInfo, ClausesInfo,
- ExtraArgModes, Procs) :-
- map__lookup(Procs0, ProcId, ProcInfo0),
- polymorphism__process_proc(ProcId, ProcInfo0, PredInfo, ClausesInfo,
- ExtraArgModes, ProcInfo),
- map__det_update(Procs0, ProcId, ProcInfo, Procs1),
- polymorphism__process_procs(ProcIds, Procs1, PredInfo, ClausesInfo,
- ExtraArgModes, Procs).
-
-:- pred polymorphism__process_proc(proc_id, proc_info, pred_info, clauses_info,
- list(mode), proc_info).
-:- mode polymorphism__process_proc(in, in, in, in, in, out) is det.
+:- pred polymorphism__process_proc_in_table(pred_info::in, clauses_info::in,
+ list(mode)::in, proc_id::in, proc_table::in, proc_table::out) is det.
+
+polymorphism__process_proc_in_table(PredInfo, ClausesInfo, ExtraArgModes,
+ ProcId, !ProcTable) :-
+ map__lookup(!.ProcTable, ProcId, ProcInfo0),
+ polymorphism__process_proc(PredInfo, ClausesInfo, ExtraArgModes,
+ ProcId, ProcInfo0, ProcInfo),
+ map__det_update(!.ProcTable, ProcId, ProcInfo, !:ProcTable).
+
+:- pred polymorphism__process_proc(pred_info::in, clauses_info::in,
+ list(mode)::in, proc_id::in, proc_info::in, proc_info::out) is det.
-polymorphism__process_proc(ProcId, ProcInfo0, PredInfo, ClausesInfo,
- ExtraArgModes, ProcInfo) :-
+polymorphism__process_proc(PredInfo, ClausesInfo, ExtraArgModes, ProcId,
+ !ProcInfo) :-
%
% copy all the information from the clauses_info into the proc_info
%
(
- ( pred_info_is_imported(PredInfo)
- ; pred_info_is_pseudo_imported(PredInfo),
+ (
+ pred_info_is_imported(PredInfo)
+ ;
+ pred_info_is_pseudo_imported(PredInfo),
hlds_pred__in_in_unification_proc_id(ProcId)
)
->
@@ -690,37 +650,36 @@
clauses_info_type_info_varmap(ClausesInfo, TypeInfoVarMap),
clauses_info_varset(ClausesInfo, VarSet),
clauses_info_vartypes(ClausesInfo, VarTypes),
- proc_info_set_headvars(ProcInfo0, HeadVars, ProcInfo1),
- proc_info_set_typeclass_info_varmap(ProcInfo1,
- TypeClassInfoVarMap, ProcInfo2),
- proc_info_set_typeinfo_varmap(ProcInfo2,
- TypeInfoVarMap, ProcInfo3),
- proc_info_set_varset(ProcInfo3, VarSet, ProcInfo4),
- proc_info_set_vartypes(ProcInfo4, VarTypes, ProcInfo5)
+ proc_info_set_headvars(!.ProcInfo, HeadVars, !:ProcInfo),
+ proc_info_set_typeclass_info_varmap(!.ProcInfo,
+ TypeClassInfoVarMap, !:ProcInfo),
+ proc_info_set_typeinfo_varmap(!.ProcInfo,
+ TypeInfoVarMap, !:ProcInfo),
+ proc_info_set_varset(!.ProcInfo, VarSet, !:ProcInfo),
+ proc_info_set_vartypes(!.ProcInfo, VarTypes, !:ProcInfo)
;
- copy_clauses_to_proc(ProcId, ClausesInfo, ProcInfo0, ProcInfo5)
+ copy_clauses_to_proc(ProcId, ClausesInfo, !ProcInfo)
),
%
% add the ExtraArgModes to the proc_info argmodes
%
- proc_info_argmodes(ProcInfo5, ArgModes1),
+ proc_info_argmodes(!.ProcInfo, ArgModes1),
list__append(ExtraArgModes, ArgModes1, ArgModes),
- proc_info_set_argmodes(ProcInfo5, ArgModes, ProcInfo).
+ proc_info_set_argmodes(!.ProcInfo, ArgModes, !:ProcInfo).
% XXX the following code ought to be rewritten to handle
% existential/universal type_infos and type_class_infos
% in a more consistent manner.
-:- pred polymorphism__setup_headvars(pred_info, list(prog_var),
- list(prog_var), list(mode), list(tvar), list(tvar),
- list(prog_var), list(prog_var), poly_info, poly_info).
-:- mode polymorphism__setup_headvars(in, in, out, out, out, out, out, out,
- in, out) is det.
+:- pred polymorphism__setup_headvars(pred_info::in, list(prog_var)::in,
+ list(prog_var)::out, list(mode)::out, list(tvar)::out, list(tvar)::out,
+ list(prog_var)::out, list(prog_var)::out,
+ poly_info::in, poly_info::out) is det.
polymorphism__setup_headvars(PredInfo, HeadVars0, HeadVars, ExtraArgModes,
HeadTypeVars, UnconstrainedTVars, ExtraHeadTypeInfoVars,
- ExistHeadTypeClassInfoVars, PolyInfo0, PolyInfo) :-
+ ExistHeadTypeClassInfoVars, !Info) :-
pred_info_get_maybe_instance_method_constraints(PredInfo,
MaybeInstanceMethodConstraints),
(
@@ -736,7 +695,7 @@
InstanceUnconstrainedTypeInfoVars, HeadVars0, HeadVars,
ExtraArgModes, HeadTypeVars, UnconstrainedTVars,
ExtraHeadTypeInfoVars, ExistHeadTypeClassInfoVars,
- PolyInfo0, PolyInfo)
+ !Info)
;
MaybeInstanceMethodConstraints =
yes(InstanceMethodConstraints),
@@ -744,7 +703,7 @@
InstanceMethodConstraints, HeadVars0, HeadVars,
ExtraArgModes, HeadTypeVars, UnconstrainedTVars,
ExtraHeadTypeInfoVars, ExistHeadTypeClassInfoVars,
- PolyInfo0, PolyInfo)
+ !Info)
).
%
@@ -753,17 +712,16 @@
% typeclass-info and pastes them onto the front of
% the argument list. We need to match that order here.
%
-:- pred polymorphism__setup_headvars_instance_method(pred_info,
- instance_method_constraints, list(prog_var), list(prog_var),
- list(mode), list(tvar), list(tvar), list(prog_var),
- list(prog_var), poly_info, poly_info).
-:- mode polymorphism__setup_headvars_instance_method(in, in, in, out, out, out,
- out, out, out, in, out) is det.
+:- pred polymorphism__setup_headvars_instance_method(pred_info::in,
+ instance_method_constraints::in,
+ list(prog_var)::in, list(prog_var)::out,
+ list(mode)::out, list(tvar)::out, list(tvar)::out, list(prog_var)::out,
+ list(prog_var)::out, poly_info::in, poly_info::out) is det.
polymorphism__setup_headvars_instance_method(PredInfo,
InstanceMethodConstraints, HeadVars0, HeadVars, ExtraArgModes,
HeadTypeVars, UnconstrainedTVars, ExtraHeadTypeInfoVars,
- ExistHeadTypeClassInfoVars, PolyInfo0, PolyInfo) :-
+ ExistHeadTypeClassInfoVars, !Info) :-
InstanceMethodConstraints = instance_method_constraints(_,
InstanceTypes, InstanceConstraints, ClassContext),
@@ -773,14 +731,13 @@
UnconstrainedInstanceTVars),
pred_info_arg_types(PredInfo, ArgTypeVarSet, _, _),
polymorphism__make_head_vars(UnconstrainedInstanceTVars,
- ArgTypeVarSet, UnconstrainedInstanceTypeInfoVars,
- PolyInfo0, PolyInfo1),
+ ArgTypeVarSet, UnconstrainedInstanceTypeInfoVars, !Info),
polymorphism__make_typeclass_info_head_vars(InstanceConstraints,
- InstanceHeadTypeClassInfoVars, PolyInfo1, PolyInfo2),
- poly_info_get_typeclass_info_map(PolyInfo2, TCVarMap0),
+ InstanceHeadTypeClassInfoVars, !Info),
+ poly_info_get_typeclass_info_map(!.Info, TCVarMap0),
map__det_insert_from_corresponding_lists(TCVarMap0,
InstanceConstraints, InstanceHeadTypeClassInfoVars, TCVarMap),
- poly_info_set_typeclass_info_map(TCVarMap, PolyInfo2, PolyInfo3),
+ poly_info_set_typeclass_info_map(TCVarMap, !Info),
list__append(UnconstrainedInstanceTypeInfoVars,
InstanceHeadTypeClassInfoVars, ExtraHeadVars0),
in_mode(InMode),
@@ -790,22 +747,20 @@
UnconstrainedInstanceTypeInfoVars, HeadVars0, HeadVars,
ExtraArgModes, HeadTypeVars,
UnconstrainedTVars, ExtraHeadTypeInfoVars,
- ExistHeadTypeClassInfoVars, PolyInfo3, PolyInfo).
+ ExistHeadTypeClassInfoVars, !Info).
-:- pred polymorphism__setup_headvars_2(pred_info, class_constraints,
- list(prog_var), list(mode), list(tvar), list(prog_var),
- list(prog_var), list(prog_var), list(mode), list(tvar),
- list(tvar), list(prog_var), list(prog_var),
- poly_info, poly_info).
-:- mode polymorphism__setup_headvars_2(in, in, in, in, in, in, in,
- out, out, out, out, out, out, in, out) is det.
+:- pred polymorphism__setup_headvars_2(pred_info::in, class_constraints::in,
+ list(prog_var)::in, list(mode)::in, list(tvar)::in,
+ list(prog_var)::in, list(prog_var)::in, list(prog_var)::out,
+ list(mode)::out, list(tvar)::out, list(tvar)::out,
+ list(prog_var)::out, list(prog_var)::out,
+ poly_info::in, poly_info::out) is det.
polymorphism__setup_headvars_2(PredInfo, ClassContext, ExtraHeadVars0,
ExtraArgModes0, UnconstrainedInstanceTVars,
UnconstrainedInstanceTypeInfoVars, HeadVars0,
HeadVars, ExtraArgModes, HeadTypeVars, AllUnconstrainedTVars,
- AllExtraHeadTypeInfoVars, ExistHeadTypeClassInfoVars,
- PolyInfo0, PolyInfo) :-
+ AllExtraHeadTypeInfoVars, ExistHeadTypeClassInfoVars, !Info) :-
%
% grab the appropriate fields from the pred_info
%
@@ -824,13 +779,13 @@
% with the location of the type infos for them.
ClassContext = constraints(UnivConstraints, ExistConstraints),
polymorphism__make_typeclass_info_head_vars(ExistConstraints,
- ExistHeadTypeClassInfoVars, PolyInfo0, PolyInfo1),
- poly_info_get_type_info_map(PolyInfo1, TypeInfoMap1),
+ ExistHeadTypeClassInfoVars, !Info),
+ poly_info_get_type_info_map(!.Info, TypeInfoMap1),
map__keys(TypeInfoMap1, ExistConstrainedTVars),
polymorphism__make_typeclass_info_head_vars(UnivConstraints,
- UnivHeadTypeClassInfoVars, PolyInfo1, PolyInfo2),
- poly_info_get_type_info_map(PolyInfo2, TypeInfoMap3),
+ UnivHeadTypeClassInfoVars, !Info),
+ poly_info_get_type_info_map(!.Info, TypeInfoMap3),
map__keys(TypeInfoMap3, UnivConstrainedTVars),
list__append(UnivHeadTypeClassInfoVars, ExistHeadTypeClassInfoVars,
@@ -852,20 +807,18 @@
% optimize common case
UnconstrainedUnivTVars = UnconstrainedTVars,
UnconstrainedExistTVars = [],
- ExistHeadTypeInfoVars = [],
- PolyInfo3 = PolyInfo2
+ ExistHeadTypeInfoVars = []
;
list__delete_elems(UnconstrainedTVars, ExistQVars,
UnconstrainedUnivTVars),
list__delete_elems(UnconstrainedTVars, UnconstrainedUnivTVars,
UnconstrainedExistTVars),
polymorphism__make_head_vars(UnconstrainedExistTVars,
- ArgTypeVarSet, ExistHeadTypeInfoVars,
- PolyInfo2, PolyInfo3)
+ ArgTypeVarSet, ExistHeadTypeInfoVars, !Info)
),
polymorphism__make_head_vars(UnconstrainedUnivTVars,
- ArgTypeVarSet, UnivHeadTypeInfoVars, PolyInfo3, PolyInfo4),
+ ArgTypeVarSet, UnivHeadTypeInfoVars, !Info),
list__append(UnivHeadTypeInfoVars, ExistHeadTypeInfoVars,
ExtraHeadTypeInfoVars),
@@ -923,15 +876,13 @@
UnconstrainedInstanceTVars, UnconstrainedInstanceTypeLocns,
TypeInfoMap6),
- poly_info_set_type_info_map(TypeInfoMap6, PolyInfo4, PolyInfo5),
+ poly_info_set_type_info_map(TypeInfoMap6, !Info),
% Make a map of the locations of the typeclass_infos
- poly_info_get_typeclass_info_map(PolyInfo5, TypeClassInfoMap0),
+ poly_info_get_typeclass_info_map(!.Info, TypeClassInfoMap0),
map__set_from_corresponding_lists(TypeClassInfoMap0,
UnivConstraints, UnivHeadTypeClassInfoVars, TypeClassInfoMap),
- poly_info_set_typeclass_info_map(TypeClassInfoMap,
- PolyInfo5, PolyInfo).
-
+ poly_info_set_typeclass_info_map(TypeClassInfoMap, !Info).
% XXX the following code ought to be rewritten to handle
% existential/universal type_infos and type_class_infos
@@ -941,16 +892,14 @@
% generate code to produce the values of type_infos and typeclass_infos
% for existentially quantified type variables in the head
%
-:- pred polymorphism__produce_existq_tvars(pred_info, list(prog_var),
- list(tvar), list(prog_var), list(prog_var),
- hlds_goal, hlds_goal, poly_info, poly_info).
-:- mode polymorphism__produce_existq_tvars(in, in, in, in, in, in, out,
- in, out) is det.
-
-polymorphism__produce_existq_tvars(PredInfo, HeadVars0,
- UnconstrainedTVars, TypeInfoHeadVars,
- ExistTypeClassInfoHeadVars, Goal0, Goal, Info0, Info) :-
- poly_info_get_var_types(Info0, VarTypes0),
+:- pred polymorphism__produce_existq_tvars(pred_info::in, list(prog_var)::in,
+ list(tvar)::in, list(prog_var)::in, list(prog_var)::in,
+ hlds_goal::in, hlds_goal::out, poly_info::in, poly_info::out) is det.
+
+polymorphism__produce_existq_tvars(PredInfo, HeadVars0, UnconstrainedTVars,
+ TypeInfoHeadVars, ExistTypeClassInfoHeadVars, Goal0, Goal,
+ !Info) :-
+ poly_info_get_var_types(!.Info, VarTypes0),
pred_info_arg_types(PredInfo, ArgTypes),
pred_info_get_class_context(PredInfo, ClassContext),
@@ -983,12 +932,11 @@
goal_info_get_context(GoalInfo, Context),
apply_rec_subst_to_constraint_list(TypeSubst, ExistConstraints0,
ExistConstraints),
- polymorphism__make_typeclass_info_vars(
- ExistConstraints, ExistQVarsForCall, Context,
- ExistTypeClassVars, ExtraTypeClassGoals,
- Info0, Info1),
+ polymorphism__make_typeclass_info_vars(ExistConstraints,
+ ExistQVarsForCall, Context, ExistTypeClassVars,
+ ExtraTypeClassGoals, !Info),
polymorphism__update_typeclass_infos(ExistConstraints,
- ExistTypeClassVars, Info1, Info2),
+ ExistTypeClassVars, !Info),
polymorphism__assign_var_list(
ExistTypeClassInfoHeadVars, ExistTypeClassVars,
ExtraTypeClassUnifyGoals),
@@ -1003,7 +951,7 @@
term__apply_substitution_to_list(UnconstrainedTVarTerms,
TypeSubst, ActualTypes),
polymorphism__make_type_info_vars(ActualTypes, Context,
- TypeInfoVars, ExtraTypeInfoGoals, Info2, Info),
+ TypeInfoVars, ExtraTypeInfoGoals, !Info),
polymorphism__assign_var_list(TypeInfoHeadVars, TypeInfoVars,
ExtraTypeInfoUnifyGoals),
list__condense([[Goal0],
@@ -1012,164 +960,161 @@
GoalList),
conj_list_to_goal(GoalList, GoalInfo, Goal).
-:- pred polymorphism__assign_var_list(list(prog_var), list(prog_var),
- list(hlds_goal)).
-:- mode polymorphism__assign_var_list(in, in, out) is det.
+:- pred polymorphism__assign_var_list(list(prog_var)::in, list(prog_var)::in,
+ list(hlds_goal)::out) is det.
-polymorphism__assign_var_list([], [_|_], _) :-
+polymorphism__assign_var_list([], [_ | _], _) :-
error("unify_proc__assign_var_list: length mismatch").
-polymorphism__assign_var_list([_|_], [], _) :-
+polymorphism__assign_var_list([_ | _], [], _) :-
error("unify_proc__assign_var_list: length mismatch").
polymorphism__assign_var_list([], [], []).
polymorphism__assign_var_list([Var1 | Vars1], [Var2 | Vars2], [Goal | Goals]) :-
polymorphism__assign_var(Var1, Var2, Goal),
polymorphism__assign_var_list(Vars1, Vars2, Goals).
-:- pred polymorphism__assign_var(prog_var, prog_var, hlds_goal).
-:- mode polymorphism__assign_var(in, in, out) is det.
+:- pred polymorphism__assign_var(prog_var::in, prog_var::in, hlds_goal::out)
+ is det.
polymorphism__assign_var(Var1, Var2, Goal) :-
( Var1 = Var2 ->
true_goal(Goal)
;
- polymorphism__assign_var_2(Var1, Var2, Goal)
- ).
-
-:- pred polymorphism__assign_var_2(prog_var, prog_var, hlds_goal).
-:- mode polymorphism__assign_var_2(in, in, out) is det.
-
-polymorphism__assign_var_2(Var1, Var2, Goal) :-
term__context_init(Context),
create_atomic_unification(Var1, var(Var2), Context, explicit,
- [], Goal).
+ [], Goal)
+ ).
%-----------------------------------------------------------------------------%
-:- pred polymorphism__process_goal(hlds_goal, hlds_goal,
- poly_info, poly_info).
-:- mode polymorphism__process_goal(in, out, in, out) is det.
-
-polymorphism__process_goal(Goal0 - GoalInfo0, Goal) -->
- polymorphism__process_goal_expr(Goal0, GoalInfo0, Goal).
-
-:- pred polymorphism__process_goal_expr(hlds_goal_expr, hlds_goal_info,
- hlds_goal, poly_info, poly_info).
-:- mode polymorphism__process_goal_expr(in, in, out, in, out) is det.
+:- pred polymorphism__process_goal(hlds_goal::in, hlds_goal::out,
+ poly_info::in, poly_info::out) is det.
+
+polymorphism__process_goal(Goal0 - GoalInfo0, Goal, !Info) :-
+ polymorphism__process_goal_expr(Goal0, GoalInfo0, Goal, !Info).
+
+:- pred polymorphism__process_goal_expr(hlds_goal_expr::in, hlds_goal_info::in,
+ hlds_goal::out, poly_info::in, poly_info::out) is det.
% We don't need to add type-infos for higher-order calls,
% since the type-infos are added when the closures are
% constructed, not when they are called.
-polymorphism__process_goal_expr(GoalExpr, GoalInfo, GoalExpr - GoalInfo) -->
- { GoalExpr = generic_call(_, _, _, _) }.
+polymorphism__process_goal_expr(GoalExpr, GoalInfo, Goal, !Info) :-
+ GoalExpr = generic_call(_, _, _, _),
+ Goal = GoalExpr - GoalInfo.
-polymorphism__process_goal_expr(Goal0, GoalInfo, Goal) -->
- { Goal0 = call(PredId, ProcId, ArgVars0, Builtin,
- UnifyContext, Name) },
+polymorphism__process_goal_expr(Goal0, GoalInfo, Goal, !Info) :-
+ Goal0 = call(PredId, ProcId, ArgVars0, Builtin, UnifyContext, Name),
polymorphism__process_call(PredId, ArgVars0, GoalInfo,
- ArgVars, _ExtraVars, CallGoalInfo, ExtraGoals),
+ ArgVars, _ExtraVars, CallGoalInfo, ExtraGoals, !Info),
+ CallExpr = call(PredId, ProcId, ArgVars, Builtin, UnifyContext, Name),
+ Call = CallExpr - CallGoalInfo,
+ list__append(ExtraGoals, [Call], GoalList),
+ conj_list_to_goal(GoalList, GoalInfo, Goal).
- { Call = call(PredId, ProcId, ArgVars, Builtin, UnifyContext, Name)
- - CallGoalInfo },
- { list__append(ExtraGoals, [Call], GoalList) },
- { conj_list_to_goal(GoalList, GoalInfo, Goal) }.
-
-polymorphism__process_goal_expr(Goal0, GoalInfo, Goal) -->
- { Goal0 = foreign_proc(Attributes, PredId, ProcId,
- ArgVars0, ArgInfo0, OrigArgTypes0, PragmaCode0) },
+polymorphism__process_goal_expr(Goal0, GoalInfo, Goal, !Info) :-
+ Goal0 = foreign_proc(Attributes, PredId, ProcId,
+ ArgVars0, ArgInfo0, OrigArgTypes0, PragmaCode0),
polymorphism__process_call(PredId, ArgVars0, GoalInfo,
- ArgVars, ExtraVars, CallGoalInfo, ExtraGoals),
+ ArgVars, ExtraVars, CallGoalInfo, ExtraGoals, !Info),
%
% insert the type_info vars into the arg-name map,
- % so that the c_code can refer to the type_info variable
+ % so that the foreign_proc can refer to the type_info variable
% for type T as `TypeInfo_for_T'.
%
- =(Info0),
- { poly_info_get_module_info(Info0, ModuleInfo) },
- { module_info_pred_info(ModuleInfo, PredId, PredInfo) },
-
- { pred_info_module(PredInfo, PredModule) },
- { pred_info_name(PredInfo, PredName) },
- { pred_info_arity(PredInfo, PredArity) },
+ poly_info_get_module_info(!.Info, ModuleInfo),
+ module_info_pred_info(ModuleInfo, PredId, PredInfo),
+ pred_info_module(PredInfo, PredModule),
+ pred_info_name(PredInfo, PredName),
+ pred_info_arity(PredInfo, PredArity),
- ( { no_type_info_builtin(PredModule, PredName, PredArity) } ->
- { Goal = Goal0 - GoalInfo }
+ ( no_type_info_builtin(PredModule, PredName, PredArity) ->
+ Goal = Goal0 - GoalInfo
;
- { list__length(ExtraVars, NumExtraVars) },
- { polymorphism__process_c_code(PredInfo, NumExtraVars,
+ list__length(ExtraVars, NumExtraVars),
+ polymorphism__process_foreign_proc(PredInfo, NumExtraVars,
PragmaCode0, OrigArgTypes0, OrigArgTypes,
- ArgInfo0, ArgInfo) },
+ ArgInfo0, ArgInfo),
%
% Add the type info arguments to the list of variables
% to call for a pragma import.
%
(
- { PragmaCode0 = import(Name, HandleReturn,
- Variables0, MaybeContext) }
+ PragmaCode0 = import(Name, HandleReturn,
+ Variables0, MaybeContext)
->
(
- { list__remove_suffix(ArgInfo, ArgInfo0,
- TypeVarArgInfos) }
+ list__remove_suffix(ArgInfo, ArgInfo0,
+ TypeVarArgInfos)
->
- { Variables = type_info_vars(ModuleInfo,
- TypeVarArgInfos, Variables0) }
+ Variables = type_info_vars(ModuleInfo,
+ TypeVarArgInfos, Variables0)
;
- { error("polymorphism__process_goal_expr") }
+ error("polymorphism__process_goal_expr")
),
- { PragmaCode = import(Name, HandleReturn,
- Variables, MaybeContext) }
+ PragmaCode = import(Name, HandleReturn,
+ Variables, MaybeContext)
;
- { PragmaCode = PragmaCode0 }
+ PragmaCode = PragmaCode0
),
%
% plug it all back together
%
- { Call = foreign_proc(Attributes, PredId,
- ProcId, ArgVars, ArgInfo, OrigArgTypes, PragmaCode) -
- CallGoalInfo },
- { list__append(ExtraGoals, [Call], GoalList) },
- { conj_list_to_goal(GoalList, GoalInfo, Goal) }
+ CallExpr = foreign_proc(Attributes, PredId, ProcId, ArgVars,
+ ArgInfo, OrigArgTypes, PragmaCode),
+ Call = CallExpr - CallGoalInfo,
+ list__append(ExtraGoals, [Call], GoalList),
+ conj_list_to_goal(GoalList, GoalInfo, Goal)
).
-polymorphism__process_goal_expr(unify(XVar, Y, Mode, Unification, UnifyContext),
- GoalInfo, Goal) -->
+polymorphism__process_goal_expr(GoalExpr, GoalInfo, Goal, !Info) :-
+ GoalExpr = unify(XVar, Y, Mode, Unification, UnifyContext),
polymorphism__process_unify(XVar, Y, Mode, Unification, UnifyContext,
- GoalInfo, Goal).
+ GoalInfo, Goal, !Info).
% the rest of the clauses just process goals recursively
-polymorphism__process_goal_expr(conj(Goals0), GoalInfo,
- conj(Goals) - GoalInfo) -->
- polymorphism__process_goal_list(Goals0, Goals).
-polymorphism__process_goal_expr(par_conj(Goals0), GoalInfo,
- par_conj(Goals) - GoalInfo) -->
- polymorphism__process_goal_list(Goals0, Goals).
-polymorphism__process_goal_expr(disj(Goals0), GoalInfo,
- disj(Goals) - GoalInfo) -->
- polymorphism__process_goal_list(Goals0, Goals).
-polymorphism__process_goal_expr(not(Goal0), GoalInfo, not(Goal) - GoalInfo) -->
- polymorphism__process_goal(Goal0, Goal).
-polymorphism__process_goal_expr(switch(Var, CanFail, Cases0), GoalInfo,
- switch(Var, CanFail, Cases) - GoalInfo) -->
- polymorphism__process_case_list(Cases0, Cases).
-polymorphism__process_goal_expr(some(Vars, CanRemove, Goal0), GoalInfo,
- some(Vars, CanRemove, Goal) - GoalInfo) -->
- polymorphism__process_goal(Goal0, Goal).
-polymorphism__process_goal_expr(if_then_else(Vars, A0, B0, C0), GoalInfo,
- if_then_else(Vars, A, B, C) - GoalInfo) -->
- polymorphism__process_goal(A0, A),
- polymorphism__process_goal(B0, B),
- polymorphism__process_goal(C0, C).
-polymorphism__process_goal_expr(shorthand(_), _, _) -->
+polymorphism__process_goal_expr(GoalExpr, GoalInfo, Goal, !Info) :-
+ GoalExpr = conj(Goals0),
+ polymorphism__process_goal_list(Goals0, Goals, !Info),
+ Goal = conj(Goals) - GoalInfo.
+polymorphism__process_goal_expr(GoalExpr, GoalInfo, Goal, !Info) :-
+ GoalExpr = par_conj(Goals0),
+ polymorphism__process_goal_list(Goals0, Goals, !Info),
+ Goal = par_conj(Goals) - GoalInfo.
+polymorphism__process_goal_expr(GoalExpr, GoalInfo, Goal, !Info) :-
+ GoalExpr = disj(Goals0),
+ polymorphism__process_goal_list(Goals0, Goals, !Info),
+ Goal = disj(Goals) - GoalInfo.
+polymorphism__process_goal_expr(GoalExpr, GoalInfo, Goal, !Info) :-
+ GoalExpr = not(SubGoal0),
+ polymorphism__process_goal(SubGoal0, SubGoal, !Info),
+ Goal = not(SubGoal) - GoalInfo.
+polymorphism__process_goal_expr(GoalExpr, GoalInfo, Goal, !Info) :-
+ GoalExpr = switch(Var, CanFail, Cases0),
+ polymorphism__process_case_list(Cases0, Cases, !Info),
+ Goal = switch(Var, CanFail, Cases) - GoalInfo.
+polymorphism__process_goal_expr(GoalExpr, GoalInfo, Goal, !Info) :-
+ GoalExpr = some(Vars, CanRemove, SubGoal0),
+ polymorphism__process_goal(SubGoal0, SubGoal, !Info),
+ Goal = some(Vars, CanRemove, SubGoal) - GoalInfo.
+polymorphism__process_goal_expr(GoalExpr, GoalInfo, Goal, !Info) :-
+ GoalExpr = if_then_else(Vars, Cond0, Then0, Else0),
+ polymorphism__process_goal(Cond0, Cond, !Info),
+ polymorphism__process_goal(Then0, Then, !Info),
+ polymorphism__process_goal(Else0, Else, !Info),
+ Goal = if_then_else(Vars, Cond, Then, Else) - GoalInfo.
+polymorphism__process_goal_expr(GoalExpr, _GoalInfo, _Goal, !Info) :-
% these should have been expanded out by now
- { error("polymorphism__process_goal_expr: unexpected shorthand") }.
+ GoalExpr = shorthand(_),
+ error("polymorphism__process_goal_expr: unexpected shorthand").
- % type_info_vars prepends a comma seperated list of variables
+ % type_info_vars prepends a comma separated list of variables
% onto a string of variables.
- % It places an & at the start of the variable name if variable
+ % It places an & at the start of the variable name if the variable
% is an output variable.
:- func type_info_vars(module_info, list(maybe(pair(string, mode))),
string) = string.
@@ -1192,17 +1137,15 @@
String = String0
).
-:- pred polymorphism__process_unify(prog_var, unify_rhs,
- unify_mode, unification, unify_context, hlds_goal_info,
- hlds_goal, poly_info, poly_info).
-:- mode polymorphism__process_unify(in, in, in, in, in, in, out,
- in, out) is det.
+:- pred polymorphism__process_unify(prog_var::in, unify_rhs::in,
+ unify_mode::in, unification::in, unify_context::in, hlds_goal_info::in,
+ hlds_goal::out, poly_info::in, poly_info::out) is det.
polymorphism__process_unify(XVar, Y, Mode, Unification0, UnifyContext,
- GoalInfo0, Goal) -->
+ GoalInfo0, Goal, !Info) :-
% switch on Y
(
- { Y = var(_YVar) },
+ Y = var(_YVar),
%
% var-var unifications (simple_test, assign,
% or complicated_unify) are basically left unchanged.
@@ -1218,39 +1161,37 @@
% variables in a field in the unification, which
% quantification.m uses when requantifying things.
%
- =(Info0),
- { poly_info_get_var_types(Info0, VarTypes) },
- { map__lookup(VarTypes, XVar, Type) },
+ poly_info_get_var_types(!.Info, VarTypes),
+ map__lookup(VarTypes, XVar, Type),
polymorphism__unification_typeinfos(Type,
- Unification0, GoalInfo0, Unification, GoalInfo),
- { Goal = unify(XVar, Y, Mode, Unification,
- UnifyContext) - GoalInfo }
+ Unification0, Unification, GoalInfo0, GoalInfo, !Info),
+ Goal = unify(XVar, Y, Mode, Unification, UnifyContext)
+ - GoalInfo
;
- { Y = functor(ConsId, _, Args) },
+ Y = functor(ConsId, _, Args),
polymorphism__process_unify_functor(XVar, ConsId, Args, Mode,
- Unification0, UnifyContext, GoalInfo0, Goal)
+ Unification0, UnifyContext, GoalInfo0, Goal, !Info)
;
- { Y = lambda_goal(Purity, PredOrFunc, EvalMethod, FixModes,
- ArgVars0, LambdaVars, Modes, Det, LambdaGoal0) },
+ Y = lambda_goal(Purity, PredOrFunc, EvalMethod, FixModes,
+ ArgVars0, LambdaVars, Modes, Det, LambdaGoal0),
%
% for lambda expressions, we must recursively traverse the
% lambda goal
%
- polymorphism__process_goal(LambdaGoal0, LambdaGoal1),
+ polymorphism__process_goal(LambdaGoal0, LambdaGoal1, !Info),
% Currently we don't allow lambda goals to be
% existentially typed
- { ExistQVars = [] },
- polymorphism__fixup_lambda_quantification(LambdaGoal1,
- ArgVars0, LambdaVars, ExistQVars,
- LambdaGoal, NonLocalTypeInfos),
- { set__to_sorted_list(NonLocalTypeInfos,
- NonLocalTypeInfosList) },
- { list__append(NonLocalTypeInfosList, ArgVars0, ArgVars) },
- { Y1 = lambda_goal(Purity, PredOrFunc, EvalMethod, FixModes,
- ArgVars, LambdaVars, Modes, Det, LambdaGoal) },
- { goal_info_get_nonlocals(GoalInfo0, NonLocals0) },
- { set__union(NonLocals0, NonLocalTypeInfos, NonLocals) },
- { goal_info_set_nonlocals(GoalInfo0, NonLocals, GoalInfo) },
+ ExistQVars = [],
+ polymorphism__fixup_lambda_quantification(ArgVars0, LambdaVars,
+ ExistQVars, LambdaGoal1, LambdaGoal, NonLocalTypeInfos,
+ !Info),
+ set__to_sorted_list(NonLocalTypeInfos, NonLocalTypeInfosList),
+ list__append(NonLocalTypeInfosList, ArgVars0, ArgVars),
+ Y1 = lambda_goal(Purity, PredOrFunc, EvalMethod, FixModes,
+ ArgVars, LambdaVars, Modes, Det, LambdaGoal),
+ goal_info_get_nonlocals(GoalInfo0, NonLocals0),
+ set__union(NonLocals0, NonLocalTypeInfos, NonLocals),
+ goal_info_set_nonlocals(GoalInfo0, NonLocals, GoalInfo),
%
% Complicated (in-in) argument unifications are impossible
@@ -1258,49 +1199,45 @@
% adding the type-infos that would be required for such
% unifications.
%
- { Goal = unify(XVar, Y1, Mode, Unification0, UnifyContext)
- - GoalInfo }
+ Goal = unify(XVar, Y1, Mode, Unification0, UnifyContext)
+ - GoalInfo
).
-:- pred polymorphism__unification_typeinfos(type, unification,
- hlds_goal_info, unification, hlds_goal_info, poly_info, poly_info).
-:- mode polymorphism__unification_typeinfos(in, in, in,
- out, out, in, out) is det.
+:- pred polymorphism__unification_typeinfos((type)::in,
+ unification::in, unification::out,
+ hlds_goal_info::in, hlds_goal_info::out,
+ poly_info::in, poly_info::out) is det.
-polymorphism__unification_typeinfos(Type, Unification0, GoalInfo0,
- Unification, GoalInfo, Info0, Info) :-
+polymorphism__unification_typeinfos(Type, !Unification, !GoalInfo, !Info) :-
%
% Compute the type_info/type_class_info variables that would be
% used if this unification ends up being a complicated_unify.
%
type_util__vars(Type, TypeVars),
- list__map_foldl(get_type_info_locn, TypeVars, TypeInfoLocns,
- Info0, Info),
-
+ list__map_foldl(get_type_info_locn, TypeVars, TypeInfoLocns, !Info),
polymorphism__add_unification_typeinfos(TypeInfoLocns,
- Unification0, GoalInfo0, Unification, GoalInfo).
+ !Unification, !GoalInfo).
% This variant is for use by modecheck_unify.m.
% During mode-checking all the type-infos should appear in
% the type_info_varmap.
-polymorphism__unification_typeinfos(Type, TypeInfoMap,
- Unification0, GoalInfo0, Unification, GoalInfo) :-
+polymorphism__unification_typeinfos(Type, TypeInfoMap, !Unification,
+ !GoalInfo) :-
%
% Compute the type_info/type_class_info variables that would be
% used if this unification ends up being a complicated_unify.
%
type_util__vars(Type, TypeVars),
map__apply_to_list(TypeVars, TypeInfoMap, TypeInfoLocns),
-
polymorphism__add_unification_typeinfos(TypeInfoLocns,
- Unification0, GoalInfo0, Unification, GoalInfo).
+ !Unification, !GoalInfo).
:- pred polymorphism__add_unification_typeinfos(list(type_info_locn)::in,
- unification::in, hlds_goal_info::in,
- unification::out, hlds_goal_info::out) is det.
+ unification::in, unification::out,
+ hlds_goal_info::in, hlds_goal_info::out) is det.
-polymorphism__add_unification_typeinfos(TypeInfoLocns,
- Unification0, GoalInfo0, Unification, GoalInfo) :-
+polymorphism__add_unification_typeinfos(TypeInfoLocns, !Unification,
+ !GoalInfo) :-
list__map(type_info_locn_var, TypeInfoLocns, TypeInfoVars0),
list__remove_dups(TypeInfoVars0, TypeInfoVars),
@@ -1308,9 +1245,9 @@
% Insert the TypeInfoVars into the nonlocals field of the goal_info
% for the unification goal.
%
- goal_info_get_nonlocals(GoalInfo0, NonLocals0),
+ goal_info_get_nonlocals(!.GoalInfo, NonLocals0),
set__insert_list(NonLocals0, TypeInfoVars, NonLocals),
- goal_info_set_nonlocals(GoalInfo0, NonLocals, GoalInfo),
+ goal_info_set_nonlocals(!.GoalInfo, NonLocals, !:GoalInfo),
%
% Also save those type_info vars into a field in the complicated_unify,
@@ -1318,27 +1255,25 @@
% This field is also used by modecheck_unify.m -- for complicated
% unifications, it checks that all these variables are ground.
%
- ( Unification0 = complicated_unify(Modes, CanFail, _) ->
- Unification = complicated_unify(Modes, CanFail, TypeInfoVars)
+ ( !.Unification = complicated_unify(Modes, CanFail, _) ->
+ !:Unification = complicated_unify(Modes, CanFail, TypeInfoVars)
;
% This can happen if an earlier stage of compilation
% has already determined that this unification is particular
% kind of unification. In that case, the type_info vars
% won't be needed.
- Unification = Unification0
+ true
).
-:- pred polymorphism__process_unify_functor(prog_var, cons_id, list(prog_var),
- unify_mode, unification, unify_context, hlds_goal_info,
- hlds_goal, poly_info, poly_info).
-:- mode polymorphism__process_unify_functor(in, in, in, in, in, in, in, out,
- in, out) is det.
+:- pred polymorphism__process_unify_functor(prog_var::in, cons_id::in,
+ list(prog_var)::in, unify_mode::in, unification::in, unify_context::in,
+ hlds_goal_info::in, hlds_goal::out, poly_info::in, poly_info::out)
+ is det.
polymorphism__process_unify_functor(X0, ConsId0, ArgVars0, Mode0,
- Unification0, UnifyContext, GoalInfo0, Goal,
- PolyInfo0, PolyInfo) :-
- poly_info_get_module_info(PolyInfo0, ModuleInfo0),
- poly_info_get_var_types(PolyInfo0, VarTypes0),
+ Unification0, UnifyContext, GoalInfo0, Goal, !Info) :-
+ poly_info_get_module_info(!.Info, ModuleInfo0),
+ poly_info_get_var_types(!.Info, VarTypes0),
map__lookup(VarTypes0, X0, TypeOfX),
list__length(ArgVars0, Arity),
(
@@ -1377,21 +1312,18 @@
%
% convert the higher-order pred term to a lambda goal
%
- poly_info_get_varset(PolyInfo0, VarSet0),
+ poly_info_get_varset(!.Info, VarSet0),
goal_info_get_context(GoalInfo0, Context),
convert_pred_to_lambda_goal(Purity, EvalMethod,
X0, PredId, ProcId, ArgVars0, PredArgTypes,
- UnifyContext, GoalInfo0, Context,
- ModuleInfo0, VarSet0, VarTypes0,
- Functor0, VarSet, VarTypes),
- poly_info_set_varset_and_types(VarSet, VarTypes,
- PolyInfo0, PolyInfo1),
+ UnifyContext, GoalInfo0, Context, ModuleInfo0,
+ Functor0, VarSet0, VarSet, VarTypes0, VarTypes),
+ poly_info_set_varset_and_types(VarSet, VarTypes, !Info),
%
% process the unification in its new form
%
polymorphism__process_unify(X0, Functor0, Mode0,
- Unification0, UnifyContext, GoalInfo0, Goal,
- PolyInfo1, PolyInfo)
+ Unification0, UnifyContext, GoalInfo0, Goal, !Info)
;
%
% is this a construction or deconstruction of an
@@ -1404,9 +1336,7 @@
% Otherwise, assume it is a deconstruction.
%
ConsId0 = cons(Functor0, Arity),
- (
- remove_new_prefix(Functor0, OrigFunctor)
- ->
+ ( remove_new_prefix(Functor0, OrigFunctor) ->
ConsId = cons(OrigFunctor, Arity),
IsConstruction = yes
;
@@ -1429,7 +1359,7 @@
goal_info_get_context(GoalInfo0, Context),
polymorphism__process_existq_unify_functor(ConsDefn,
IsConstruction, ActualArgTypes, TypeOfX, Context,
- ExtraVars, ExtraGoals, PolyInfo0, PolyInfo1),
+ ExtraVars, ExtraGoals, !Info),
list__append(ExtraVars, ArgVars0, ArgVars),
goal_info_get_nonlocals(GoalInfo0, NonLocals0),
set__insert_list(NonLocals0, ExtraVars, NonLocals),
@@ -1439,8 +1369,8 @@
% Some of the argument unifications may be complicated
% unifications, which may need type-infos.
%
- polymorphism__unification_typeinfos(TypeOfX, Unification0,
- GoalInfo1, Unification, GoalInfo, PolyInfo1, PolyInfo),
+ polymorphism__unification_typeinfos(TypeOfX,
+ Unification0, Unification, GoalInfo1, GoalInfo, !Info),
Unify = unify(X0, functor(ConsId, IsConstruction, ArgVars),
Mode0, Unification, UnifyContext) - GoalInfo,
@@ -1452,21 +1382,19 @@
% Some of the argument unifications may be complicated
% unifications, which may need type-infos.
%
- polymorphism__unification_typeinfos(TypeOfX, Unification0,
- GoalInfo0, Unification, GoalInfo, PolyInfo0, PolyInfo),
+ polymorphism__unification_typeinfos(TypeOfX,
+ Unification0, Unification, GoalInfo0, GoalInfo, !Info),
Goal = unify(X0, functor(ConsId0, no, ArgVars0), Mode0,
Unification, UnifyContext) - GoalInfo
).
convert_pred_to_lambda_goal(Purity, EvalMethod, X0, PredId, ProcId,
ArgVars0, PredArgTypes, UnifyContext, GoalInfo0, Context,
- ModuleInfo0, VarSet0, VarTypes0,
- Functor, VarSet, VarTypes) :-
+ ModuleInfo0, Functor, !VarSet, !VarTypes) :-
%
% Create the new lambda-quantified variables
%
- make_fresh_vars(PredArgTypes, VarSet0, VarTypes0,
- LambdaVars, VarSet, VarTypes),
+ make_fresh_vars(PredArgTypes, LambdaVars, !VarSet, !VarTypes),
list__append(ArgVars0, LambdaVars, Args),
%
@@ -1520,7 +1448,8 @@
( MaybeDet = yes(Det) ->
LambdaDet = Det
;
- error("Sorry, not implemented: determinism inference for higher-order predicate terms")
+ error("Sorry, not implemented: determinism inference " ++
+ "for higher-order predicate terms")
),
%
@@ -1530,16 +1459,15 @@
Functor = lambda_goal(Purity, PredOrFunc, EvalMethod, modes_are_ok,
ArgVars0, LambdaVars, LambdaModes, LambdaDet, LambdaGoal).
-:- pred make_fresh_vars(list(type), prog_varset, map(prog_var, type),
- list(prog_var), prog_varset, map(prog_var, type)).
-:- mode make_fresh_vars(in, in, in, out, out, out) is det.
-
-make_fresh_vars([], VarSet, VarTypes, [], VarSet, VarTypes).
-make_fresh_vars([Type|Types], VarSet0, VarTypes0,
- [Var|Vars], VarSet, VarTypes) :-
- varset__new_var(VarSet0, Var, VarSet1),
- map__det_insert(VarTypes0, Var, Type, VarTypes1),
- make_fresh_vars(Types, VarSet1, VarTypes1, Vars, VarSet, VarTypes).
+:- pred make_fresh_vars(list(type)::in, list(prog_var)::out,
+ prog_varset::in, prog_varset::out,
+ map(prog_var, type)::in, map(prog_var, type)::out) is det.
+
+make_fresh_vars([], [], !VarSet, !VarTypes).
+make_fresh_vars([Type | Types], [Var | Vars], !VarSet, !VarTypes) :-
+ varset__new_var(!.VarSet, Var, !:VarSet),
+ map__det_insert(!.VarTypes, Var, Type, !:VarTypes),
+ make_fresh_vars(Types, Vars, !VarSet, !VarTypes).
%-----------------------------------------------------------------------------%
@@ -1547,15 +1475,13 @@
% compute the extra arguments that we need to add to a unification with
% an existentially quantified data constructor.
%
-:- pred polymorphism__process_existq_unify_functor(
- ctor_defn, bool, list(type), (type), prog_context,
- list(prog_var), list(hlds_goal), poly_info, poly_info).
-:- mode polymorphism__process_existq_unify_functor(in, in, in, in, in,
- out, out, in, out) is det.
+:- pred polymorphism__process_existq_unify_functor(ctor_defn::in, bool::in,
+ list(type)::in, (type)::in, prog_context::in, list(prog_var)::out,
+ list(hlds_goal)::out, poly_info::in, poly_info::out) is det.
polymorphism__process_existq_unify_functor(CtorDefn, IsConstruction,
ActualArgTypes, ActualRetType, Context,
- ExtraVars, ExtraGoals, PolyInfo0, PolyInfo) :-
+ ExtraVars, ExtraGoals, !Info) :-
CtorDefn = ctor_defn(CtorTypeVarSet, ExistQVars0,
ExistentialConstraints0, CtorArgTypes0, CtorRetType0),
@@ -1563,7 +1489,7 @@
%
% rename apart the type variables in the constructor definition
%
- poly_info_get_typevarset(PolyInfo0, TypeVarSet0),
+ poly_info_get_typevarset(!.Info, TypeVarSet0),
varset__merge_subst(TypeVarSet0, CtorTypeVarSet, TypeVarSet, Subst),
term__var_list_to_term_list(ExistQVars0, ExistQVarTerms0),
term__apply_substitution_to_list(ExistQVarTerms0, Subst,
@@ -1572,19 +1498,21 @@
ExistentialConstraints1),
term__apply_substitution_to_list(CtorArgTypes0, Subst, CtorArgTypes1),
term__apply_substitution(CtorRetType0, Subst, CtorRetType1),
- poly_info_set_typevarset(TypeVarSet, PolyInfo0, PolyInfo1),
+ poly_info_set_typevarset(TypeVarSet, !Info),
%
% Compute the type bindings resulting from the functor's actual
% argument and return types.
% These are the ones that might bind the ExistQVars.
%
- ( type_list_subsumes([CtorRetType1 | CtorArgTypes1],
- [ActualRetType | ActualArgTypes], TypeSubst1) ->
+ (
+ type_list_subsumes([CtorRetType1 | CtorArgTypes1],
+ [ActualRetType | ActualArgTypes], TypeSubst1)
+ ->
TypeSubst = TypeSubst1
;
- error(
- "polymorphism__process_existq_unify_functor: type unification failed")
+ error("polymorphism__process_existq_unify_functor: " ++
+ "type unification failed")
),
%
@@ -1601,16 +1529,15 @@
(
IsConstruction = yes,
% assume it's a construction
- polymorphism__make_typeclass_info_vars(
- ExistentialConstraints, [], Context,
- ExtraTypeClassVars, ExtraTypeClassGoals,
- PolyInfo1, PolyInfo3)
+ polymorphism__make_typeclass_info_vars(ExistentialConstraints,
+ [], Context, ExtraTypeClassVars, ExtraTypeClassGoals,
+ !Info)
;
IsConstruction = no,
% assume it's a deconstruction
polymorphism__make_existq_typeclass_info_vars(
ExistentialConstraints, ExtraTypeClassVars,
- ExtraTypeClassGoals, PolyInfo1, PolyInfo3)
+ ExtraTypeClassGoals, !Info)
),
%
@@ -1631,9 +1558,8 @@
% create type_info variables for the _unconstrained_
% existentially quantified type variables
%
- polymorphism__make_type_info_vars(ExistentialTypes,
- Context, ExtraTypeInfoVars, ExtraTypeInfoGoals,
- PolyInfo3, PolyInfo),
+ polymorphism__make_type_info_vars(ExistentialTypes, Context,
+ ExtraTypeInfoVars, ExtraTypeInfoGoals, !Info),
%
% the type_class_info variables go AFTER the type_info variables
@@ -1645,12 +1571,12 @@
%-----------------------------------------------------------------------------%
-:- pred polymorphism__process_c_code(pred_info, int, pragma_foreign_code_impl,
- list(type), list(type),
- list(maybe(pair(string, mode))), list(maybe(pair(string, mode)))).
-:- mode polymorphism__process_c_code(in, in, in, in, out, in, out) is det.
+:- pred polymorphism__process_foreign_proc(pred_info::in, int::in,
+ pragma_foreign_code_impl::in, list(type)::in, list(type)::out,
+ list(maybe(pair(string, mode)))::in,
+ list(maybe(pair(string, mode)))::out) is det.
-polymorphism__process_c_code(PredInfo, NumExtraVars, Impl, OrigArgTypes0,
+polymorphism__process_foreign_proc(PredInfo, NumExtraVars, Impl, OrigArgTypes0,
OrigArgTypes, ArgInfo0, ArgInfo) :-
pred_info_arg_types(PredInfo, PredTypeVarSet, ExistQVars,
PredArgTypes),
@@ -1658,23 +1584,15 @@
% Find out which variables are constrained (so that we don't
% add type-infos for them.
pred_info_get_class_context(PredInfo, constraints(UnivCs, ExistCs)),
- GetConstrainedVars = lambda([ClassConstraint::in, CVars::out] is det,
- (
- ClassConstraint = constraint(_, CTypes),
- term__vars_list(CTypes, CVars)
- )
- ),
- list__map(GetConstrainedVars, UnivCs, UnivVars0),
+ UnivVars0 = list__map(get_constrained_vars, UnivCs),
list__condense(UnivVars0, UnivConstrainedVars),
- list__map(GetConstrainedVars, ExistCs, ExistVars0),
+ ExistVars0 = list__map(get_constrained_vars, ExistCs),
list__condense(ExistVars0, ExistConstrainedVars),
term__vars_list(PredArgTypes, PredTypeVars0),
list__remove_dups(PredTypeVars0, PredTypeVars1),
- list__delete_elems(PredTypeVars1, UnivConstrainedVars,
- PredTypeVars2),
- list__delete_elems(PredTypeVars2, ExistConstrainedVars,
- PredTypeVars),
+ list__delete_elems(PredTypeVars1, UnivConstrainedVars, PredTypeVars2),
+ list__delete_elems(PredTypeVars2, ExistConstrainedVars, PredTypeVars),
% sanity check
list__length(UnivCs, NUCs),
@@ -1696,12 +1614,10 @@
% arguments and prepending things as we go, we need to do it in
% reverse order.
- polymorphism__c_code_add_typeclass_infos(
- UnivCs, ExistCs, PredTypeVarSet, Impl,
- ArgInfo0, ArgInfo1),
- polymorphism__c_code_add_typeinfos(
- PredTypeVars, PredTypeVarSet, ExistQVars, Impl,
- ArgInfo1, ArgInfo),
+ polymorphism__foreign_proc_add_typeclass_infos(UnivCs, ExistCs,
+ PredTypeVarSet, Impl, ArgInfo0, ArgInfo1),
+ polymorphism__foreign_proc_add_typeinfos( PredTypeVars, PredTypeVarSet,
+ ExistQVars, Impl, ArgInfo1, ArgInfo),
%
% insert type_info/typeclass_info types for all the inserted
@@ -1716,88 +1632,78 @@
list__append(ExistTypes, OrigArgTypes1, OrigArgTypes2),
list__append(UnivTypes, OrigArgTypes2, OrigArgTypes).
-:- pred polymorphism__c_code_add_typeclass_infos(
- list(class_constraint), list(class_constraint),
- tvarset, pragma_foreign_code_impl,
- list(maybe(pair(string, mode))),
- list(maybe(pair(string, mode)))).
-:- mode polymorphism__c_code_add_typeclass_infos(in, in, in, in,
- in, out) is det.
+:- pred polymorphism__foreign_proc_add_typeclass_infos(
+ list(class_constraint)::in, list(class_constraint)::in,
+ tvarset::in, pragma_foreign_code_impl::in,
+ list(maybe(pair(string, mode)))::in,
+ list(maybe(pair(string, mode)))::out) is det.
-polymorphism__c_code_add_typeclass_infos(UnivCs, ExistCs,
+polymorphism__foreign_proc_add_typeclass_infos(UnivCs, ExistCs,
PredTypeVarSet, Impl, ArgInfo0, ArgInfo) :-
in_mode(In),
out_mode(Out),
- polymorphism__c_code_add_typeclass_infos_2(ExistCs, Out,
+ polymorphism__foreign_proc_add_typeclass_infos_2(ExistCs, Out,
PredTypeVarSet, Impl, ArgInfo0, ArgInfo1),
- polymorphism__c_code_add_typeclass_infos_2(UnivCs, In,
+ polymorphism__foreign_proc_add_typeclass_infos_2(UnivCs, In,
PredTypeVarSet, Impl, ArgInfo1, ArgInfo).
-:- pred polymorphism__c_code_add_typeclass_infos_2(
- list(class_constraint), mode,
- tvarset, pragma_foreign_code_impl,
- list(maybe(pair(string, mode))),
- list(maybe(pair(string, mode)))).
-:- mode polymorphism__c_code_add_typeclass_infos_2(in, in, in, in,
- in, out) is det.
-polymorphism__c_code_add_typeclass_infos_2([], _, _, _, ArgNames, ArgNames).
-polymorphism__c_code_add_typeclass_infos_2([C|Cs], Mode, TypeVarSet, Impl,
- ArgNames0, ArgNames) :-
- polymorphism__c_code_add_typeclass_infos_2(Cs, Mode, TypeVarSet,
- Impl, ArgNames0, ArgNames1),
- C = constraint(Name0, Types),
+:- pred polymorphism__foreign_proc_add_typeclass_infos_2(
+ list(class_constraint)::in, (mode)::in, tvarset::in,
+ pragma_foreign_code_impl::in,
+ list(maybe(pair(string, mode)))::in,
+ list(maybe(pair(string, mode)))::out) is det.
+
+polymorphism__foreign_proc_add_typeclass_infos_2([], _, _, _, !ArgNames).
+polymorphism__foreign_proc_add_typeclass_infos_2([Constraint | Constraints],
+ Mode, TypeVarSet, Impl, !ArgNames) :-
+ polymorphism__foreign_proc_add_typeclass_infos_2(Constraints,
+ Mode, TypeVarSet, Impl, !ArgNames),
+ Constraint = constraint(Name0, Types),
prog_out__sym_name_to_string(Name0, "__", Name),
term__vars_list(Types, TypeVars),
- GetName = lambda([TVar::in, TVarName::out] is det,
- (
- varset__lookup_name(TypeVarSet, TVar, TVarName0),
- string__append("_", TVarName0, TVarName)
- )
- ),
- list__map(GetName, TypeVars, TypeVarNames),
- string__append_list(["TypeClassInfo_for_", Name|TypeVarNames],
- C_VarName),
+ TypeVarNames =
+ list__map(underscore_and_tvar_name(TypeVarSet), TypeVars),
+ string__append_list(["TypeClassInfo_for_", Name | TypeVarNames],
+ ConstraintVarName),
(
% If the variable name corresponding to the
% typeclass-info isn't mentioned in the C code
% fragment, don't pass the variable to the
% C code at all.
- foreign_code_does_not_use_variable(Impl, C_VarName)
+ foreign_code_does_not_use_variable(Impl, ConstraintVarName)
->
- ArgNames = [no | ArgNames1]
+ !:ArgNames = [no | !.ArgNames]
;
- ArgNames = [yes(C_VarName - Mode) | ArgNames1]
+ !:ArgNames = [yes(ConstraintVarName - Mode) | !.ArgNames]
).
-:- pred polymorphism__c_code_add_typeinfos(list(tvar),
- tvarset, existq_tvars, pragma_foreign_code_impl,
- list(maybe(pair(string, mode))),
- list(maybe(pair(string, mode)))).
-:- mode polymorphism__c_code_add_typeinfos(in, in, in, in, in, out) is det.
+:- pred polymorphism__foreign_proc_add_typeinfos(list(tvar)::in, tvarset::in,
+ existq_tvars::in, pragma_foreign_code_impl::in,
+ list(maybe(pair(string, mode)))::in,
+ list(maybe(pair(string, mode)))::out) is det.
-polymorphism__c_code_add_typeinfos(TVars, TypeVarSet,
+polymorphism__foreign_proc_add_typeinfos(TVars, TypeVarSet,
ExistQVars, Impl, ArgNames0, ArgNames) :-
- list__filter(lambda([X::in] is semidet, (list__member(X, ExistQVars))),
+ list__filter((pred(X::in) is semidet :- list__member(X, ExistQVars)),
TVars, ExistUnconstrainedVars, UnivUnconstrainedVars),
in_mode(In),
out_mode(Out),
- polymorphism__c_code_add_typeinfos_2(ExistUnconstrainedVars, TypeVarSet,
- Out, Impl, ArgNames0, ArgNames1),
- polymorphism__c_code_add_typeinfos_2(UnivUnconstrainedVars, TypeVarSet,
- In, Impl, ArgNames1, ArgNames).
-
-:- pred polymorphism__c_code_add_typeinfos_2(list(tvar),
- tvarset, mode, pragma_foreign_code_impl,
- list(maybe(pair(string, mode))),
- list(maybe(pair(string, mode)))).
-:- mode polymorphism__c_code_add_typeinfos_2(in, in, in, in, in, out) is det.
-
-polymorphism__c_code_add_typeinfos_2([], _, _, _, ArgNames, ArgNames).
-polymorphism__c_code_add_typeinfos_2([TVar|TVars], TypeVarSet, Mode, Impl,
- ArgNames0, ArgNames) :-
- polymorphism__c_code_add_typeinfos_2(TVars, TypeVarSet,
- Mode, Impl, ArgNames0, ArgNames1),
+ polymorphism__foreign_proc_add_typeinfos_2(ExistUnconstrainedVars,
+ TypeVarSet, Out, Impl, ArgNames0, ArgNames1),
+ polymorphism__foreign_proc_add_typeinfos_2(UnivUnconstrainedVars,
+ TypeVarSet, In, Impl, ArgNames1, ArgNames).
+
+:- pred polymorphism__foreign_proc_add_typeinfos_2(list(tvar)::in, tvarset::in,
+ (mode)::in, pragma_foreign_code_impl::in,
+ list(maybe(pair(string, mode)))::in,
+ list(maybe(pair(string, mode)))::out) is det.
+
+polymorphism__foreign_proc_add_typeinfos_2([], _, _, _, !ArgNames).
+polymorphism__foreign_proc_add_typeinfos_2([TVar | TVars], TypeVarSet, Mode,
+ Impl, !ArgNames) :-
+ polymorphism__foreign_proc_add_typeinfos_2(TVars, TypeVarSet, Mode,
+ Impl, !ArgNames),
( varset__search_name(TypeVarSet, TVar, TypeVarName) ->
string__append("TypeInfo_for_", TypeVarName, C_VarName),
(
@@ -1808,16 +1714,16 @@
foreign_code_does_not_use_variable(Impl, C_VarName)
->
- ArgNames = [no | ArgNames1]
+ !:ArgNames = [no | !.ArgNames]
;
- ArgNames = [yes(C_VarName - Mode) | ArgNames1]
+ !:ArgNames = [yes(C_VarName - Mode) | !.ArgNames]
)
;
- ArgNames = [no | ArgNames1]
+ !:ArgNames = [no | !.ArgNames]
).
-:- pred foreign_code_does_not_use_variable(pragma_foreign_code_impl, string).
-:- mode foreign_code_does_not_use_variable(in, in) is semidet.
+:- pred foreign_code_does_not_use_variable(pragma_foreign_code_impl::in,
+ string::in) is semidet.
foreign_code_does_not_use_variable(Impl, VarName) :-
% XXX This test is temporarily turned off, as it causes
@@ -1826,8 +1732,7 @@
semidet_fail,
(
Impl = ordinary(ForeignBody, _),
- \+ string__sub_string_search(ForeignBody,
- VarName, _)
+ \+ string__sub_string_search(ForeignBody, VarName, _)
;
Impl = nondet(FB1,_,FB2,_,FB3,_,_,FB4,_),
\+ string__sub_string_search(FB1, VarName, _),
@@ -1836,25 +1741,29 @@
\+ string__sub_string_search(FB4, VarName, _)
).
-:- pred polymorphism__process_goal_list(list(hlds_goal), list(hlds_goal),
- poly_info, poly_info).
-:- mode polymorphism__process_goal_list(in, out, in, out) is det.
-
-polymorphism__process_goal_list([], []) --> [].
-polymorphism__process_goal_list([Goal0 | Goals0], [Goal | Goals]) -->
- polymorphism__process_goal(Goal0, Goal),
- polymorphism__process_goal_list(Goals0, Goals).
-
-:- pred polymorphism__process_case_list(list(case), list(case),
- poly_info, poly_info).
-:- mode polymorphism__process_case_list(in, out, in, out) is det.
-
-polymorphism__process_case_list([], []) --> [].
-polymorphism__process_case_list([Case0 | Cases0], [Case | Cases]) -->
- { Case0 = case(ConsId, Goal0) },
- polymorphism__process_goal(Goal0, Goal),
- { Case = case(ConsId, Goal) },
- polymorphism__process_case_list(Cases0, Cases).
+:- func underscore_and_tvar_name(tvarset, tvar) = string.
+
+underscore_and_tvar_name(TypeVarSet, TVar) = TVarName :-
+ varset__lookup_name(TypeVarSet, TVar, TVarName0),
+ string__append("_", TVarName0, TVarName).
+
+:- pred polymorphism__process_goal_list(list(hlds_goal)::in,
+ list(hlds_goal)::out, poly_info::in, poly_info::out) is det.
+
+polymorphism__process_goal_list([], [], !Info).
+polymorphism__process_goal_list([Goal0 | Goals0], [Goal | Goals], !Info) :-
+ polymorphism__process_goal(Goal0, Goal, !Info),
+ polymorphism__process_goal_list(Goals0, Goals, !Info).
+
+:- pred polymorphism__process_case_list(list(case)::in, list(case)::out,
+ poly_info::in, poly_info::out) is det.
+
+polymorphism__process_case_list([], [], !Info).
+polymorphism__process_case_list([Case0 | Cases0], [Case | Cases], !Info) :-
+ Case0 = case(ConsId, Goal0),
+ polymorphism__process_goal(Goal0, Goal, !Info),
+ Case = case(ConsId, Goal),
+ polymorphism__process_case_list(Cases0, Cases, !Info).
%-----------------------------------------------------------------------------%
@@ -1862,19 +1771,16 @@
% existential/universal type_infos and type_class_infos
% in a more consistent manner.
-:- pred polymorphism__process_call(pred_id, list(prog_var), hlds_goal_info,
- list(prog_var), list(prog_var), hlds_goal_info,
- list(hlds_goal), poly_info, poly_info).
-:- mode polymorphism__process_call(in, in, in,
- out, out, out, out, in, out) is det.
+:- pred polymorphism__process_call(pred_id::in, list(prog_var)::in,
+ hlds_goal_info::in, list(prog_var)::out, list(prog_var)::out,
+ hlds_goal_info::out, list(hlds_goal)::out,
+ poly_info::in, poly_info::out) is det.
polymorphism__process_call(PredId, ArgVars0, GoalInfo0,
- ArgVars, ExtraVars, GoalInfo, ExtraGoals,
- Info0, Info) :-
-
- poly_info_get_var_types(Info0, VarTypes),
- poly_info_get_typevarset(Info0, TypeVarSet0),
- poly_info_get_module_info(Info0, ModuleInfo),
+ ArgVars, ExtraVars, GoalInfo, ExtraGoals, !Info) :-
+ poly_info_get_var_types(!.Info, VarTypes),
+ poly_info_get_typevarset(!.Info, TypeVarSet0),
+ poly_info_get_module_info(!.Info, ModuleInfo),
module_info_pred_info(ModuleInfo, PredId, PredInfo),
pred_info_arg_types(PredInfo, PredTypeVarSet, PredExistQVars0,
@@ -1924,22 +1830,24 @@
ArgVars = ArgVars0,
GoalInfo = GoalInfo0,
ExtraGoals = [],
- ExtraVars = [],
- Info = Info0
+ ExtraVars = []
;
list__remove_dups(PredTypeVars0, PredTypeVars1),
map__apply_to_list(ArgVars0, VarTypes, ActualArgTypes),
- ( type_list_subsumes(PredArgTypes, ActualArgTypes,
- TypeSubst1) ->
+ (
+ type_list_subsumes(PredArgTypes, ActualArgTypes,
+ TypeSubst1)
+ ->
TypeSubst = TypeSubst1
;
- error("polymorphism__process_goal_expr: type unification failed")
+ error("polymorphism__process_goal_expr: " ++
+ "type unification failed")
),
apply_subst_to_constraints(Subst, PredClassContext0,
PredClassContext1),
- poly_info_set_typevarset(TypeVarSet, Info0, Info1),
+ poly_info_set_typevarset(TypeVarSet, !Info),
% Make the universally quantified typeclass_infos
% for the call, and return a list of which type
@@ -1963,11 +1871,9 @@
term__term_list_to_var_list(PredExistQVarTerms,
PredExistQVars),
- polymorphism__make_typeclass_info_vars(
- UniversalConstraints2,
- PredExistQVars, Context,
- UnivTypeClassVars, ExtraTypeClassGoals,
- Info1, Info2),
+ polymorphism__make_typeclass_info_vars(UniversalConstraints2,
+ PredExistQVars, Context, UnivTypeClassVars,
+ ExtraTypeClassGoals, !Info),
% Make variables to hold any existentially
% quantified typeclass_infos in the call,
@@ -1976,7 +1882,7 @@
ExistentialConstraints1, ExistentialConstraints),
polymorphism__make_existq_typeclass_info_vars(
ExistentialConstraints, ExistTypeClassVars,
- ExtraExistClassGoals, Info2, Info4),
+ ExtraExistClassGoals, !Info),
list__append(UnivTypeClassVars, ExistTypeClassVars,
ExtraTypeClassVars),
@@ -1992,8 +1898,7 @@
PredTypes),
polymorphism__make_type_info_vars(PredTypes,
- Context, ExtraTypeInfoVars, ExtraTypeInfoGoals,
- Info4, Info),
+ Context, ExtraTypeInfoVars, ExtraTypeInfoGoals, !Info),
list__append(ExtraTypeClassVars, ArgVars0, ArgVars1),
list__append(ExtraTypeInfoVars, ArgVars1, ArgVars),
ExtraGoals = ExtraTypeClassGoals ++ ExtraExistClassGoals
@@ -2008,36 +1913,34 @@
goal_info_set_nonlocals(GoalInfo0, NonLocals, GoalInfo)
).
-:- pred polymorphism__update_typeclass_infos(list(class_constraint),
- list(prog_var), poly_info, poly_info).
-:- mode polymorphism__update_typeclass_infos(in, in, in, out) is det.
-
-polymorphism__update_typeclass_infos(Constraints, Vars, Info0, Info) :-
- poly_info_get_typeclass_info_map(Info0, TypeClassInfoMap0),
- insert_typeclass_info_locns( Constraints, Vars, TypeClassInfoMap0,
- TypeClassInfoMap),
- poly_info_set_typeclass_info_map(TypeClassInfoMap, Info0, Info).
-
-:- pred insert_typeclass_info_locns(list(class_constraint), list(prog_var),
- map(class_constraint, prog_var), map(class_constraint, prog_var)).
-:- mode insert_typeclass_info_locns(in, in, in, out) is det.
-
-insert_typeclass_info_locns([], [], TypeClassInfoMap, TypeClassInfoMap).
-insert_typeclass_info_locns([C|Cs], [V|Vs], TypeClassInfoMap0,
- TypeClassInfoMap) :-
- map__set(TypeClassInfoMap0, C, V, TypeClassInfoMap1),
- insert_typeclass_info_locns(Cs, Vs,
- TypeClassInfoMap1, TypeClassInfoMap).
-insert_typeclass_info_locns([], [_|_], _, _) :-
+:- pred polymorphism__update_typeclass_infos(list(class_constraint)::in,
+ list(prog_var)::in, poly_info::in, poly_info::out) is det.
+
+polymorphism__update_typeclass_infos(Constraints, Vars, !Info) :-
+ poly_info_get_typeclass_info_map(!.Info, TypeClassInfoMap0),
+ insert_typeclass_info_locns(Constraints, Vars,
+ TypeClassInfoMap0, TypeClassInfoMap),
+ poly_info_set_typeclass_info_map(TypeClassInfoMap, !Info).
+
+:- pred insert_typeclass_info_locns(list(class_constraint)::in,
+ list(prog_var)::in,
+ map(class_constraint, prog_var)::in,
+ map(class_constraint, prog_var)::out) is det.
+
+insert_typeclass_info_locns([], [], !TypeClassInfoMap).
+insert_typeclass_info_locns([C | Cs], [V | Vs], !TypeClassInfoMap) :-
+ map__set(!.TypeClassInfoMap, C, V, !:TypeClassInfoMap),
+ insert_typeclass_info_locns(Cs, Vs, !TypeClassInfoMap).
+insert_typeclass_info_locns([], [_ | _], _, _) :-
error("polymorphism:insert_typeclass_info_locns").
-insert_typeclass_info_locns([_|_], [], _, _) :-
+insert_typeclass_info_locns([_ | _], [], _, _) :-
error("polymorphism:insert_typeclass_info_locns").
%-----------------------------------------------------------------------------%
-:- pred polymorphism__fixup_quantification(list(prog_var), existq_tvars,
- hlds_goal, hlds_goal, poly_info, poly_info).
-:- mode polymorphism__fixup_quantification(in, in, in, out, in, out) is det.
+:- pred polymorphism__fixup_quantification(list(prog_var)::in,
+ existq_tvars::in, hlds_goal::in, hlds_goal::out,
+ poly_info::in, poly_info::out) is det.
%
% If the pred we are processing is a polymorphic predicate,
@@ -2056,30 +1959,26 @@
% the code which creates/alters them.
%
-polymorphism__fixup_quantification(HeadVars, ExistQVars, Goal0, Goal,
- Info0, Info) :-
+polymorphism__fixup_quantification(HeadVars, ExistQVars, Goal0, Goal, !Info) :-
(
% optimize common case
ExistQVars = [],
- poly_info_get_type_info_map(Info0, TypeVarMap),
+ poly_info_get_type_info_map(!.Info, TypeVarMap),
map__is_empty(TypeVarMap)
->
- Info = Info0,
Goal = Goal0
;
- poly_info_get_varset(Info0, VarSet0),
- poly_info_get_var_types(Info0, VarTypes0),
+ poly_info_get_varset(!.Info, VarSet0),
+ poly_info_get_var_types(!.Info, VarTypes0),
set__list_to_set(HeadVars, OutsideVars),
implicitly_quantify_goal(Goal0, VarSet0, VarTypes0,
OutsideVars, Goal, VarSet, VarTypes, _Warnings),
- poly_info_set_varset_and_types(VarSet, VarTypes, Info0, Info)
+ poly_info_set_varset_and_types(VarSet, VarTypes, !Info)
).
-:- pred polymorphism__fixup_lambda_quantification(hlds_goal,
- list(prog_var), list(prog_var), existq_tvars,
- hlds_goal, set(prog_var), poly_info, poly_info).
-:- mode polymorphism__fixup_lambda_quantification(in, in, in, in, out, out,
- in, out) is det.
+:- pred polymorphism__fixup_lambda_quantification(list(prog_var)::in,
+ list(prog_var)::in, existq_tvars::in, hlds_goal::in, hlds_goal::out,
+ set(prog_var)::out, poly_info::in, poly_info::out) is det.
%
% If the lambda goal we are processing is polymorphically typed,
@@ -2094,18 +1993,16 @@
% cost is pretty minimal.
%
-polymorphism__fixup_lambda_quantification(Goal0, ArgVars, LambdaVars,
- ExistQVars, Goal, NewOutsideVars, Info0, Info) :-
- poly_info_get_type_info_map(Info0, TypeVarMap),
- poly_info_get_typeclass_info_map(Info0, TypeClassVarMap),
+polymorphism__fixup_lambda_quantification(ArgVars, LambdaVars, ExistQVars,
+ !Goal, NewOutsideVars, !Info) :-
+ poly_info_get_type_info_map(!.Info, TypeVarMap),
+ poly_info_get_typeclass_info_map(!.Info, TypeClassVarMap),
( map__is_empty(TypeVarMap) ->
- set__init(NewOutsideVars),
- Info = Info0,
- Goal = Goal0
+ set__init(NewOutsideVars)
;
- poly_info_get_varset(Info0, VarSet0),
- poly_info_get_var_types(Info0, VarTypes0),
- Goal0 = _ - GoalInfo0,
+ poly_info_get_varset(!.Info, VarSet0),
+ poly_info_get_var_types(!.Info, VarTypes0),
+ !.Goal = _ - GoalInfo0,
goal_info_get_nonlocals(GoalInfo0, NonLocals),
set__insert_list(NonLocals, ArgVars, NonLocalsPlusArgs0),
set__insert_list(NonLocalsPlusArgs0, LambdaVars,
@@ -2114,9 +2011,9 @@
TypeClassVarMap, VarTypes0, ExistQVars,
NonLocalsPlusArgs, NewOutsideVars),
set__union(NonLocals, NewOutsideVars, OutsideVars),
- implicitly_quantify_goal(Goal0, VarSet0, VarTypes0,
- OutsideVars, Goal, VarSet, VarTypes, _Warnings),
- poly_info_set_varset_and_types(VarSet, VarTypes, Info0, Info)
+ implicitly_quantify_goal(!.Goal, VarSet0, VarTypes0,
+ OutsideVars, !:Goal, VarSet, VarTypes, _Warnings),
+ poly_info_set_varset_and_types(VarSet, VarTypes, !Info)
).
%-----------------------------------------------------------------------------%
@@ -2130,116 +2027,88 @@
% have already had their typeclass_infos initialized; for them, we
% just return the variable in the TypeClassInfoMap.
-:- pred polymorphism__make_typeclass_info_vars(list(class_constraint),
- existq_tvars, prog_context,
- list(prog_var), list(hlds_goal),
- poly_info, poly_info).
-:- mode polymorphism__make_typeclass_info_vars(in, in, in,
- out, out, in, out) is det.
-
-polymorphism__make_typeclass_info_vars(PredClassContext,
- ExistQVars, Context,
- ExtraVars, ExtraGoals, Info0, Info) :-
+:- pred polymorphism__make_typeclass_info_vars(list(class_constraint)::in,
+ existq_tvars::in, prog_context::in,
+ list(prog_var)::out, list(hlds_goal)::out,
+ poly_info::in, poly_info::out) is det.
+polymorphism__make_typeclass_info_vars(PredClassContext, ExistQVars, Context,
+ ExtraVars, ExtraGoals, !Info) :-
% initialise the accumulators
ExtraVars0 = [],
ExtraGoals0 = [],
-
SeenInstances = [],
-
% do the work
polymorphism__make_typeclass_info_vars_2(PredClassContext,
- SeenInstances, ExistQVars, Context,
- ExtraVars0, ExtraVars1,
- ExtraGoals0, ExtraGoals1,
- Info0, Info),
-
+ SeenInstances, ExistQVars, Context, ExtraVars0, ExtraVars1,
+ ExtraGoals0, ExtraGoals1, !Info),
% We build up the vars and goals in reverse order
list__reverse(ExtraVars1, ExtraVars),
list__reverse(ExtraGoals1, ExtraGoals).
% Accumulator version of the above.
:- pred polymorphism__make_typeclass_info_vars_2(
- list(class_constraint),
- list(class_constraint),
- existq_tvars, prog_context,
- list(prog_var), list(prog_var),
- list(hlds_goal), list(hlds_goal),
- poly_info, poly_info).
-:- mode polymorphism__make_typeclass_info_vars_2(in, in, in, in,
- in, out, in, out, in, out) is det.
+ list(class_constraint)::in, list(class_constraint)::in,
+ existq_tvars::in, prog_context::in,
+ list(prog_var)::in, list(prog_var)::out,
+ list(hlds_goal)::in, list(hlds_goal)::out,
+ poly_info::in, poly_info::out) is det.
polymorphism__make_typeclass_info_vars_2([], _Seen, _ExistQVars,
- _Context, ExtraVars, ExtraVars,
- ExtraGoals, ExtraGoals,
- Info, Info).
-polymorphism__make_typeclass_info_vars_2([C|Cs], Seen, ExistQVars,
- Context, ExtraVars0, ExtraVars,
- ExtraGoals0, ExtraGoals,
- Info0, Info) :-
- polymorphism__make_typeclass_info_var(C, [C | Seen], ExistQVars,
- Context, ExtraGoals0, ExtraGoals1,
- Info0, Info1, MaybeExtraVar),
- maybe_insert_var(MaybeExtraVar, ExtraVars0, ExtraVars1),
- polymorphism__make_typeclass_info_vars_2(Cs, Seen,
- ExistQVars, Context,
- ExtraVars1, ExtraVars,
- ExtraGoals1, ExtraGoals,
- Info1, Info).
-
-:- pred polymorphism__make_typeclass_info_var(class_constraint,
- list(class_constraint), existq_tvars, prog_context, list(hlds_goal),
- list(hlds_goal), poly_info, poly_info, maybe(prog_var)).
-:- mode polymorphism__make_typeclass_info_var(in, in, in, in, in, out,
- in, out, out) is det.
+ _Context, !ExtraVars, !ExtraGoals, !Info).
+polymorphism__make_typeclass_info_vars_2([Constraint | Constraints],
+ Seen, ExistQVars, Context, !ExtraVars, !ExtraGoals, !Info) :-
+ polymorphism__make_typeclass_info_var(Constraint, [Constraint | Seen],
+ ExistQVars, Context, !ExtraGoals, !Info, MaybeExtraVar),
+ maybe_insert_var(MaybeExtraVar, !ExtraVars),
+ polymorphism__make_typeclass_info_vars_2(Constraints, Seen, ExistQVars,
+ Context, !ExtraVars, !ExtraGoals, !Info).
+
+:- pred polymorphism__make_typeclass_info_var(class_constraint::in,
+ list(class_constraint)::in, existq_tvars::in, prog_context::in,
+ list(hlds_goal)::in, list(hlds_goal)::out,
+ poly_info::in, poly_info::out, maybe(prog_var)::out) is det.
polymorphism__make_typeclass_info_var(Constraint, Seen, ExistQVars,
- Context, ExtraGoals0, ExtraGoals,
- Info0, Info, MaybeVar) :-
+ Context, !ExtraGoals, !Info, MaybeVar) :-
(
- map__search(Info0^typeclass_info_map, Constraint, Location)
+ map__search(!.Info ^ typeclass_info_map, Constraint, Var)
->
% We already have a typeclass_info for this constraint,
% either from a parameter to the pred or from an
% existentially quantified goal that we have already
% processed.
- ExtraGoals = ExtraGoals0,
- Var = Location,
- MaybeVar = yes(Var),
- Info = Info0
+ MaybeVar = yes(Var)
;
% We don't have the typeclass_info, we must either have
% a proof that tells us how to make it, or it will be
% produced by an existentially typed goal that we
% will process later on.
- map__search(Info0^proof_map, Constraint, Proof)
+ map__search(!.Info ^ proof_map, Constraint, Proof)
->
polymorphism__make_typeclass_info_from_proof(Constraint, Seen,
- Proof, ExistQVars, Context, MaybeVar, ExtraGoals0,
- ExtraGoals, Info0, Info)
+ Proof, ExistQVars, Context, MaybeVar,
+ !ExtraGoals, !Info)
;
polymorphism__make_typeclass_info_head_var(Constraint,
- NewVar, Info0, Info1),
- map__det_insert(Info1^typeclass_info_map, Constraint, NewVar,
- NewTypeClassInfoMap),
- Info = (Info1^typeclass_info_map := NewTypeClassInfoMap),
- MaybeVar = yes(NewVar),
- ExtraGoals = ExtraGoals0
+ NewVar, !Info),
+ map__det_insert(!.Info ^ typeclass_info_map, Constraint,
+ NewVar, NewTypeClassInfoMap),
+ !:Info = (!.Info ^ typeclass_info_map := NewTypeClassInfoMap),
+ MaybeVar = yes(NewVar)
).
-:- pred polymorphism__make_typeclass_info_from_proof(class_constraint,
- list(class_constraint), constraint_proof, existq_tvars, prog_context,
- maybe(prog_var), list(hlds_goal), list(hlds_goal), poly_info,
- poly_info).
-:- mode polymorphism__make_typeclass_info_from_proof(in, in, in, in, in, out,
- in, out, in, out) is det.
+:- pred polymorphism__make_typeclass_info_from_proof(class_constraint::in,
+ list(class_constraint)::in, constraint_proof::in, existq_tvars::in,
+ prog_context::in, maybe(prog_var)::out,
+ list(hlds_goal)::in, list(hlds_goal)::out,
+ poly_info::in, poly_info::out) is det.
polymorphism__make_typeclass_info_from_proof(Constraint, Seen, Proof,
- ExistQVars, Context, MaybeVar, ExtraGoals0, ExtraGoals,
- Info0, Info) :-
- Info0 = poly_info(VarSet0, VarTypes0, TypeVarSet, TypeInfoMap0,
+ ExistQVars, Context, MaybeVar, !ExtraGoals, !Info) :-
+ !.Info = poly_info(VarSet0, VarTypes0, TypeVarSet, TypeInfoMap0,
TypeClassInfoMap0, Proofs, PredName, ModuleInfo),
Constraint = constraint(ClassName, ConstrainedTypes),
list__length(ConstrainedTypes, ClassArity),
@@ -2298,38 +2167,29 @@
UnconstrainedTypes1, InstanceSubst,
UnconstrainedTypes),
- map__overlay(Proofs, SuperClassProofs2,
- SuperClassProofs),
+ map__overlay(Proofs, SuperClassProofs2, SuperClassProofs),
% Make the type_infos for the types
% that are constrained by this. These
% are packaged in the typeclass_info
- polymorphism__make_type_info_vars(
- ConstrainedTypes, Context,
- InstanceExtraTypeInfoVars, TypeInfoGoals,
- Info0, Info1),
+ polymorphism__make_type_info_vars(ConstrainedTypes, Context,
+ InstanceExtraTypeInfoVars, TypeInfoGoals, !Info),
% Make the typeclass_infos for the
% constraints from the context of the
% instance decl.
- polymorphism__make_typeclass_info_vars_2(
- InstanceConstraints, Seen,
- ExistQVars, Context,
- [], InstanceExtraTypeClassInfoVars0,
- ExtraGoals0, ExtraGoals1,
- Info1, Info2),
+ polymorphism__make_typeclass_info_vars_2(InstanceConstraints,
+ Seen, ExistQVars, Context, [],
+ InstanceExtraTypeClassInfoVars0, !ExtraGoals, !Info),
% Make the type_infos for the unconstrained
% type variables from the head of the
% instance declaration
- polymorphism__make_type_info_vars(
- UnconstrainedTypes, Context,
+ polymorphism__make_type_info_vars(UnconstrainedTypes, Context,
InstanceExtraTypeInfoUnconstrainedVars,
- UnconstrainedTypeInfoGoals,
- Info2, Info3),
+ UnconstrainedTypeInfoGoals, !Info),
- % The variables are built up in
- % reverse order.
+ % The variables are built up in reverse order.
list__reverse(InstanceExtraTypeClassInfoVars0,
InstanceExtraTypeClassInfoVars),
@@ -2337,23 +2197,19 @@
InstanceExtraTypeInfoUnconstrainedVars,
InstanceExtraTypeInfoVars,
InstanceExtraTypeClassInfoVars,
- ClassId, Constraint, InstanceNum,
- ConstrainedTypes,
- SuperClassProofs, ExistQVars, Var, NewGoals,
- Info3, Info),
+ ClassId, Constraint, InstanceNum, ConstrainedTypes,
+ SuperClassProofs, ExistQVars, Var, NewGoals, !Info),
MaybeVar = yes(Var),
- % Oh, yuck. The type_info goals have
- % already been reversed, so lets
- % reverse them back.
+ % Oh, yuck. The type_info goals have already been
+ % reversed, so lets reverse them back.
list__reverse(TypeInfoGoals, RevTypeInfoGoals),
list__reverse(UnconstrainedTypeInfoGoals,
RevUnconstrainedTypeInfoGoals),
- list__condense([RevUnconstrainedTypeInfoGoals,
- NewGoals, ExtraGoals1, RevTypeInfoGoals],
- ExtraGoals)
+ list__condense([RevUnconstrainedTypeInfoGoals, NewGoals,
+ !.ExtraGoals, RevTypeInfoGoals], !:ExtraGoals)
;
% We have to extract the typeclass_info from
% another one
@@ -2362,9 +2218,9 @@
% First create a variable to hold the new
% typeclass_info
unqualify_name(ClassName, ClassNameString),
- polymorphism__new_typeclass_info_var(VarSet0,
- VarTypes0, Constraint, ClassNameString,
- Var, VarSet1, VarTypes1),
+ polymorphism__new_typeclass_info_var(Constraint,
+ ClassNameString, Var, VarSet0, VarSet1,
+ VarTypes0, VarTypes1),
MaybeVar = yes(Var),
@@ -2374,7 +2230,7 @@
list__length(SubClassTypes, SubClassArity),
SubClassId = class_id(SubClassName, SubClassArity),
- Info1 = poly_info(VarSet1, VarTypes1, TypeVarSet,
+ !:Info = poly_info(VarSet1, VarTypes1, TypeVarSet,
TypeInfoMap0, TypeClassInfoMap0, Proofs,
PredName, ModuleInfo),
@@ -2382,9 +2238,7 @@
polymorphism__make_typeclass_info_var(
SubClassConstraint, Seen,
ExistQVars, Context,
- ExtraGoals0, ExtraGoals1,
- Info1, Info2,
- MaybeSubClassVar),
+ !ExtraGoals, !Info, MaybeSubClassVar),
( MaybeSubClassVar = yes(SubClassVar0) ->
SubClassVar = SubClassVar0
;
@@ -2404,23 +2258,23 @@
apply_subst_to_constraint_list(SubTypeSubst,
SuperClasses0, SuperClasses),
(
- list__nth_member_search(SuperClasses,
- Constraint, SuperClassIndex0)
+ list__nth_member_search(SuperClasses, Constraint,
+ SuperClassIndex0)
->
SuperClassIndex0 = SuperClassIndex
;
% We shouldn't have got this far if
% the constraints were not satisfied
- error("polymorphism.m: constraint not in constraint list")
+ error("polymorphism.m: constraint " ++
+ "not in constraint list")
),
- poly_info_get_varset(Info2, VarSet2),
- poly_info_get_var_types(Info2, VarTypes2),
+ poly_info_get_varset(!.Info, VarSet2),
+ poly_info_get_var_types(!.Info, VarTypes2),
make_int_const_construction(SuperClassIndex,
yes("SuperClassIndex"), IndexGoal, IndexVar,
VarTypes2, VarTypes, VarSet2, VarSet),
- poly_info_set_varset_and_types(VarSet, VarTypes,
- Info2, Info),
+ poly_info_set_varset_and_types(VarSet, VarTypes, !Info),
% We extract the superclass typeclass_info by
% inserting a call to
@@ -2429,40 +2283,38 @@
% Note that superclass_from_typeclass_info
% does not need extra type_info arguments
% even though its declaration is polymorphic.
-
goal_util__generate_simple_call(mercury_private_builtin_module,
"superclass_from_typeclass_info", predicate,
[SubClassVar, IndexVar, Var], only_mode, det, no,
[], ModuleInfo, term__context_init, SuperClassGoal),
% Add it to the accumulator
- ExtraGoals = [SuperClassGoal,IndexGoal|ExtraGoals1]
+ !:ExtraGoals = [SuperClassGoal, IndexGoal | !.ExtraGoals]
).
-:- pred polymorphism__construct_typeclass_info(list(prog_var), list(prog_var),
- list(prog_var), class_id, class_constraint, int,
- list(type), map(class_constraint, constraint_proof),
- existq_tvars, prog_var, list(hlds_goal), poly_info, poly_info).
-:- mode polymorphism__construct_typeclass_info(in, in, in, in, in,
- in, in, in, in, out, out, in, out) is det.
+:- pred polymorphism__construct_typeclass_info(list(prog_var)::in,
+ list(prog_var)::in, list(prog_var)::in, class_id::in,
+ class_constraint::in, int::in, list(type)::in,
+ map(class_constraint, constraint_proof)::in, existq_tvars::in,
+ prog_var::out, list(hlds_goal)::out, poly_info::in, poly_info::out)
+ is det.
polymorphism__construct_typeclass_info(ArgUnconstrainedTypeInfoVars,
- ArgTypeInfoVars, ArgTypeClassInfoVars,
- ClassId, Constraint, InstanceNum,
- InstanceTypes, SuperClassProofs, ExistQVars,
- NewVar, NewGoals, Info0, Info) :-
+ ArgTypeInfoVars, ArgTypeClassInfoVars, ClassId, Constraint,
+ InstanceNum, InstanceTypes, SuperClassProofs, ExistQVars,
+ NewVar, NewGoals, !Info) :-
- poly_info_get_module_info(Info0, ModuleInfo),
+ poly_info_get_module_info(!.Info, ModuleInfo),
module_info_classes(ModuleInfo, ClassTable),
map__lookup(ClassTable, ClassId, ClassDefn),
polymorphism__get_arg_superclass_vars(ClassDefn, InstanceTypes,
SuperClassProofs, ExistQVars, ArgSuperClassVars,
- SuperClassGoals, Info0, Info1),
+ SuperClassGoals, !Info),
- poly_info_get_varset(Info1, VarSet0),
- poly_info_get_var_types(Info1, VarTypes0),
+ poly_info_get_varset(!.Info, VarSet0),
+ poly_info_get_var_types(!.Info, VarTypes0),
% lay out the argument variables as expected in the
% typeclass_info
@@ -2473,14 +2325,13 @@
ClassId = class_id(ClassName, _Arity),
unqualify_name(ClassName, ClassNameString),
- polymorphism__new_typeclass_info_var(VarSet0, VarTypes0,
- Constraint, ClassNameString, BaseVar, VarSet1, VarTypes1),
+ polymorphism__new_typeclass_info_var(Constraint, ClassNameString,
+ BaseVar, VarSet0, VarSet1, VarTypes0, VarTypes1),
module_info_instances(ModuleInfo, InstanceTable),
map__lookup(InstanceTable, ClassId, InstanceList),
list__index1_det(InstanceList, InstanceNum, InstanceDefn),
- InstanceDefn = hlds_instance_defn(InstanceModuleName,
- _, _, _, _, _, _, _, _),
+ InstanceModuleName = InstanceDefn ^ instance_module,
base_typeclass_info__make_instance_string(InstanceTypes,
InstanceString),
ConsId = base_typeclass_info_const(InstanceModuleName, ClassId,
@@ -2508,12 +2359,12 @@
% build a unification to add the argvars to the
% base_typeclass_info
NewConsId = typeclass_info_cell_constructor,
- NewArgVars = [BaseVar|ArgVars],
+ NewArgVars = [BaseVar | ArgVars],
TypeClassInfoTerm = functor(NewConsId, no, NewArgVars),
% introduce a new variable
- polymorphism__new_typeclass_info_var(VarSet1, VarTypes1,
- Constraint, ClassNameString, NewVar, VarSet, VarTypes),
+ polymorphism__new_typeclass_info_var(Constraint, ClassNameString,
+ NewVar, VarSet1, VarSet, VarTypes1, VarTypes),
% create the construction unification to initialize the
% variable
@@ -2527,8 +2378,8 @@
(ground(shared, none) -> ground(shared, none)),
UnifyContext = unify_context(explicit, []),
% XXX the UnifyContext is wrong
- Unify = unify(NewVar, TypeClassInfoTerm, UnifyMode,
- Unification, UnifyContext),
+ Unify = unify(NewVar, TypeClassInfoTerm, UnifyMode, Unification,
+ UnifyContext),
% create a goal_info for the unification
goal_info_init(GoalInfo0),
@@ -2540,8 +2391,7 @@
% difference.
InstConsId = cell_inst_cons_id(typeclass_info_cell, NumArgVars),
instmap_delta_from_assoc_list(
- [NewVar -
- bound(unique, [functor(InstConsId, ArgInsts)])],
+ [NewVar - bound(unique, [functor(InstConsId, ArgInsts)])],
InstMapDelta),
goal_info_set_instmap_delta(GoalInfo1, InstMapDelta, GoalInfo2),
goal_info_set_determinism(GoalInfo2, det, GoalInfo),
@@ -2549,27 +2399,26 @@
TypeClassInfoGoal = Unify - GoalInfo,
NewGoals0 = [TypeClassInfoGoal, BaseGoal],
list__append(NewGoals0, SuperClassGoals, NewGoals),
- poly_info_set_varset_and_types(VarSet, VarTypes, Info1, Info).
+ poly_info_set_varset_and_types(VarSet, VarTypes, !Info).
%---------------------------------------------------------------------------%
-:- pred polymorphism__get_arg_superclass_vars(hlds_class_defn, list(type),
- map(class_constraint, constraint_proof), existq_tvars,
- list(prog_var), list(hlds_goal), poly_info, poly_info).
-:- mode polymorphism__get_arg_superclass_vars(in, in, in, in, out, out,
- in, out) is det.
+:- pred polymorphism__get_arg_superclass_vars(hlds_class_defn::in,
+ list(type)::in, map(class_constraint, constraint_proof)::in,
+ existq_tvars::in, list(prog_var)::out, list(hlds_goal)::out,
+ poly_info::in, poly_info::out) is det.
polymorphism__get_arg_superclass_vars(ClassDefn, InstanceTypes,
- SuperClassProofs, ExistQVars, NewVars, NewGoals,
- Info0, Info) :-
+ SuperClassProofs, ExistQVars, NewVars, NewGoals, !Info) :-
- poly_info_get_proofs(Info0, Proofs),
+ poly_info_get_proofs(!.Info, Proofs),
- poly_info_get_typevarset(Info0, TVarSet0),
- ClassDefn = hlds_class_defn(_, SuperClasses0, ClassVars0,
- _, _, ClassTVarSet, _),
+ poly_info_get_typevarset(!.Info, TVarSet0),
+ SuperClasses0 = ClassDefn ^ class_supers,
+ ClassVars0 = ClassDefn ^ class_vars,
+ ClassTVarSet = ClassDefn ^ class_tvarset,
varset__merge_subst(TVarSet0, ClassTVarSet, TVarSet1, Subst),
- poly_info_set_typevarset(TVarSet1, Info0, Info1),
+ poly_info_set_typevarset(TVarSet1, !Info),
map__apply_to_list(ClassVars0, Subst, ClassVars1),
term__vars_list(ClassVars1, ClassVars),
@@ -2579,34 +2428,30 @@
apply_rec_subst_to_constraint_list(TypeSubst, SuperClasses1,
SuperClasses),
- poly_info_set_proofs(SuperClassProofs, Info1, Info2),
+ poly_info_set_proofs(SuperClassProofs, !Info),
polymorphism__make_superclasses_from_proofs(SuperClasses,
- ExistQVars, [], NewGoals, Info2, Info3,
- [], NewVars),
+ ExistQVars, [], NewGoals, !Info, [], NewVars),
- poly_info_set_proofs(Proofs, Info3, Info).
+ poly_info_set_proofs(Proofs, !Info).
+:- pred polymorphism__make_superclasses_from_proofs(list(class_constraint)::in,
+ existq_tvars::in, list(hlds_goal)::in, list(hlds_goal)::out,
+ poly_info::in, poly_info::out, list(prog_var)::in, list(prog_var)::out)
+ is det.
-:- pred polymorphism__make_superclasses_from_proofs(list(class_constraint),
- existq_tvars, list(hlds_goal), list(hlds_goal),
- poly_info, poly_info, list(prog_var), list(prog_var)).
-:- mode polymorphism__make_superclasses_from_proofs(in, in, in, out,
- in, out, in, out) is det.
-
-polymorphism__make_superclasses_from_proofs([], _,
- Goals, Goals, Info, Info, Vars, Vars).
-polymorphism__make_superclasses_from_proofs([C|Cs],
- ExistQVars, Goals0, Goals, Info0, Info, Vars0, Vars) :-
- polymorphism__make_superclasses_from_proofs(Cs,
- ExistQVars, Goals0, Goals1, Info0, Info1, Vars0, Vars1),
+polymorphism__make_superclasses_from_proofs([], _, !Goals, !Info, !Vars).
+polymorphism__make_superclasses_from_proofs([Constraint | Constraints],
+ ExistQVars, !Goals, !Info, !Vars) :-
+ polymorphism__make_superclasses_from_proofs(Constraints,
+ ExistQVars, !Goals, !Info, !Vars),
term__context_init(Context),
- polymorphism__make_typeclass_info_var(C, [],
- ExistQVars, Context, Goals1, Goals, Info1, Info,
- MaybeVar),
- maybe_insert_var(MaybeVar, Vars1, Vars).
+ polymorphism__make_typeclass_info_var(Constraint, [],
+ ExistQVars, Context, !Goals, !Info, MaybeVar),
+ maybe_insert_var(MaybeVar, !Vars).
+
+:- pred maybe_insert_var(maybe(prog_var)::in, list(prog_var)::in,
+ list(prog_var)::out) is det.
-:- pred maybe_insert_var(maybe(prog_var), list(prog_var), list(prog_var)).
-:- mode maybe_insert_var(in, in, out) is det.
maybe_insert_var(no, Vars, Vars).
maybe_insert_var(yes(Var), Vars, [Var | Vars]).
@@ -2615,24 +2460,21 @@
% Produce the typeclass_infos for the existential class
% constraints for a call or deconstruction unification.
:- pred polymorphism__make_existq_typeclass_info_vars(
- list(class_constraint), list(prog_var), list(hlds_goal),
- poly_info, poly_info).
-:- mode polymorphism__make_existq_typeclass_info_vars(in, out, out,
- in, out) is det.
+ list(class_constraint)::in, list(prog_var)::out, list(hlds_goal)::out,
+ poly_info::in, poly_info::out) is det.
-polymorphism__make_existq_typeclass_info_vars(
- ExistentialConstraints, ExtraTypeClassVars,
- ExtraGoals, PolyInfo0, PolyInfo) :-
- poly_info_get_type_info_map(PolyInfo0, OldTypeInfoMap),
+polymorphism__make_existq_typeclass_info_vars(ExistentialConstraints,
+ ExtraTypeClassVars, ExtraGoals, !Info) :-
+ poly_info_get_type_info_map(!.Info, OldTypeInfoMap),
polymorphism__make_typeclass_info_head_vars(ExistentialConstraints,
- ExtraTypeClassVars, PolyInfo0, PolyInfo1),
+ ExtraTypeClassVars, !Info),
polymorphism__update_typeclass_infos(ExistentialConstraints,
- ExtraTypeClassVars, PolyInfo1, PolyInfo2),
+ ExtraTypeClassVars, !Info),
constraint_list_get_tvars(ExistentialConstraints, TVars0),
list__sort_and_remove_dups(TVars0, TVars),
list__foldl2(polymorphism__maybe_extract_type_info(OldTypeInfoMap),
- TVars, [], ExtraGoals, PolyInfo2, PolyInfo).
+ TVars, [], ExtraGoals, !Info).
% For code which requires mode reordering, we may have already
% seen uses of some of the type variables produced by this call.
@@ -2640,27 +2482,25 @@
% before, we assume that it is unconstrained. If it turns out that
% the type variable is constrained, and the type_info is contained
% in a typeclass_info, we need to generate code to extract it here.
-:- pred polymorphism__maybe_extract_type_info(type_info_varmap,
- tvar, list(hlds_goal), list(hlds_goal),
- poly_info, poly_info).
-:- mode polymorphism__maybe_extract_type_info(in, in, in, out, in, out) is det.
-
-polymorphism__maybe_extract_type_info(OldTypeInfoMap, TVar,
- ExtraGoals0, ExtraGoals, Info0, Info) :-
- poly_info_get_type_info_map(Info0, TypeInfoMap),
+:- pred polymorphism__maybe_extract_type_info(type_info_varmap::in,
+ tvar::in, list(hlds_goal)::in, list(hlds_goal)::out,
+ poly_info::in, poly_info::out) is det.
+
+polymorphism__maybe_extract_type_info(OldTypeInfoMap, TVar, !ExtraGoals,
+ !Info) :-
+ poly_info_get_type_info_map(!.Info, TypeInfoMap),
(
map__search(OldTypeInfoMap, TVar, type_info(TypeInfoVar0)),
map__search(TypeInfoMap, TVar,
typeclass_info(TypeClassInfoVar, Index))
->
extract_type_info(TVar, TypeClassInfoVar,
- Index, ExtraGoals1, TypeInfoVar1, Info0, Info),
+ Index, NewGoals, TypeInfoVar1, !Info),
polymorphism__assign_var(TypeInfoVar0,
TypeInfoVar1, AssignGoal),
- ExtraGoals = ExtraGoals1 ++ [AssignGoal | ExtraGoals0]
+ !:ExtraGoals = NewGoals ++ [AssignGoal | !.ExtraGoals]
;
- ExtraGoals = ExtraGoals0,
- Info = Info0
+ true
).
%---------------------------------------------------------------------------%
@@ -2670,18 +2510,17 @@
% variables to the appropriate type_info structures for the types.
% Update the varset and vartypes accordingly.
-polymorphism__make_type_info_vars([], _, [], [], Info, Info).
+polymorphism__make_type_info_vars([], _, [], [], !Info).
polymorphism__make_type_info_vars([Type | Types], Context,
- ExtraVars, ExtraGoals, Info0, Info) :-
+ ExtraVars, ExtraGoals, !Info) :-
polymorphism__make_type_info_var(Type, Context,
- Var, ExtraGoals1, Info0, Info1),
+ Var, ExtraGoals1, !Info),
polymorphism__make_type_info_vars(Types, Context,
- ExtraVars2, ExtraGoals2, Info1, Info),
+ ExtraVars2, ExtraGoals2, !Info),
ExtraVars = [Var | ExtraVars2],
list__append(ExtraGoals1, ExtraGoals2, ExtraGoals).
-polymorphism__make_type_info_var(Type, Context, Var, ExtraGoals,
- Info0, Info) :-
+polymorphism__make_type_info_var(Type, Context, Var, ExtraGoals, !Info) :-
%
% First handle statically known types
% (i.e. types which are not type variables)
@@ -2702,7 +2541,7 @@
% we should not ignore the purity of higher order procs;
% it should get included in the RTTI.
polymorphism__construct_type_info(Type, TypeCtor, TypeArgs,
- yes, Context, Var, ExtraGoals, Info0, Info)
+ yes, Context, Var, ExtraGoals, !Info)
; type_to_ctor_and_args(Type, TypeCtor, TypeArgs) ->
% This occurs for code where a predicate calls a polymorphic
% predicate with a known value of the type variable.
@@ -2710,7 +2549,7 @@
% at the top of the module.
polymorphism__construct_type_info(Type, TypeCtor, TypeArgs,
- no, Context, Var, ExtraGoals, Info0, Info)
+ no, Context, Var, ExtraGoals, !Info)
;
%
% Now handle the cases of types which are not known statically
@@ -2718,26 +2557,24 @@
%
Type = term__variable(TypeVar)
->
- get_type_info_locn(TypeVar, TypeInfoLocn, Info0, Info1),
- get_type_info(TypeInfoLocn, TypeVar, ExtraGoals, Var,
- Info1, Info)
+ get_type_info_locn(TypeVar, TypeInfoLocn, !Info),
+ get_type_info(TypeInfoLocn, TypeVar, ExtraGoals, Var, !Info)
;
error("polymorphism__make_var: unknown type")
).
-:- pred get_type_info_locn(tvar, type_info_locn, poly_info, poly_info).
-:- mode get_type_info_locn(in, out, in, out) is det.
+:- pred get_type_info_locn(tvar::in, type_info_locn::out,
+ poly_info::in, poly_info::out) is det.
-get_type_info_locn(TypeVar, TypeInfoLocn, Info0, Info) :-
+get_type_info_locn(TypeVar, TypeInfoLocn, !Info) :-
%
% If we have already allocated a location for this type_info,
% then all we need to do is to extract the type_info variable
% from its location.
%
- poly_info_get_type_info_map(Info0, TypeInfoMap0),
+ poly_info_get_type_info_map(!.Info, TypeInfoMap0),
( map__search(TypeInfoMap0, TypeVar, TypeInfoLocn0) ->
- TypeInfoLocn = TypeInfoLocn0,
- Info = Info0
+ TypeInfoLocn = TypeInfoLocn0
;
%
% Otherwise, we need to create a new type_info
@@ -2754,30 +2591,26 @@
% the typeclass_info is created.
%
type_util__var(Type, TypeVar),
- polymorphism__new_type_info_var(Type, type_info,
- Var, Info0, Info1),
+ polymorphism__new_type_info_var(Type, type_info, Var, !Info),
TypeInfoLocn = type_info(Var),
map__det_insert(TypeInfoMap0, TypeVar, TypeInfoLocn,
TypeInfoMap),
- poly_info_set_type_info_map(TypeInfoMap, Info1, Info)
+ poly_info_set_type_info_map(TypeInfoMap, !Info)
).
-:- pred polymorphism__construct_type_info(type, type_ctor, list(type),
- bool, prog_context, prog_var, list(hlds_goal),
- poly_info, poly_info).
-:- mode polymorphism__construct_type_info(in, in, in, in, in, out, out,
- in, out) is det.
+:- pred polymorphism__construct_type_info((type)::in, type_ctor::in,
+ list(type)::in, bool::in, prog_context::in, prog_var::out,
+ list(hlds_goal)::out, poly_info::in, poly_info::out) is det.
polymorphism__construct_type_info(Type, TypeCtor, TypeArgs,
- TypeCtorIsVarArity, Context, Var, ExtraGoals, Info0, Info) :-
-
+ TypeCtorIsVarArity, Context, Var, ExtraGoals, !Info) :-
% Create the typeinfo vars for the arguments
polymorphism__make_type_info_vars(TypeArgs, Context,
- ArgTypeInfoVars, ArgTypeInfoGoals, Info0, Info1),
+ ArgTypeInfoVars, ArgTypeInfoGoals, !Info),
- poly_info_get_varset(Info1, VarSet1),
- poly_info_get_var_types(Info1, VarTypes1),
- poly_info_get_module_info(Info1, ModuleInfo),
+ poly_info_get_varset(!.Info, VarSet1),
+ poly_info_get_var_types(!.Info, VarTypes1),
+ poly_info_get_module_info(!.Info, ModuleInfo),
polymorphism__init_const_type_ctor_info_var(Type, TypeCtor,
TypeCtorVar, TypeCtorGoal, ModuleInfo,
@@ -2787,7 +2620,7 @@
VarSet2, VarSet, VarTypes2, VarTypes,
ArgTypeInfoGoals, [TypeCtorGoal], ExtraGoals),
- poly_info_set_varset_and_types(VarSet, VarTypes, Info1, Info).
+ poly_info_set_varset_and_types(VarSet, VarTypes, !Info).
% maybe_init_second_cell(Type, TypeCtorVar, TypeCtorIsVarArity,
% ArgTypeInfoVars, Context, Var, VarSet0, VarSet,
@@ -2892,8 +2725,8 @@
map__search(SpecialPredMap, SpecialPredId - TypeCtor,
PredId)
;
- error(
- "polymorphism__get_special_proc: type_to_ctor_and_args failed")
+ error("polymorphism__get_special_proc: " ++
+ "type_to_ctor_and_args failed")
),
module_info_pred_info(ModuleInfo, PredId, PredInfo),
pred_info_module(PredInfo, Module),
@@ -3005,41 +2838,39 @@
%---------------------------------------------------------------------------%
-:- pred polymorphism__make_head_vars(list(tvar), tvarset, list(prog_var),
- poly_info, poly_info).
-:- mode polymorphism__make_head_vars(in, in, out, in, out) is det.
-
-polymorphism__make_head_vars([], _, []) --> [].
-polymorphism__make_head_vars([TypeVar|TypeVars], TypeVarSet, TypeInfoVars) -->
- { Type = term__variable(TypeVar) },
- polymorphism__new_type_info_var(Type, type_info, Var),
- ( { varset__search_name(TypeVarSet, TypeVar, TypeVarName) } ->
- =(Info0),
- { poly_info_get_varset(Info0, VarSet0) },
- { string__append("TypeInfo_for_", TypeVarName, VarName) },
- { varset__name_var(VarSet0, Var, VarName, VarSet) },
- poly_info_set_varset(VarSet)
- ;
- []
- ),
- { TypeInfoVars = [Var | TypeInfoVars1] },
- polymorphism__make_head_vars(TypeVars, TypeVarSet, TypeInfoVars1).
-
-:- pred polymorphism__new_type_info_var(type, type_info_kind, prog_var,
- poly_info, poly_info).
-:- mode polymorphism__new_type_info_var(in, in, out, in, out) is det.
-
-polymorphism__new_type_info_var(Type, Kind, Var, Info0, Info) :-
- poly_info_get_varset(Info0, VarSet0),
- poly_info_get_var_types(Info0, VarTypes0),
+:- pred polymorphism__make_head_vars(list(tvar)::in, tvarset::in,
+ list(prog_var)::out, poly_info::in, poly_info::out) is det.
+
+polymorphism__make_head_vars([], _, [], !Info).
+polymorphism__make_head_vars([TypeVar | TypeVars], TypeVarSet, TypeInfoVars,
+ !Info) :-
+ Type = term__variable(TypeVar),
+ polymorphism__new_type_info_var(Type, type_info, Var, !Info),
+ ( varset__search_name(TypeVarSet, TypeVar, TypeVarName) ->
+ poly_info_get_varset(!.Info, VarSet0),
+ string__append("TypeInfo_for_", TypeVarName, VarName),
+ varset__name_var(VarSet0, Var, VarName, VarSet),
+ poly_info_set_varset(VarSet, !Info)
+ ;
+ true
+ ),
+ polymorphism__make_head_vars(TypeVars, TypeVarSet, TypeInfoVars1,
+ !Info),
+ TypeInfoVars = [Var | TypeInfoVars1].
+
+:- pred polymorphism__new_type_info_var((type)::in, type_info_kind::in,
+ prog_var::out, poly_info::in, poly_info::out) is det.
+
+polymorphism__new_type_info_var(Type, Kind, Var, !Info) :-
+ poly_info_get_varset(!.Info, VarSet0),
+ poly_info_get_var_types(!.Info, VarTypes0),
polymorphism__new_type_info_var_raw(Type, Kind, Var,
VarSet0, VarSet, VarTypes0, VarTypes),
- poly_info_set_varset_and_types(VarSet, VarTypes, Info0, Info).
+ poly_info_set_varset_and_types(VarSet, VarTypes, !Info).
-polymorphism__new_type_info_var_raw(Type, Kind, Var,
- VarSet0, VarSet, VarTypes0, VarTypes) :-
+polymorphism__new_type_info_var_raw(Type, Kind, Var, !VarSet, !VarTypes) :-
% introduce new variable
- varset__new_var(VarSet0, Var, VarSet1),
+ varset__new_var(!.VarSet, Var, !:VarSet),
term__var_to_int(Var, VarNum),
string__int_to_string(VarNum, VarNumStr),
(
@@ -3050,9 +2881,9 @@
Prefix = typectorinfo_prefix
),
string__append(Prefix, VarNumStr, Name),
- varset__name_var(VarSet1, Var, Name, VarSet),
+ varset__name_var(!.VarSet, Var, Name, !:VarSet),
polymorphism__build_type_info_type(Kind, Type, TypeInfoType),
- map__set(VarTypes0, Var, TypeInfoType, VarTypes).
+ map__set(!.VarTypes, Var, TypeInfoType, !:VarTypes).
:- func typeinfo_prefix = string.
@@ -3069,52 +2900,46 @@
:- pred get_type_info(type_info_locn::in, tvar::in, list(hlds_goal)::out,
prog_var::out, poly_info::in, poly_info::out) is det.
-get_type_info(TypeInfoLocn, TypeVar, ExtraGoals, Var, Info0, Info) :-
+get_type_info(TypeInfoLocn, TypeVar, ExtraGoals, Var, !Info) :-
(
% If the typeinfo is available in a variable,
% just use it
TypeInfoLocn = type_info(TypeInfoVar),
Var = TypeInfoVar,
- ExtraGoals = [],
- Info = Info0
+ ExtraGoals = []
;
% If the typeinfo is in a typeclass_info, then
% we need to extract it before using it
TypeInfoLocn = typeclass_info(TypeClassInfoVar, Index),
extract_type_info(TypeVar, TypeClassInfoVar,
- Index, ExtraGoals, Var, Info0, Info)
+ Index, ExtraGoals, Var, !Info)
).
-:- pred extract_type_info(tvar, prog_var, int, list(hlds_goal),
- prog_var, poly_info, poly_info).
-:- mode extract_type_info(in, in, in, out, out, in, out) is det.
-
-extract_type_info(TypeVar, TypeClassInfoVar, Index, Goals,
- TypeInfoVar, PolyInfo0, PolyInfo) :-
- poly_info_get_varset(PolyInfo0, VarSet0),
- poly_info_get_var_types(PolyInfo0, VarTypes0),
- poly_info_get_module_info(PolyInfo0, ModuleInfo),
+:- pred extract_type_info(tvar::in, prog_var::in, int::in,
+ list(hlds_goal)::out, prog_var::out, poly_info::in, poly_info::out)
+ is det.
+
+extract_type_info(TypeVar, TypeClassInfoVar, Index, Goals, TypeInfoVar,
+ !Info) :-
+ poly_info_get_varset(!.Info, VarSet0),
+ poly_info_get_var_types(!.Info, VarTypes0),
+ poly_info_get_module_info(!.Info, ModuleInfo),
polymorphism__gen_extract_type_info(TypeVar, TypeClassInfoVar, Index,
ModuleInfo, Goals, TypeInfoVar,
- VarSet0, VarTypes0, VarSet, VarTypes),
- poly_info_set_varset_and_types(VarSet, VarTypes, PolyInfo0, PolyInfo).
+ VarSet0, VarSet, VarTypes0, VarTypes),
+ poly_info_set_varset_and_types(VarSet, VarTypes, !Info).
polymorphism__gen_extract_type_info(TypeVar, TypeClassInfoVar, Index,
- ModuleInfo, Goals, TypeInfoVar,
- VarSet0, VarTypes0, VarSet, VarTypes) :-
-
+ ModuleInfo, Goals, TypeInfoVar, !VarSet, !VarTypes) :-
make_int_const_construction(Index, yes("TypeInfoIndex"),
- IndexGoal, IndexVar, VarTypes0, VarTypes1, VarSet0, VarSet1),
-
+ IndexGoal, IndexVar, !VarTypes, !VarSet),
polymorphism__new_type_info_var_raw(term__variable(TypeVar), type_info,
- TypeInfoVar, VarSet1, VarSet, VarTypes1, VarTypes),
-
+ TypeInfoVar, !VarSet, !VarTypes),
goal_util__generate_simple_call(mercury_private_builtin_module,
"type_info_from_typeclass_info", predicate,
[TypeClassInfoVar, IndexVar, TypeInfoVar], only_mode, det, no,
[TypeInfoVar - ground(shared, none)], ModuleInfo,
term__context_init, CallGoal),
-
Goals = [IndexGoal, CallGoal].
%-----------------------------------------------------------------------------%
@@ -3122,34 +2947,29 @@
% Create a head var for each class constraint, and make an entry in
% the typeinfo locations map for each constrained type var.
-:- pred polymorphism__make_typeclass_info_head_vars(list(class_constraint),
- list(prog_var), poly_info, poly_info).
-:- mode polymorphism__make_typeclass_info_head_vars(in, out, in, out)
- is det.
+:- pred polymorphism__make_typeclass_info_head_vars(
+ list(class_constraint)::in, list(prog_var)::out,
+ poly_info::in, poly_info::out) is det.
-polymorphism__make_typeclass_info_head_vars(Constraints, ExtraHeadVars) -->
+polymorphism__make_typeclass_info_head_vars(Constraints, ExtraHeadVars,
+ !Info) :-
list__map_foldl(polymorphism__make_typeclass_info_head_var,
- Constraints, ExtraHeadVars).
+ Constraints, ExtraHeadVars, !Info).
-:- pred polymorphism__make_typeclass_info_head_var(class_constraint,
- prog_var, poly_info, poly_info).
-:- mode polymorphism__make_typeclass_info_head_var(in, out, in, out) is det.
+:- pred polymorphism__make_typeclass_info_head_var(class_constraint::in,
+ prog_var::out, poly_info::in, poly_info::out) is det.
-polymorphism__make_typeclass_info_head_var(C, ExtraHeadVar, Info0, Info) :-
+polymorphism__make_typeclass_info_head_var(Constraint, ExtraHeadVar, !Info) :-
+ poly_info_get_typeclass_info_map(!.Info, TypeClassInfoMap),
+ ( map__search(TypeClassInfoMap, Constraint, ExistingVar) ->
+ ExtraHeadVar = ExistingVar
+ ;
+ poly_info_get_varset(!.Info, VarSet0),
+ poly_info_get_var_types(!.Info, VarTypes0),
+ poly_info_get_type_info_map(!.Info, TypeInfoMap0),
+ poly_info_get_module_info(!.Info, ModuleInfo),
- poly_info_get_typeclass_info_map(Info0, TypeClassInfoMap),
- (
- map__search(TypeClassInfoMap, C, ExistingVar)
- ->
- ExtraHeadVar = ExistingVar,
- Info = Info0
- ;
- poly_info_get_varset(Info0, VarSet0),
- poly_info_get_var_types(Info0, VarTypes0),
- poly_info_get_type_info_map(Info0, TypeInfoMap0),
- poly_info_get_module_info(Info0, ModuleInfo),
-
- C = constraint(ClassName0, ClassTypes),
+ Constraint = constraint(ClassName0, ClassTypes),
% Work out how many superclass the class has
list__length(ClassTypes, ClassArity),
@@ -3163,8 +2983,8 @@
% Make a new variable to contain the dictionary for
% this typeclass constraint
- polymorphism__new_typeclass_info_var(VarSet0, VarTypes0, C,
- ClassName, ExtraHeadVar, VarSet1, VarTypes1),
+ polymorphism__new_typeclass_info_var(Constraint, ClassName,
+ ExtraHeadVar, VarSet0, VarSet1, VarTypes0, VarTypes1),
% Find all the type variables in the constraint, and
% remember what index they appear in in the typeclass
@@ -3186,7 +3006,6 @@
list__map_foldl(MakeIndex, ClassTypeVars0, ClassTypeVars,
First, _),
-
% Work out which type variables we haven't seen
% before, or which we assumed earlier would be
% produced in a type-info (this can happen for
@@ -3220,29 +3039,26 @@
list__foldl(MakeEntry, NewClassTypeVars, TypeInfoMap0,
TypeInfoMap1),
- poly_info_set_varset_and_types(VarSet1, VarTypes1, Info0,
- Info1),
- poly_info_set_type_info_map(TypeInfoMap1, Info1, Info)
+ poly_info_set_varset_and_types(VarSet1, VarTypes1, !Info),
+ poly_info_set_type_info_map(TypeInfoMap1, !Info)
).
:- pred is_pair(pair(_, _)::in) is det.
+
is_pair(_).
-:- pred polymorphism__new_typeclass_info_var(prog_varset, map(prog_var, type),
- class_constraint, string, prog_var,
- prog_varset, map(prog_var, type)).
-:- mode polymorphism__new_typeclass_info_var(in, in,
- in, in, out, out, out) is det.
+:- pred polymorphism__new_typeclass_info_var(class_constraint::in, string::in,
+ prog_var::out, prog_varset::in, prog_varset::out,
+ map(prog_var, type)::in, map(prog_var, type)::out) is det.
-polymorphism__new_typeclass_info_var(VarSet0, VarTypes0, Constraint,
- ClassString, Var, VarSet, VarTypes) :-
+polymorphism__new_typeclass_info_var(Constraint, ClassString, Var,
+ !VarSet, !VarTypes) :-
% introduce new variable
- varset__new_var(VarSet0, Var, VarSet1),
+ varset__new_var(!.VarSet, Var, !:VarSet),
string__append("TypeClassInfo_for_", ClassString, Name),
- varset__name_var(VarSet1, Var, Name, VarSet),
-
+ varset__name_var(!.VarSet, Var, Name, !:VarSet),
polymorphism__build_typeclass_info_type(Constraint, DictionaryType),
- map__set(VarTypes0, Var, DictionaryType, VarTypes).
+ map__set(!.VarTypes, Var, DictionaryType, !:VarTypes).
polymorphism__build_typeclass_info_type(Constraint, DictionaryType) :-
Constraint = constraint(SymName, ArgTypes),
@@ -3254,7 +3070,6 @@
PrivateBuiltin = mercury_private_builtin_module,
construct_qualified_term(qualified(PrivateBuiltin, "constraint"),
[ClassNameTerm | ArgTypes], ConstraintTerm),
-
construct_type(qualified(PrivateBuiltin, "typeclass_info") - 1,
[ConstraintTerm], DictionaryType).
@@ -3301,8 +3116,8 @@
),
polymorphism__build_type_info_type(Kind, Type, TypeInfoType).
-:- pred polymorphism__build_type_info_type(type_info_kind, (type), (type)).
-:- mode polymorphism__build_type_info_type(in, in, out) is det.
+:- pred polymorphism__build_type_info_type(type_info_kind::in,
+ (type)::in, (type)::out) is det.
polymorphism__build_type_info_type(Kind, Type, TypeInfoType) :-
(
@@ -3315,8 +3130,8 @@
%---------------------------------------------------------------------------%
-polymorphism__is_typeclass_info_manipulator(ModuleInfo,
- PredId, TypeClassManipulator) :-
+polymorphism__is_typeclass_info_manipulator(ModuleInfo, PredId,
+ TypeClassManipulator) :-
module_info_pred_info(ModuleInfo, PredId, PredInfo),
pred_info_module(PredInfo, mercury_private_builtin_module),
pred_info_name(PredInfo, PredName),
@@ -3341,46 +3156,48 @@
% The expansion involves inserting a class_method_call with the
% appropriate arguments, which is responsible for extracting the
% appropriate part of the dictionary.
-:- pred polymorphism__expand_class_method_bodies(module_info, module_info).
-:- mode polymorphism__expand_class_method_bodies(in, out) is det.
+:- pred polymorphism__expand_class_method_bodies(module_info::in,
+ module_info::out) is det.
-polymorphism__expand_class_method_bodies(ModuleInfo0, ModuleInfo) :-
- module_info_classes(ModuleInfo0, Classes),
- module_info_name(ModuleInfo0, ModuleName),
+polymorphism__expand_class_method_bodies(!ModuleInfo) :-
+ module_info_classes(!.ModuleInfo, Classes),
+ module_info_name(!.ModuleInfo, ModuleName),
map__keys(Classes, ClassIds0),
- module_info_globals(ModuleInfo0, Globals),
+ module_info_globals(!.ModuleInfo, Globals),
globals__lookup_bool_option(Globals, user_guided_type_specialization,
TypeSpec),
(
TypeSpec = no,
-
% Don't expand classes from other modules
- FromThisModule = lambda([ClassId::in] is semidet,
- (
- ClassId = class_id(qualified(ModuleName, _), _)
- )),
- list__filter(FromThisModule, ClassIds0, ClassIds)
+ list__filter(class_id_is_from_given_module(ModuleName),
+ ClassIds0, ClassIds)
;
TypeSpec = yes,
ClassIds = ClassIds0
),
map__apply_to_list(ClassIds, Classes, ClassDefns),
- list__foldl(expand_bodies, ClassDefns, ModuleInfo0, ModuleInfo).
+ list__foldl(expand_bodies, ClassDefns, !ModuleInfo).
-:- pred expand_bodies(hlds_class_defn, module_info, module_info).
-:- mode expand_bodies(in, in, out) is det.
+:- pred class_id_is_from_given_module(module_name::in, class_id::in)
+ is semidet.
-expand_bodies(hlds_class_defn(_, _, _, _, Interface, _, _),
- ModuleInfo0, ModuleInfo) :-
- list__foldl2(expand_one_body, Interface, 1, _, ModuleInfo0, ModuleInfo).
+class_id_is_from_given_module(ModuleName, ClassId) :-
+ ClassId = class_id(qualified(ModuleName, _), _).
-:- pred expand_one_body(hlds_class_proc, int, int, module_info, module_info).
-:- mode expand_one_body(in, in, out, in, out) is det.
+:- pred expand_bodies(hlds_class_defn::in, module_info::in, module_info::out)
+ is det.
-expand_one_body(hlds_class_proc(PredId, ProcId), ProcNum0, ProcNum,
- ModuleInfo0, ModuleInfo) :-
- module_info_preds(ModuleInfo0, PredTable0),
+expand_bodies(HLDSClassDefn, !ModuleInfo) :-
+ Interface = HLDSClassDefn ^ class_hlds_interface,
+ list__foldl2(expand_one_body, Interface, 1, _, !ModuleInfo).
+
+:- pred expand_one_body(hlds_class_proc::in, int::in, int::out,
+ module_info::in, module_info::out) is det.
+
+expand_one_body(hlds_class_proc(PredId, ProcId), !ProcNum, !ModuleInfo) :-
+ OldModuleInfo = !.ModuleInfo, % see XXX below
+ module_info_preds(!.ModuleInfo, PredTable0),
map__lookup(PredTable0, PredId, PredInfo0),
pred_info_procedures(PredInfo0, ProcTable0),
map__lookup(ProcTable0, ProcId, ProcInfo0),
@@ -3389,7 +3206,7 @@
% introduced because it is a class method.
pred_info_get_class_context(PredInfo0, ClassContext),
(
- ClassContext = constraints([Head|_], _)
+ ClassContext = constraints([Head | _], _)
->
InstanceConstraint = Head
;
@@ -3401,12 +3218,9 @@
proc_info_headvars(ProcInfo0, HeadVars0),
proc_info_argmodes(ProcInfo0, Modes0),
- proc_info_declared_determinism(ProcInfo0, Detism0),
- (
- Detism0 = yes(Detism1)
- ->
- Detism = Detism1,
- ModuleInfo1 = ModuleInfo0
+ proc_info_declared_determinism(ProcInfo0, MaybeDetism0),
+ ( MaybeDetism0 = yes(Detism0) ->
+ Detism = Detism0
;
% Omitting the determinism for a method is not allowed.
% But make_hlds.m will have already detected and reported
@@ -3415,7 +3229,7 @@
% We also mark the predicate as invalid, also to avoid
% flow-on errors.
Detism = nondet,
- module_info_remove_predid(ModuleInfo0, PredId, ModuleInfo1)
+ module_info_remove_predid(!.ModuleInfo, PredId, !:ModuleInfo)
),
% Work out which argument corresponds to the constraint which
@@ -3438,13 +3252,15 @@
list__length(InstanceArgs, InstanceArity),
pred_info_get_call_id(PredInfo0, CallId),
BodyGoalExpr = generic_call(
- class_method(TypeClassInfoVar, ProcNum0,
+ class_method(TypeClassInfoVar, !.ProcNum,
class_id(ClassName, InstanceArity), CallId),
HeadVars, Modes, Detism),
% Make the goal info for the call.
set__list_to_set(HeadVars0, NonLocals),
- instmap_delta_from_mode_list(HeadVars0, Modes0, ModuleInfo0,
+ % XXX This reference to OldModuleInfo after !ModuleInfo
+ % has been updated looks suspicious.
+ instmap_delta_from_mode_list(HeadVars0, Modes0, OldModuleInfo,
InstmapDelta),
pred_info_get_purity(PredInfo0, Purity),
goal_info_init(NonLocals, InstmapDelta, Detism, Purity, GoalInfo),
@@ -3453,7 +3269,6 @@
proc_info_set_goal(ProcInfo0, BodyGoal, ProcInfo),
map__det_update(ProcTable0, ProcId, ProcInfo, ProcTable),
pred_info_set_procedures(PredInfo0, ProcTable, PredInfo1),
-
( pred_info_is_imported(PredInfo1) ->
pred_info_set_import_status(PredInfo1, opt_imported, PredInfo)
;
@@ -3461,22 +3276,30 @@
),
map__det_update(PredTable0, PredId, PredInfo, PredTable),
- module_info_set_preds(ModuleInfo1, PredTable, ModuleInfo),
+ module_info_set_preds(!.ModuleInfo, PredTable, !:ModuleInfo),
- ProcNum = ProcNum0 + 1.
+ !:ProcNum = !.ProcNum + 1.
:- pred delete_nth(list(T)::in, int::in, list(T)::out) is semidet.
-delete_nth([X|Xs], N0, Result) :-
+delete_nth([X | Xs], N0, Result) :-
( N0 > 1 ->
N = N0 - 1,
delete_nth(Xs, N, TheRest),
- Result = [X|TheRest]
+ Result = [X | TheRest]
;
Result = Xs
).
%---------------------------------------------------------------------------%
+
+:- func get_constrained_vars(class_constraint) = list(tvar).
+
+get_constrained_vars(ClassConstraint) = CVars :-
+ ClassConstraint = constraint(_, CTypes),
+ term__vars_list(CTypes, CVars).
+
+%---------------------------------------------------------------------------%
%---------------------------------------------------------------------------%
:- type poly_info --->
@@ -3492,14 +3315,13 @@
% for each of the pred's type
% parameters
- typeclass_info_map ::
- map(class_constraint, prog_var),
+ typeclass_info_map :: map(class_constraint, prog_var),
% specifies the location of
% the typeclass_info var
% for each of the pred's class
% constraints
- proof_map ::
- map(class_constraint, constraint_proof),
+ proof_map :: map(class_constraint,
+ constraint_proof),
% specifies why each constraint
% that was eliminated from the
% pred was able to be eliminated
@@ -3523,8 +3345,8 @@
% init_poly_info initializes a poly_info from a pred_info
% and clauses_info.
% (See also create_poly_info.)
-:- pred init_poly_info(module_info, pred_info, clauses_info, poly_info).
-:- mode init_poly_info(in, in, in, out) is det.
+:- pred init_poly_info(module_info::in, pred_info::in, clauses_info::in,
+ poly_info::out) is det.
init_poly_info(ModuleInfo, PredInfo, ClausesInfo, PolyInfo) :-
clauses_info_varset(ClausesInfo, VarSet),
@@ -3533,9 +3355,8 @@
pred_info_get_constraint_proofs(PredInfo, Proofs),
map__init(TypeInfoMap),
map__init(TypeClassInfoMap),
- PolyInfo = poly_info(VarSet, VarTypes, TypeVarSet,
- TypeInfoMap, TypeClassInfoMap,
- Proofs, PredInfo, ModuleInfo).
+ PolyInfo = poly_info(VarSet, VarTypes, TypeVarSet, TypeInfoMap,
+ TypeClassInfoMap, Proofs, PredInfo, ModuleInfo).
% create_poly_info creates a poly_info for an existing procedure.
% (See also init_poly_info.)
@@ -3546,22 +3367,20 @@
proc_info_vartypes(ProcInfo, VarTypes),
proc_info_typeinfo_varmap(ProcInfo, TypeInfoMap),
proc_info_typeclass_info_varmap(ProcInfo, TypeClassInfoMap),
- PolyInfo = poly_info(VarSet, VarTypes, TypeVarSet,
- TypeInfoMap, TypeClassInfoMap,
- Proofs, PredInfo, ModuleInfo).
+ PolyInfo = poly_info(VarSet, VarTypes, TypeVarSet, TypeInfoMap,
+ TypeClassInfoMap, Proofs, PredInfo, ModuleInfo).
-poly_info_extract(Info, PredInfo0, PredInfo,
- ProcInfo0, ProcInfo, ModuleInfo) :-
+poly_info_extract(Info, !PredInfo, !ProcInfo, ModuleInfo) :-
Info = poly_info(VarSet, VarTypes, TypeVarSet, TypeInfoMap,
TypeclassInfoLocations, _Proofs, _OldPredInfo, ModuleInfo),
% set the new values of the fields in proc_info and pred_info
- proc_info_set_varset(ProcInfo0, VarSet, ProcInfo1),
- proc_info_set_vartypes(ProcInfo1, VarTypes, ProcInfo2),
- proc_info_set_typeinfo_varmap(ProcInfo2, TypeInfoMap, ProcInfo3),
- proc_info_set_typeclass_info_varmap(ProcInfo3, TypeclassInfoLocations,
- ProcInfo),
- pred_info_set_typevarset(PredInfo0, TypeVarSet, PredInfo).
+ proc_info_set_varset(!.ProcInfo, VarSet, !:ProcInfo),
+ proc_info_set_vartypes(!.ProcInfo, VarTypes, !:ProcInfo),
+ proc_info_set_typeinfo_varmap(!.ProcInfo, TypeInfoMap, !:ProcInfo),
+ proc_info_set_typeclass_info_varmap(!.ProcInfo, TypeclassInfoLocations,
+ !:ProcInfo),
+ pred_info_set_typevarset(!.PredInfo, TypeVarSet, !:PredInfo).
%---------------------------------------------------------------------------%
@@ -3577,14 +3396,14 @@
:- pred poly_info_get_pred_info(poly_info::in, pred_info::out) is det.
:- pred poly_info_get_module_info(poly_info::in, module_info::out) is det.
-poly_info_get_varset(PolyInfo, PolyInfo^varset).
-poly_info_get_var_types(PolyInfo, PolyInfo^vartypes).
-poly_info_get_typevarset(PolyInfo, PolyInfo^typevarset).
-poly_info_get_type_info_map(PolyInfo, PolyInfo^type_info_varmap).
-poly_info_get_typeclass_info_map(PolyInfo, PolyInfo^typeclass_info_map).
-poly_info_get_proofs(PolyInfo, PolyInfo^proof_map).
-poly_info_get_pred_info(PolyInfo, PolyInfo^pred_info).
-poly_info_get_module_info(PolyInfo, PolyInfo^module_info).
+poly_info_get_varset(PolyInfo, PolyInfo ^ varset).
+poly_info_get_var_types(PolyInfo, PolyInfo ^ vartypes).
+poly_info_get_typevarset(PolyInfo, PolyInfo ^ typevarset).
+poly_info_get_type_info_map(PolyInfo, PolyInfo ^ type_info_varmap).
+poly_info_get_typeclass_info_map(PolyInfo, PolyInfo ^ typeclass_info_map).
+poly_info_get_proofs(PolyInfo, PolyInfo ^ proof_map).
+poly_info_get_pred_info(PolyInfo, PolyInfo ^ pred_info).
+poly_info_get_module_info(PolyInfo, PolyInfo ^ module_info).
:- pred poly_info_set_varset(prog_varset::in, poly_info::in,
poly_info::out) is det.
@@ -3601,15 +3420,15 @@
:- pred poly_info_set_module_info(module_info::in, poly_info::in,
poly_info::out) is det.
-poly_info_set_varset(VarSet, PI, PI^varset := VarSet).
+poly_info_set_varset(VarSet, PI, PI ^ varset := VarSet).
poly_info_set_varset_and_types(VarSet, VarTypes, PI,
- (PI ^varset := VarSet) ^vartypes := VarTypes).
-poly_info_set_typevarset(TVarSet, PI, PI^typevarset := TVarSet).
-poly_info_set_type_info_map(TVarMap, PI, PI^type_info_varmap := TVarMap).
+ (PI ^ varset := VarSet) ^ vartypes := VarTypes).
+poly_info_set_typevarset(TVarSet, PI, PI ^ typevarset := TVarSet).
+poly_info_set_type_info_map(TVarMap, PI, PI ^ type_info_varmap := TVarMap).
poly_info_set_typeclass_info_map(TypeClassInfoMap, PI,
- PI^typeclass_info_map := TypeClassInfoMap).
-poly_info_set_proofs(Proofs, PI, PI^proof_map := Proofs).
-poly_info_set_module_info(ModuleInfo, PI, PI^module_info := ModuleInfo).
+ PI ^ typeclass_info_map := TypeClassInfoMap).
+poly_info_set_proofs(Proofs, PI, PI ^ proof_map := Proofs).
+poly_info_set_module_info(ModuleInfo, PI, PI ^ module_info := ModuleInfo).
%---------------------------------------------------------------------------%
%---------------------------------------------------------------------------%
Index: simplify.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/simplify.m,v
retrieving revision 1.120
diff -u -b -r1.120 simplify.m
--- simplify.m 13 Oct 2003 02:29:39 -0000 1.120
+++ simplify.m 20 Oct 2003 14:06:15 -0000
@@ -1599,7 +1599,7 @@
polymorphism__gen_extract_type_info(TypeVar, TypeClassInfoVar, Index,
ModuleInfo, Goals, TypeInfoVar,
- VarSet0, VarTypes0, VarSet, VarTypes),
+ VarSet0, VarSet, VarTypes0, VarTypes),
simplify_info_set_var_types(Info0, VarTypes, Info1),
simplify_info_set_varset(Info1, VarSet, Info).
cvs diff: Diffing notes
--------------------------------------------------------------------------
mercury-reviews mailing list
post: mercury-reviews at cs.mu.oz.au
administrative address: owner-mercury-reviews at cs.mu.oz.au
unsubscribe: Address: mercury-reviews-request at cs.mu.oz.au Message: unsubscribe
subscribe: Address: mercury-reviews-request at cs.mu.oz.au Message: subscribe
--------------------------------------------------------------------------
More information about the reviews
mailing list