[m-dev.] for review: reordering for existential types [2]
Fergus Henderson
fjh at cs.mu.OZ.AU
Fri Jun 11 01:52:42 AEST 1999
[continued from part 1]
Index: compiler/polymorphism.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/polymorphism.m,v
retrieving revision 1.163
diff -u -r1.163 polymorphism.m
--- polymorphism.m 1999/04/23 01:02:57 1.163
+++ polymorphism.m 1999/06/09 19:55:09
@@ -9,9 +9,9 @@
% This module is a pass over the HLDS.
% It does a syntactic transformation to implement polymorphism, including
-% typeclasses, using higher-order predicates, and also invokes
-% `lambda__transform_lambda' to handle lambda expressions by creating new
-% predicates for them.
+% typeclasses, by passing extra `type_info' and `typeclass_info' arguments.
+% These arguments are structures that contain, amoung other things,
+% higher-order predicate terms for the polymorphic procedures or methods.
% XXX The way the code in this module handles existential type classes
% and type class constraints is a bit ad-hoc, in general; there are
@@ -308,12 +308,21 @@
:- interface.
:- import_module hlds_goal, hlds_module, hlds_pred, prog_data, special_pred.
-:- import_module io, list, term.
+:- import_module io, list, term, map.
+
+% 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.
+% 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.
+
% 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.
@@ -323,12 +332,32 @@
term__context, list(prog_var), list(hlds_goal), poly_info, poly_info).
:- mode polymorphism__make_type_info_vars(in, in, in, out, out, in, out) is det.
+ % polymorphism__gen_extract_type_info(TypeVar, TypeClassInfoVar, Index,
+ % ModuleInfo, Goals, TypeInfoVar, ...):
+ %
+ % Generate code to extract a type_info variable from a
+ % given slot of a typeclass_info variable, by calling
+ % private_builtin:type_info_from_typeclass_info.
+ % TypeVar is the type variable to which this type_info
+ % variable corresponds. TypeClassInfoVar is the variable
+ % holding the type_class_info. Index specifies which
+ % slot it is. The procedure returns TypeInfoVar, which
+ % 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),
+ map(tvar, type_info_locn), prog_varset, map(prog_var, type),
+ map(tvar, type_info_locn)).
+:- mode polymorphism__gen_extract_type_info(in, in, in, in, out, out,
+ in, in, in, out, out, out) is det.
+
:- type poly_info.
- % Extract some fields from a pred_info and proc_info for use
- % by the polymorphism transformation.
-:- pred init_poly_info(module_info, pred_info, proc_info, poly_info).
-:- mode init_poly_info(in, in, in, out) is det.
+ % Extract some fields from a pred_info and proc_info and use them to
+ % create a poly_info, for use by the polymorphism transformation.
+:- pred create_poly_info(module_info, pred_info, proc_info, poly_info).
+:- mode create_poly_info(in, in, in, out) is det.
% Update the fields in a pred_info and proc_info with
% the values in a poly_info.
@@ -389,10 +418,11 @@
:- implementation.
-:- import_module hlds_data, llds, (lambda), prog_io.
+:- import_module typecheck, hlds_data, llds, prog_io.
:- import_module type_util, mode_util, quantification, instmap, prog_out.
:- import_module code_util, unify_proc, prog_util, make_hlds.
:- import_module (inst), hlds_out, base_typeclass_info, goal_util, passes_aux.
+:- import_module clause_to_proc.
:- import_module bool, int, string, set, map.
:- import_module term, varset, std_util, require, assoc_list.
@@ -400,8 +430,8 @@
%-----------------------------------------------------------------------------%
% This whole section just traverses the module structure.
- % We do two passes, the first to fix up the procedure bodies,
- % (and in fact everything except the pred_info argtypes),
+ % We do two passes, the first to fix up the clauses_info and
+ % proc_infos (and in fact everything except the pred_info argtypes),
% the second to fix up the pred_info argtypes.
% The reason we need two passes is that the first pass looks at
% the argtypes of the called predicates, and so we need to make
@@ -416,10 +446,7 @@
map__keys(Preds1, PredIds1),
polymorphism__fixup_preds(PredIds1, ModuleInfo1, ModuleInfo2),
- polymorphism__expand_class_method_bodies(ModuleInfo2, ModuleInfo3),
-
- % Need update the dependency graph to include the lambda predicates.
- module_info_clobber_dependency_info(ModuleInfo3, ModuleInfo).
+ polymorphism__expand_class_method_bodies(ModuleInfo2, ModuleInfo).
:- pred polymorphism__process_preds(list(pred_id), module_info, module_info,
io__state, io__state).
@@ -427,17 +454,17 @@
polymorphism__process_preds([], ModuleInfo, ModuleInfo) --> [].
polymorphism__process_preds([PredId | PredIds], ModuleInfo0, ModuleInfo) -->
- polymorphism__process_pred(PredId, ModuleInfo0, ModuleInfo1),
+ polymorphism__maybe_process_pred(PredId, ModuleInfo0, ModuleInfo1),
polymorphism__process_preds(PredIds, ModuleInfo1, ModuleInfo).
-:- pred polymorphism__process_pred(pred_id, module_info, module_info,
+:- pred polymorphism__maybe_process_pred(pred_id, module_info, module_info,
io__state, io__state).
-:- mode polymorphism__process_pred(in, in, out, di, uo) is det.
+:- mode polymorphism__maybe_process_pred(in, in, out, di, uo) is det.
-polymorphism__process_pred(PredId, ModuleInfo0, ModuleInfo, IO0, IO) :-
- module_info_pred_info(ModuleInfo0, PredId, PredInfo),
+polymorphism__maybe_process_pred(PredId, ModuleInfo0, ModuleInfo) -->
+ { module_info_pred_info(ModuleInfo0, PredId, PredInfo) },
(
- (
+ {
% Leave Aditi aggregates alone, since
% calls to them must be monomorphic. This avoids
% unnecessarily creating type_infos in Aditi code,
@@ -446,9 +473,8 @@
% the address of an Aditi procedure. The
% monomorphism of Aditi procedures is checked by
% magic.m.
- % Other Aditi procedures should still be processed
- % to remove complicated unifications and
- % lambda expressions.
+ % Other Aditi procedures should still be processed,
+ % to handle complicated unifications.
hlds_pred__pred_info_is_aditi_aggregate(PredInfo)
;
pred_info_module(PredInfo, PredModule),
@@ -456,47 +482,16 @@
pred_info_arity(PredInfo, PredArity),
polymorphism__no_type_info_builtin(PredModule,
PredName, PredArity)
- )
+ }
->
- ModuleInfo = ModuleInfo0,
- IO = IO0
+ % just copy the clauses to the proc_infos
+ { copy_module_clauses_to_procs([PredId],
+ ModuleInfo0, ModuleInfo) }
;
- pred_info_procids(PredInfo, ProcIds),
- polymorphism__process_procs(PredId, ProcIds,
- ModuleInfo0, ModuleInfo, IO0, IO)
+ polymorphism__process_pred(PredId, ModuleInfo0, ModuleInfo)
).
-:- pred polymorphism__process_procs(pred_id, list(proc_id),
- module_info, module_info,
- io__state, io__state).
-:- mode polymorphism__process_procs(in, in, in, out, di, uo) is det.
-
-polymorphism__process_procs(_PredId, [], ModuleInfo, ModuleInfo, IO, IO).
-polymorphism__process_procs(PredId, [ProcId | ProcIds], ModuleInfo0,
- ModuleInfo, IO0, IO) :-
- module_info_preds(ModuleInfo0, PredTable0),
- map__lookup(PredTable0, PredId, PredInfo0),
- pred_info_procedures(PredInfo0, ProcTable0),
- map__lookup(ProcTable0, ProcId, ProcInfo0),
-
-% It is misleading to output this message for predicates which are
-% not defined in this module, and we get far too many of them anyway.
-% write_proc_progress_message("% Transforming polymorphism for ",
-% PredId, ProcId, ModuleInfo0, IO0, IO1),
- IO1 = IO0,
-
- polymorphism__process_proc(ProcId, ProcInfo0, PredInfo0,
- ModuleInfo0, ProcInfo, PredInfo1, ModuleInfo1),
-
- pred_info_procedures(PredInfo1, ProcTable1),
- map__det_update(ProcTable1, ProcId, ProcInfo, ProcTable),
- pred_info_set_procedures(PredInfo1, ProcTable, PredInfo),
- module_info_preds(ModuleInfo1, PredTable1),
- map__det_update(PredTable1, PredId, PredInfo, PredTable),
- module_info_set_preds(ModuleInfo1, PredTable, ModuleInfo2),
-
- polymorphism__process_procs(PredId, ProcIds, ModuleInfo2, ModuleInfo,
- IO1, IO).
+%---------------------------------------------------------------------------%
polymorphism__no_type_info_builtin(MercuryBuiltin, "unsafe_type_cast", 2) :-
mercury_private_builtin_module(MercuryBuiltin).
@@ -521,8 +516,8 @@
polymorphism__fixup_preds([], ModuleInfo, ModuleInfo).
polymorphism__fixup_preds([PredId | PredIds], ModuleInfo0, ModuleInfo) :-
%
- % Recompute the arg types by finding the headvars and the var->type
- % mapping (from the first procedure for the predicate) and
+ % Recompute the arg types by finding the headvars and
+ % the var->type mapping (from the clauses_info) and
% applying the type mapping to the extra headvars to get the new
% arg types. Note that we are careful to only apply the mapping
% to the extra head vars, not to the originals, because otherwise
@@ -531,142 +526,204 @@
%
module_info_preds(ModuleInfo0, PredTable0),
map__lookup(PredTable0, PredId, PredInfo0),
- pred_info_procedures(PredInfo0, ProcTable0),
- pred_info_procids(PredInfo0, ProcIds),
- ( ProcIds = [ProcId | _] ->
- map__lookup(ProcTable0, ProcId, ProcInfo),
- proc_info_vartypes(ProcInfo, VarTypes),
- proc_info_headvars(ProcInfo, HeadVars),
- pred_info_arg_types(PredInfo0, TypeVarSet, ExistQVars,
- ArgTypes0),
- list__length(ArgTypes0, NumOldArgs),
- list__length(HeadVars, NumNewArgs),
- NumExtraArgs is NumNewArgs - NumOldArgs,
- (
- list__split_list(NumExtraArgs, HeadVars, ExtraHeadVars,
- _OldHeadVars)
- ->
- map__apply_to_list(ExtraHeadVars, VarTypes,
- ExtraArgTypes),
- list__append(ExtraArgTypes, ArgTypes0, ArgTypes)
- ;
- error("polymorphism.m: list__split_list failed")
- ),
-
- pred_info_set_arg_types(PredInfo0, TypeVarSet, ExistQVars,
- ArgTypes, PredInfo),
- map__det_update(PredTable0, PredId, PredInfo, PredTable),
- module_info_set_preds(ModuleInfo0, PredTable, ModuleInfo1)
+ pred_info_clauses_info(PredInfo0, ClausesInfo),
+ clauses_info_vartypes(ClausesInfo, VarTypes),
+ clauses_info_headvars(ClausesInfo, HeadVars),
+
+ pred_info_arg_types(PredInfo0, TypeVarSet, ExistQVars, ArgTypes0),
+ list__length(ArgTypes0, NumOldArgs),
+ list__length(HeadVars, NumNewArgs),
+ NumExtraArgs is NumNewArgs - NumOldArgs,
+ (
+ list__split_list(NumExtraArgs, HeadVars, ExtraHeadVars,
+ _OldHeadVars)
+ ->
+ map__apply_to_list(ExtraHeadVars, VarTypes,
+ ExtraArgTypes),
+ list__append(ExtraArgTypes, ArgTypes0, ArgTypes)
;
- ModuleInfo1 = ModuleInfo0
+ error("polymorphism.m: list__split_list failed")
),
+
+ pred_info_set_arg_types(PredInfo0, TypeVarSet, ExistQVars,
+ ArgTypes, PredInfo),
+ map__det_update(PredTable0, PredId, PredInfo, PredTable),
+ module_info_set_preds(ModuleInfo0, PredTable, ModuleInfo1),
+
polymorphism__fixup_preds(PredIds, ModuleInfo1, 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_proc(proc_id, proc_info, pred_info,
- module_info, proc_info, pred_info, module_info).
-:- mode polymorphism__process_proc(in, in, in, in, out, out, out) is det.
-
-polymorphism__process_proc(ProcId, ProcInfo0, PredInfo0, ModuleInfo0,
- ProcInfo, PredInfo, ModuleInfo) :-
- proc_info_goal(ProcInfo0, Goal0),
- init_poly_info(ModuleInfo0, PredInfo0, ProcInfo0, Info0),
- polymorphism__setup_headvars(PredInfo0, ProcInfo0,
- HeadVars, ArgModes, HeadTypeVars, UnconstrainedTVars,
+polymorphism__process_pred(PredId, ModuleInfo0, ModuleInfo) -->
+ { module_info_pred_info(ModuleInfo0, PredId, PredInfo0) },
+
+ write_pred_progress_message("% Transforming polymorphism for ",
+ PredId, ModuleInfo0),
+
+ %
+ % 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) },
+ { pred_info_set_typevarset(PredInfo0, TypeVarSet, PredInfo1) },
+ { pred_info_set_clauses_info(PredInfo1, ClausesInfo, PredInfo2) },
+
+ %
+ % do a pass over the proc_infos, copying the relevant information
+ % from the clauses_info and the poly_info, and updating all
+ % the argmodes with modes for the extra arguments.
+ %
+ { pred_info_procids(PredInfo2, ProcIds) },
+ { pred_info_procedures(PredInfo2, Procs0) },
+ { polymorphism__process_procs(ProcIds, Procs0, PredInfo2, ClausesInfo,
+ ExtraArgModes, Procs) },
+ { pred_info_set_procedures(PredInfo2, Procs, PredInfo) },
+
+ { module_info_set_pred_info(ModuleInfo1, 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.
+
+polymorphism__process_clause_info(ClausesInfo0, PredInfo0, ModuleInfo0,
+ ClausesInfo, PolyInfo, ExtraArgModes) :-
+
+ init_poly_info(ModuleInfo0, PredInfo0, ClausesInfo0, PolyInfo0),
+ clauses_info_headvars(ClausesInfo0, HeadVars0),
+
+ polymorphism__setup_headvars(PredInfo0, HeadVars0,
+ HeadVars, ExtraArgModes, _HeadTypeVars,
+ UnconstrainedTVars,
ExtraTypeInfoHeadVars, ExistTypeClassInfoHeadVars,
- Info0, Info1),
+ PolyInfo0, PolyInfo1),
+ clauses_info_clauses(ClausesInfo0, Clauses0),
+ list__map_foldl(polymorphism__process_clause(PredInfo0,
+ HeadVars, UnconstrainedTVars,
+ ExtraTypeInfoHeadVars,
+ ExistTypeClassInfoHeadVars),
+ Clauses0, Clauses, PolyInfo1, PolyInfo),
+
+ %
+ % 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),
+ clauses_info_explicit_vartypes(ClausesInfo0, ExplicitVarTypes),
+ ClausesInfo = clauses_info(VarSet, ExplicitVarTypes, VarTypes,
+ HeadVars, Clauses,
+ TypeInfoMap, TypeClassInfoMap).
+
+:- pred polymorphism__process_clause(pred_info, 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, out, in, out) is det.
+
+polymorphism__process_clause(PredInfo, HeadVars, UnconstrainedTVars,
+ ExtraTypeInfoHeadVars, ExistTypeClassInfoHeadVars,
+ Clause0, Clause) -->
(
- ( pred_info_is_imported(PredInfo0)
- ; pred_info_is_pseudo_imported(PredInfo0),
- hlds_pred__in_in_unification_proc_id(ProcId)
- )
+ { pred_info_is_imported(PredInfo) }
->
- Goal = Goal0,
- Info = Info1
+ { Clause = Clause0 }
;
+ { Clause0 = clause(ProcIds, Goal0, Context) },
%
% process any polymorphic calls inside the goal
%
- polymorphism__process_goal(Goal0, Goal1, Info1, Info2),
+ polymorphism__process_goal(Goal0, Goal1),
%
% generate code to construct the type-class-infos
% and type-infos for existentially quantified type vars
%
polymorphism__produce_existq_tvars(
- PredInfo0, ProcInfo0,
+ PredInfo, HeadVars,
UnconstrainedTVars, ExtraTypeInfoHeadVars,
ExistTypeClassInfoHeadVars,
- Goal1, Goal2, Info2, Info3),
+ Goal1, Goal2),
- pred_info_get_exist_quant_tvars(PredInfo0, ExistQVars),
+ { pred_info_get_exist_quant_tvars(PredInfo, ExistQVars) },
polymorphism__fixup_quantification(HeadVars, ExistQVars,
- Goal2, Goal3, Info3, Info4),
+ Goal2, Goal),
+ { Clause = clause(ProcIds, Goal, Context) }
+ ).
- %
- % If there were any existentially quantified type variables,
- % either in this predicate or in any predicate that it calls,
- % then we may need to recompute the instmap deltas too.
- % (The instmap deltas only need to be recomputed if we
- % change which variables are bound by the subgoals, i.e.
- % if any of the new variables that we introduced have mode
- % `out' rather than mode `in'. This can happen only if some
- % of the type variables are existentially quantified rather
- % than universally quantified.)
- %
- (
- ExistQVars = [],
- pred_info_get_head_type_params(PredInfo0,
- HeadTypeParams),
- HeadTypeVars = HeadTypeParams
- ->
- Goal = Goal3,
- Info = Info4
- ;
- poly_info_get_module_info(Info4, ModuleInfo4),
- mode_list_get_initial_insts(ArgModes, ModuleInfo4,
- InitialInsts),
- assoc_list__from_corresponding_lists(HeadVars,
- InitialInsts, InstAL),
- instmap__from_assoc_list(InstAL, InstMap),
- recompute_instmap_delta(no, Goal3, Goal, InstMap,
- ModuleInfo4, ModuleInfo5),
- poly_info_set_module_info(ModuleInfo5, Info4, Info)
+:- 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.
+
+polymorphism__process_proc(ProcId, ProcInfo0, PredInfo, ClausesInfo,
+ ExtraArgModes, ProcInfo) :-
+ %
+ % copy all the information from the clauses_info into the proc_info
+ %
+ (
+ ( pred_info_is_imported(PredInfo)
+ ; pred_info_is_pseudo_imported(PredInfo),
+ hlds_pred__in_in_unification_proc_id(ProcId)
)
+ ->
+ % XXX is this right?
+ ProcInfo1 = ProcInfo0
+ /* proc_info_set_headvars(ProcInfo0, HeadVars, ProcInfo1) */
+ ;
+ copy_clauses_to_proc(ProcId, ClausesInfo, ProcInfo0, ProcInfo1)
),
%
- % set the new values of the fields in proc_info and pred_info
+ % add the ExtraArgModes to the proc_info argmodes
%
- proc_info_set_headvars(ProcInfo0, HeadVars, ProcInfo1),
- proc_info_set_goal(ProcInfo1, Goal, ProcInfo2),
- proc_info_set_argmodes(ProcInfo2, ArgModes, ProcInfo3),
- poly_info_extract(Info, PredInfo0, PredInfo,
- ProcInfo3, ProcInfo, ModuleInfo).
+ proc_info_argmodes(ProcInfo1, ArgModes1),
+ list__append(ExtraArgModes, ArgModes1, ArgModes),
+ proc_info_set_argmodes(ProcInfo1, 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, proc_info,
+:- 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.
-polymorphism__setup_headvars(PredInfo, ProcInfo, HeadVars, ArgModes,
+polymorphism__setup_headvars(PredInfo, HeadVars0, HeadVars, ExtraArgModes,
HeadTypeVars, UnconstrainedTVars, ExtraHeadTypeInfoVars,
ExistHeadTypeClassInfoVars, PolyInfo0, PolyInfo) :-
%
- % grab the appropriate fields from the pred_info and proc_info
+ % grab the appropriate fields from the pred_info
%
pred_info_arg_types(PredInfo, ArgTypeVarSet, ExistQVars, ArgTypes),
pred_info_get_class_context(PredInfo, ClassContext),
- proc_info_headvars(ProcInfo, HeadVars0),
- proc_info_argmodes(ProcInfo, ArgModes0),
%
@@ -741,7 +798,7 @@
list__duplicate(NumUnivClassInfoVars, In, UnivTypeClassInfoModes),
list__duplicate(NumExistClassInfoVars, Out, ExistTypeClassInfoModes),
list__condense([UnivTypeClassInfoModes, ExistTypeClassInfoModes,
- UnivTypeInfoModes, ExistTypeInfoModes, ArgModes0], ArgModes),
+ UnivTypeInfoModes, ExistTypeInfoModes], ExtraArgModes),
%
% Add the locations of the typeinfos
@@ -775,19 +832,18 @@
% 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, proc_info, list(tvar), list(prog_var), list(prog_var),
+:- 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, ProcInfo,
+polymorphism__produce_existq_tvars(PredInfo, HeadVars0,
UnconstrainedTVars, TypeInfoHeadVars,
ExistTypeClassInfoHeadVars, Goal0, Goal, Info0, Info) :-
poly_info_get_var_types(Info0, VarTypes0),
pred_info_arg_types(PredInfo, _ArgTypeVarSet, ExistQVars, ArgTypes),
pred_info_get_class_context(PredInfo, ClassContext),
- proc_info_headvars(ProcInfo, HeadVars0),
%
% Figure out the bindings for any existentially quantified
@@ -881,22 +937,11 @@
:- 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).
- % Doing just this wouldn't work, because we also need to fill in
- % the mode and determinism info:
- % term__context_init(Context),
- % create_atomic_unification(Var1, var(Var2), Context, explicit,
- % [], Goal),
-
- Ground = ground(shared, no),
- Mode = ((free -> Ground) - (Ground -> Ground)),
- UnifyInfo = assign(Var1, Var2),
- UnifyC = unify_context(explicit, []),
- set__list_to_set([Var1, Var2], NonLocals),
- instmap_delta_from_assoc_list([Var1 - Ground], InstMapDelta),
- Determinism = det,
- goal_info_init(NonLocals, InstMapDelta, Determinism, GoalInfo),
- Goal = unify(Var1, var(Var2), Mode, UnifyInfo, UnifyC) - GoalInfo.
+%-----------------------------------------------------------------------------%
:- pred polymorphism__process_goal(hlds_goal, hlds_goal,
poly_info, poly_info).
@@ -961,152 +1006,50 @@
{ list__append(ExtraGoals, [Call], GoalList) },
{ conj_list_to_goal(GoalList, GoalInfo, Goal) }.
-polymorphism__process_goal_expr(unify(XVar, Y, Mode, Unification, Context),
- GoalInfo, Goal) -->
- (
- { Unification = complicated_unify(UniMode, CanFail) },
- { Y = var(YVar) }
- ->
- =(Info0),
- { poly_info_get_var_types(Info0, VarTypes) },
- { poly_info_get_type_info_map(Info0, TypeInfoMap) },
- { poly_info_get_module_info(Info0, ModuleInfo) },
- { map__lookup(VarTypes, XVar, Type) },
- ( { Type = term__variable(TypeVar) } ->
- % Convert polymorphic unifications into calls to
- % `unify/2', the general unification predicate, passing
- % the appropriate Type_info
- % =(TypeInfoVar, X, Y)
- % where TypeInfoVar is the type_info variable
- % associated with the type of the variables that
- % are being unified.
-
- { module_info_get_predicate_table(ModuleInfo,
- PredicateTable) },
- { mercury_public_builtin_module(MercuryBuiltin) },
- { predicate_table_search_pred_m_n_a(PredicateTable,
- MercuryBuiltin, "unify", 2, [CallPredId])
- ->
- PredId = CallPredId
- ;
- error("polymorphism.m: can't find `builtin:unify/2'")
- },
- { Mode = XMode - YMode },
- {
- mode_is_fully_input(ModuleInfo, XMode),
- mode_is_fully_input(ModuleInfo, YMode)
- ->
- true
- ;
- goal_info_get_context(GoalInfo, GoalContext),
- context_to_string(GoalContext, ContextMsg),
- string__append(ContextMsg,
-"Sorry, not implemented: polymorphic unification in mode other than (in, in)",
- ErrorMsg),
- error(ErrorMsg)
- },
- { hlds_pred__in_in_unification_proc_id(ProcId) },
- { map__lookup(TypeInfoMap, TypeVar, TypeInfoLocn) },
- { SymName = unqualified("unify") },
- { code_util__builtin_state(ModuleInfo, PredId, ProcId,
- BuiltinState) },
- { CallContext = call_unify_context(XVar, Y, Context) },
- (
- % If the typeinfo is available in a
- % variable, just use it
- { TypeInfoLocn = type_info(TypeInfoVar) },
- { ArgVars = [TypeInfoVar, XVar, YVar] },
- { Goal = call(PredId, ProcId, ArgVars,
- BuiltinState, yes(CallContext), SymName)
- - GoalInfo }
- ;
- % If the typeinfo is in a
- % typeclass_info, first extract it,
- % then use it
- { TypeInfoLocn =
- typeclass_info(TypeClassInfoVar,
- Index) },
- extract_type_info(Type, TypeVar,
- TypeClassInfoVar, Index,
- Goals, TypeInfoVar),
-
- { ArgVars = [TypeInfoVar, XVar, YVar] },
- { Call = call(PredId, ProcId, ArgVars,
- BuiltinState, yes(CallContext), SymName)
- - GoalInfo },
-
- { list__append(Goals, [Call], TheGoals) },
- { Goal = conj(TheGoals) - GoalInfo }
- )
-
- ; { type_is_higher_order(Type, _, _) } ->
- { SymName = unqualified("builtin_unify_pred") },
- { ArgVars = [XVar, YVar] },
- { module_info_get_predicate_table(ModuleInfo,
- PredicateTable) },
- {
- mercury_private_builtin_module(PrivateBuiltin),
- predicate_table_search_pred_m_n_a(
- PredicateTable,
- PrivateBuiltin, "builtin_unify_pred", 2,
- [PredId0])
- ->
- PredId = PredId0
- ;
- error("can't locate private_builtin:builtin_unify_pred/2")
- },
- { hlds_pred__in_in_unification_proc_id(ProcId) },
- { CallContext = call_unify_context(XVar, Y, Context) },
- { Call = call(PredId, ProcId, ArgVars, not_builtin,
- yes(CallContext), SymName) },
- polymorphism__process_goal_expr(Call, GoalInfo, Goal)
-
- ; { type_to_type_id(Type, TypeId, _) } ->
+polymorphism__process_goal_expr(Goal0, GoalInfo, Goal) -->
+ { Goal0 = pragma_c_code(IsRecursive, PredId, ProcId,
+ ArgVars0, ArgInfo0, OrigArgTypes0, PragmaCode) },
+ polymorphism__process_call(PredId, ArgVars0, GoalInfo,
+ ArgVars, ExtraVars, CallGoalInfo, ExtraGoals),
- % Convert other complicated unifications into
- % calls to specific unification predicates, and then
- % recursively call polymorphism__process_goal_expr
- % to insert extra arguments if necessary.
-
- { module_info_get_special_pred_map(ModuleInfo,
- SpecialPredMap) },
- { map__lookup(SpecialPredMap, unify - TypeId, PredId) },
- { determinism_components(Det, CanFail, at_most_one) },
- { unify_proc__lookup_mode_num(ModuleInfo, TypeId,
- UniMode, Det, ProcId) },
- { SymName = unqualified("__Unify__") },
- { ArgVars = [XVar, YVar] },
- { CallContext = call_unify_context(XVar, Y, Context) },
- { Call = call(PredId, ProcId, ArgVars, not_builtin,
- yes(CallContext), SymName) },
- polymorphism__process_goal_expr(Call, GoalInfo, Goal)
- ;
- { error("polymorphism: type_to_type_id failed") }
- )
- ;
- { Y = lambda_goal(PredOrFunc, ArgVars, LambdaVars,
- Modes, Det, LambdaGoal0) }
+ %
+ % insert the type_info vars into the arg-name map,
+ % so that the c_code 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) },
+
+
+ (
+ { polymorphism__no_type_info_builtin(PredModule,
+ PredName, PredArity) }
->
- % for lambda expressions, we must recursively traverse the
- % lambda goal and then convert the lambda expression
- % into a new predicate
- polymorphism__process_goal(LambdaGoal0, LambdaGoal1),
- % XXX currently we don't allow lambda goals to be
- % existentially typed
- { ExistQVars = [] },
- polymorphism__fixup_lambda_quantification(LambdaGoal1,
- ArgVars, LambdaVars, ExistQVars,
- LambdaGoal, NonLocalTypeInfos),
- polymorphism__process_lambda(PredOrFunc, LambdaVars, Modes,
- Det, ArgVars, NonLocalTypeInfos, LambdaGoal,
- Unification, Y1, Unification1),
- { Goal = unify(XVar, Y1, Mode, Unification1, Context)
- - GoalInfo }
+ { Goal = Goal0 - GoalInfo }
;
- % ordinary unifications are left unchanged,
- { Goal = unify(XVar, Y, Mode, Unification, Context) - GoalInfo }
+ { list__length(ExtraVars, NumExtraVars) },
+ { polymorphism__process_c_code(PredInfo, NumExtraVars,
+ OrigArgTypes0, OrigArgTypes, ArgInfo0, ArgInfo) },
+
+ %
+ % plug it all back together
+ %
+ { Call = pragma_c_code(IsRecursive, PredId, ProcId, ArgVars,
+ ArgInfo, OrigArgTypes, PragmaCode) - 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_unify(XVar, Y, Mode, Unification, UnifyContext,
+ GoalInfo, Goal).
+
% the rest of the clauses just process goals recursively
polymorphism__process_goal_expr(conj(Goals0), GoalInfo,
@@ -1132,45 +1075,326 @@
polymorphism__process_goal(B0, B),
polymorphism__process_goal(C0, C).
-polymorphism__process_goal_expr(Goal0, GoalInfo, Goal) -->
- { Goal0 = pragma_c_code(IsRecursive, PredId, ProcId,
- ArgVars0, ArgInfo0, OrigArgTypes0, PragmaCode) },
- polymorphism__process_call(PredId, ArgVars0, GoalInfo,
- ArgVars, ExtraVars, CallGoalInfo, ExtraGoals),
+:- 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.
+
+polymorphism__process_unify(XVar, Y, Mode, Unification0, UnifyContext,
+ GoalInfo0, Goal) -->
+ % switch on Y
+ (
+ { Y = var(_YVar) },
+ %
+ % var-var unifications (simple_test, assign,
+ % or complicated_unify) are basically left unchanged.
+ % Complicated unifications will eventually get converted into
+ % calls, but that is done later on, by simplify.m, not now.
+ % At this point we just need to figure out
+ % which type_info/typeclass_info variables the unification
+ % might need, and insert them in the non-locals.
+ % We have to do that for all var-var unifications,
+ % because at this point we haven't done mode analysis so
+ % we don't know which ones will become complicated_unifies.
+ % Note that we also store the type_info/typeclass_info
+ % variables in a field in the unification, which
+ % quantification.m uses when requantifying things.
+ %
+ =(Info0),
+ { poly_info_get_type_info_map(Info0, TypeInfoMap) },
+ { poly_info_get_var_types(Info0, VarTypes) },
+ { map__lookup(VarTypes, XVar, Type) },
+ { polymorphism__unification_typeinfos(Type, TypeInfoMap,
+ Unification0, GoalInfo0, Unification, GoalInfo) },
+ { Goal = unify(XVar, Y, Mode, Unification,
+ UnifyContext) - GoalInfo }
+ ;
+ { Y = functor(ConsId, Args) },
+ polymorphism__process_unify_functor(XVar, ConsId, Args, Mode,
+ Unification0, UnifyContext, GoalInfo0, Goal)
+ ;
+ { Y = lambda_goal(PredOrFunc, ArgVars0, LambdaVars,
+ Modes, Det, LambdaGoal0) },
+ %
+ % for lambda expressions, we must recursively traverse the
+ % lambda goal
+ %
+ polymorphism__process_goal(LambdaGoal0, LambdaGoal1),
+ % 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(PredOrFunc, ArgVars, LambdaVars,
+ Modes, Det, LambdaGoal) },
+ { goal_info_get_nonlocals(GoalInfo0, NonLocals0) },
+ { set__union(NonLocals0, NonLocalTypeInfos, NonLocals) },
+ { goal_info_set_nonlocals(GoalInfo0, NonLocals, GoalInfo) },
+ { Goal = unify(XVar, Y1, Mode, Unification0, UnifyContext)
+ - GoalInfo }
+ ).
+polymorphism__unification_typeinfos(Type, TypeInfoMap,
+ Unification0, GoalInfo0, Unification, GoalInfo) :-
%
- % insert the type_info vars into the arg-name map,
- % so that the c_code can refer to the type_info variable
- % for type T as `TypeInfo_for_T'.
+ % Compute the type_info/type_class_info variables that would be
+ % used if this unification ends up being a complicated_unify.
%
- =(Info0),
- { poly_info_get_module_info(Info0, ModuleInfo) },
- { module_info_pred_info(ModuleInfo, PredId, PredInfo) },
+ type_util__vars(Type, TypeVars),
+ map__apply_to_list(TypeVars, TypeInfoMap, TypeInfoLocns),
+ list__map(type_info_locn_var, TypeInfoLocns, TypeInfoVars0),
+ list__remove_dups(TypeInfoVars0, TypeInfoVars),
- { pred_info_module(PredInfo, PredModule) },
- { pred_info_name(PredInfo, PredName) },
- { pred_info_arity(PredInfo, PredArity) },
+ %
+ % Insert the TypeInfoVars into the nonlocals field of the goal_info
+ % for the unification goal.
+ %
+ goal_info_get_nonlocals(GoalInfo0, NonLocals0),
+ set__insert_list(NonLocals0, TypeInfoVars, NonLocals),
+ goal_info_set_nonlocals(GoalInfo0, NonLocals, GoalInfo),
+
+ %
+ % Also save those type_info vars into a field in the complicated_unify,
+ % so that quantification.m can recompute variable scopes properly.
+ % 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)
+ ;
+ error("polymorphism__unification_typeinfos")
+ ).
+:- 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.
+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),
+ map__lookup(VarTypes0, X0, TypeOfX),
+ list__length(ArgVars0, Arity),
(
- { polymorphism__no_type_info_builtin(PredModule,
- PredName, PredArity) }
+ %
+ % is the function symbol apply/N or ''/N,
+ % representing a higher-order function call?
+ %
+ ConsId0 = cons(unqualified(ApplyName), _),
+ ( ApplyName = "apply" ; ApplyName = "" ),
+ Arity >= 1,
+ ArgVars0 = [FuncVar | FuncArgVars]
->
- { Goal = Goal0 - GoalInfo }
+ %
+ % Convert the higher-order function call (apply/N)
+ % into a higher-order predicate call
+ % (i.e., replace `X = apply(F, A, B, C)'
+ % with `call(F, A, B, C, X)')
+ %
+ list__append(FuncArgVars, [X0], ArgVars),
+ map__apply_to_list(ArgVars, VarTypes0, ArgTypes),
+ Modes = [],
+ Det = erroneous,
+ HOCall = higher_order_call(FuncVar, ArgVars, ArgTypes,
+ Modes, Det, function),
+
+ %
+ % now process it
+ %
+ %polymorphism__process_goal_expr(HOCall, GoalInfo0, Goal,
+ % PolyInfo0, PolyInfo)
+ Goal = HOCall - GoalInfo0,
+ PolyInfo = PolyInfo0
;
- { list__length(ExtraVars, NumExtraVars) },
- { polymorphism__process_c_code(PredInfo, NumExtraVars,
- OrigArgTypes0, OrigArgTypes, ArgInfo0, ArgInfo) },
+ %
+ % is the function symbol a user-defined function, rather
+ % than a functor which represents a data constructor?
+ %
+
+ % Find the set of candidate predicates which have the
+ % specified name and arity (and module, if module-qualified)
+ ConsId0 = cons(PredName, _),
%
- % plug it all back together
+ % We don't do this for compiler-generated predicates;
+ % they are assumed to have been generated with all
+ % functions already expanded.
+ % If we did this check for compiler-generated
+ % predicates, it would cause the wrong behaviour
+ % in the case where there is a user-defined function
+ % whose type is exactly the same as the type of
+ % a constructor. (Normally that would cause
+ % a type ambiguity error, but compiler-generated
+ % predicates are not type-checked.)
%
- { Call = pragma_c_code(IsRecursive, PredId, ProcId, ArgVars,
- ArgInfo, OrigArgTypes, PragmaCode) - CallGoalInfo },
- { list__append(ExtraGoals, [Call], GoalList) },
- { conj_list_to_goal(GoalList, GoalInfo, Goal) }
+ poly_info_get_pred_info(PolyInfo0, PredInfo),
+ \+ code_util__compiler_generated(PredInfo),
+
+ module_info_get_predicate_table(ModuleInfo0, PredTable),
+ predicate_table_search_func_sym_arity(PredTable,
+ PredName, Arity, PredIds),
+
+ % Check if any of the candidate functions have
+ % argument/return types which subsume the actual
+ % argument/return types of this function call
+
+ poly_info_get_typevarset(PolyInfo0, TVarSet),
+ map__apply_to_list(ArgVars0, VarTypes0, ArgTypes0),
+ list__append(ArgTypes0, [TypeOfX], ArgTypes),
+ typecheck__find_matching_pred_id(PredIds, ModuleInfo0,
+ TVarSet, ArgTypes, PredId, QualifiedFuncName)
+ ->
+ %
+ % Convert function calls into predicate calls:
+ % replace `X = f(A, B, C)'
+ % with `f(A, B, C, X)'
+ %
+ invalid_proc_id(ProcId),
+ list__append(ArgVars0, [X0], ArgVars),
+ FuncCallUnifyContext = call_unify_context(X0,
+ functor(ConsId0, ArgVars0), UnifyContext),
+ FuncCall = call(PredId, ProcId, ArgVars, not_builtin,
+ yes(FuncCallUnifyContext), QualifiedFuncName),
+
+ %
+ % now process it
+ %
+ polymorphism__process_goal_expr(FuncCall, GoalInfo0, Goal,
+ PolyInfo0, PolyInfo)
+ ;
+
+ %
+ % We replace any unifications with higher-order pred constants
+ % by lambda expressions. For example, we replace
+ %
+ % X = list__append(Y) % Y::in, X::out
+ %
+ % with
+ %
+ % X = lambda [A1::in, A2::out] (list__append(Y, A1, A2))
+ %
+ % We do this because it makes two things easier.
+ % Firstly, mode analysis needs to check that the lambda-goal doesn't
+ % bind any non-local variables (e.g. `Y' in above example).
+ % This would require a bit of moderately tricky special-case code
+ % if we didn't expand them here.
+ % Secondly, this pass (polymorphism.m) is a lot easier
+ % if we don't have to handle higher-order pred consts.
+ % If it turns out that the predicate was non-polymorphic,
+ % lambda.m will (I hope) turn the lambda expression
+ % back into a higher-order pred constant again.
+ %
+
+ % check if variable has a higher-order type
+ type_is_higher_order(TypeOfX, PredOrFunc, PredArgTypes),
+ ConsId0 = cons(PName, _)
+ ->
+ %
+ % Create the new lambda-quantified variables
+ %
+ poly_info_get_varset(PolyInfo0, VarSet0),
+ make_fresh_vars(PredArgTypes, VarSet0, VarTypes0,
+ LambdaVars, VarSet, VarTypes),
+ list__append(ArgVars0, LambdaVars, Args),
+ poly_info_set_varset_and_types(VarSet, VarTypes,
+ PolyInfo0, PolyInfo1),
+
+ %
+ % Build up the hlds_goal_expr for the call that will form
+ % the lambda goal
+ %
+
+ poly_info_get_typevarset(PolyInfo1, TVarSet),
+ map__apply_to_list(Args, VarTypes, ArgTypes),
+ get_pred_id_and_proc_id(PName, PredOrFunc, TVarSet,
+ ArgTypes, ModuleInfo0, PredId, ProcId),
+ module_info_pred_proc_info(ModuleInfo0, PredId, ProcId,
+ PredInfo, ProcInfo),
+
+ % module-qualify the pred name (is this necessary?)
+ pred_info_module(PredInfo, PredModule),
+ unqualify_name(PName, UnqualPName),
+ QualifiedPName = qualified(PredModule, UnqualPName),
+
+ CallUnifyContext = call_unify_context(X0,
+ functor(ConsId0, ArgVars0), UnifyContext),
+ LambdaGoalExpr = call(PredId, ProcId, Args, not_builtin,
+ yes(CallUnifyContext), QualifiedPName),
+
+ %
+ % construct a goal_info for the lambda goal, making sure
+ % to set up the nonlocals field in the goal_info correctly
+ %
+ goal_info_get_nonlocals(GoalInfo0, NonLocals),
+ set__insert_list(NonLocals, LambdaVars, OutsideVars),
+ set__list_to_set(Args, InsideVars),
+ set__intersect(OutsideVars, InsideVars, LambdaNonLocals),
+ goal_info_init(LambdaGoalInfo0),
+ goal_info_get_context(GoalInfo0, Context),
+ goal_info_set_context(LambdaGoalInfo0, Context,
+ LambdaGoalInfo1),
+ goal_info_set_nonlocals(LambdaGoalInfo1, LambdaNonLocals,
+ LambdaGoalInfo),
+ LambdaGoal = LambdaGoalExpr - LambdaGoalInfo,
+
+ %
+ % work out the modes of the introduced lambda variables
+ % and the determinism of the lambda goal
+ %
+ pred_info_arity(PredInfo, PredArity),
+ proc_info_argmodes(ProcInfo, ArgModes),
+ list__length(ArgModes, ProcArity),
+ NumTypeInfos = ProcArity - PredArity,
+ ( list__drop(NumTypeInfos + Arity, ArgModes, LambdaModes0) ->
+ LambdaModes = LambdaModes0
+ ;
+ error("modecheck_unification: list__drop failed")
+ ),
+ proc_info_declared_determinism(ProcInfo, MaybeDet),
+ ( MaybeDet = yes(Det) ->
+ LambdaDet = Det
+ ;
+ error("Sorry, not implemented: determinism inference for higher-order predicate terms")
+ ),
+
+ %
+ % construct the lambda expression, and then go ahead
+ % and process this unification in its new form
+ %
+ Functor0 = lambda_goal(PredOrFunc, ArgVars0, LambdaVars,
+ LambdaModes, LambdaDet, LambdaGoal),
+ polymorphism__process_unify(X0, Functor0, Mode0,
+ Unification0, UnifyContext, GoalInfo0, Goal,
+ PolyInfo1, PolyInfo)
+ ;
+ %
+ % ordinary construction/deconstruction unifications
+ % we leave alone
+ %
+ Goal = unify(X0, functor(ConsId0, ArgVars0), Mode0,
+ Unification0, UnifyContext) - GoalInfo0,
+ PolyInfo = PolyInfo0
).
+% this is duplicated in modecheck_unify.m
+:- 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 polymorphism__process_c_code(pred_info, int, list(type), list(type),
list(maybe(pair(string, mode))), list(maybe(pair(string, mode)))).
@@ -1478,46 +1702,7 @@
%
goal_info_get_nonlocals(GoalInfo0, NonLocals0),
set__insert_list(NonLocals0, ExtraVars, NonLocals),
- goal_info_set_nonlocals(GoalInfo0, NonLocals, GoalInfo1),
-
- %
- % update the instmap delta for typeinfo vars and
- % typeclassinfo vars for any existentially quantified
- % type vars in the callee's type: such typeinfo variables
- % are produced by this call
- % (universally quantified typeinfo and typeclassinfo vars
- % are input to the goal, and their inst is not changed by
- % the goal, so they don't need to be mentioned in the
- % instmap delta)
- %
- poly_info_get_type_info_map(Info, TypeVarMap),
- poly_info_get_typeclass_info_map(Info, TypeClassVarMap),
- goal_info_get_instmap_delta(GoalInfo1, InstmapDelta0),
- AddInstDelta = lambda([TVar::in, IMD0::in, IMD::out] is det, (
- map__lookup(TypeVarMap, TVar, TypeInfoLocn),
- (
- TypeInfoLocn = type_info(TypeInfoVar),
- instmap_delta_set(IMD0, TypeInfoVar,
- ground(shared, no), IMD)
- ;
- TypeInfoLocn = typeclass_info(_, _),
- % the instmap delta for the type class info
- % variable will be added by AddTCInstDelta
- % (below)
- IMD = IMD0
- ))),
- AddTCInstDelta = lambda([Constraint::in, IMD0::in, IMD::out]
- is det, (
- map__lookup(TypeClassVarMap, Constraint,
- TypeClassInfoVar),
- instmap_delta_set(IMD0, TypeClassInfoVar,
- ground(shared, no), IMD)
- )),
- list__foldl(AddInstDelta, PredExistQVars,
- InstmapDelta0, InstmapDelta1),
- list__foldl(AddTCInstDelta, ExistentialConstraints,
- InstmapDelta1, InstmapDelta),
- goal_info_set_instmap_delta(GoalInfo1, InstmapDelta, GoalInfo)
+ goal_info_set_nonlocals(GoalInfo0, NonLocals, GoalInfo)
).
:- pred polymorphism__update_typeclass_infos(list(class_constraint),
@@ -1568,7 +1753,7 @@
:- mode polymorphism__fixup_quantification(in, in, in, out, in, out) is det.
%
-% If the lambda predicate we are processing is a polymorphic predicate,
+% If the pred we are processing is a polymorphic predicate,
% or contains polymorphically-typed goals, we
% may need to fix up the quantification (non-local variables)
% so that it includes the extra type-info variables and type-class-info
@@ -1640,52 +1825,6 @@
%-----------------------------------------------------------------------------%
-:- pred polymorphism__process_lambda(pred_or_func, list(prog_var),
- list(mode), determinism, list(prog_var), set(prog_var),
- hlds_goal, unification, unify_rhs, unification,
- poly_info, poly_info).
-:- mode polymorphism__process_lambda(in, in, in, in, in, in, in, in, out, out,
- in, out) is det.
-
-polymorphism__process_lambda(PredOrFunc, Vars, Modes, Det, OrigNonLocals,
- NonLocalTypeInfos, LambdaGoal, Unification0, Functor,
- Unification, PolyInfo0, PolyInfo) :-
- PolyInfo0 = poly_info(VarSet, VarTypes, TVarSet, TVarMap,
- TCVarMap, _Proofs, PredName, ModuleInfo0,
- Markers, Owner),
-
- % Calculate the constraints which apply to this lambda
- % expression.
- % XXX Note currently we only allow lambda expressions
- % to have universally quantified constraints.
- map__keys(TCVarMap, AllConstraints),
- map__apply_to_list(Vars, VarTypes, LambdaVarTypes),
- list__map(type_util__vars, LambdaVarTypes, LambdaTypeVarsList),
- list__condense(LambdaTypeVarsList, LambdaTypeVars),
- list__filter(polymorphism__constraint_contains_vars(LambdaTypeVars),
- AllConstraints, UnivConstraints),
- Constraints = constraints(UnivConstraints, []),
- lambda__transform_lambda(PredOrFunc, PredName, Vars, Modes, Det,
- OrigNonLocals, NonLocalTypeInfos, LambdaGoal, Unification0,
- VarSet, VarTypes, Constraints, TVarSet, TVarMap, TCVarMap,
- Markers, Owner, ModuleInfo0, Functor, Unification, ModuleInfo),
- poly_info_set_module_info(ModuleInfo, PolyInfo0, PolyInfo).
-
-:- pred polymorphism__constraint_contains_vars(list(tvar), class_constraint).
-:- mode polymorphism__constraint_contains_vars(in, in) is semidet.
-
-polymorphism__constraint_contains_vars(LambdaVars, ClassConstraint) :-
- ClassConstraint = constraint(_, ConstraintTypes),
- list__map(type_util__vars, ConstraintTypes, ConstraintVarsList),
- list__condense(ConstraintVarsList, ConstraintVars),
- % Probably not the most efficient way of doing it, but I
- % wouldn't think that it matters.
- set__list_to_set(LambdaVars, LambdaVarsSet),
- set__list_to_set(ConstraintVars, ConstraintVarsSet),
- set__subset(ConstraintVarsSet, LambdaVarsSet).
-
-%---------------------------------------------------------------------------%
-
% Given the list of constraints for a called predicate, create a list of
% variables to hold the typeclass_info for those constraints,
% and create a list of goals to initialize those typeclass_info variables
@@ -1765,7 +1904,7 @@
Info0 = poly_info(VarSet0, VarTypes0, TypeVarSet, TypeInfoMap0,
TypeClassInfoMap0, Proofs, PredName, ModuleInfo,
- Markers, Owner),
+ unit, unit),
(
map__search(TypeClassInfoMap0, Constraint, Location)
@@ -1885,7 +2024,7 @@
Info1 = poly_info(VarSet1, VarTypes1, TypeVarSet,
TypeInfoMap0, TypeClassInfoMap0, Proofs,
- PredName, ModuleInfo, Markers, Owner),
+ PredName, ModuleInfo, unit, unit),
% Make the typeclass_info for the subclass
polymorphism__make_typeclass_info_var(
@@ -1964,10 +2103,9 @@
% Make the goal info for the call
set__list_to_set([SubClassVar, IndexVar, Var],
NonLocals),
- instmap_delta_from_assoc_list(
- [Var - ground(shared, no)],
- InstmapDelta),
- goal_info_init(NonLocals, InstmapDelta, det, GoalInfo),
+ goal_info_init(GoalInfo0),
+ goal_info_set_nonlocals(GoalInfo0, NonLocals,
+ GoalInfo),
% Put them together
SuperClassGoal = Call - GoalInfo,
@@ -2250,20 +2388,8 @@
%
% p(TypeInfo, X) :- q(TypeInfo, X).
- (
- % If the typeinfo is available in a variable,
- % just use it
- TypeInfoLocn = type_info(TypeInfoVar),
- Var = TypeInfoVar,
- ExtraGoals = [],
- Info = Info0
- ;
- % If the typeinfo is in a typeclass_info, first
- % extract it, then use it
- TypeInfoLocn = typeclass_info(TypeClassInfoVar, Index),
- extract_type_info(Type, TypeVar, TypeClassInfoVar,
- Index, ExtraGoals, Var, Info0, Info)
- )
+ get_type_info(TypeInfoLocn, TypeVar, ExtraGoals, Var,
+ Info0, Info)
;
Type = term__variable(TypeVar)
->
@@ -2287,7 +2413,9 @@
string__format("%s:%03d: ",
[s(FileName), i(LineNumber)], ContextMessage)
),
- poly_info_get_pred_name(Info0, PredName),
+ poly_info_get_pred_info(Info0, PredInfo),
+ % XXX should print the module name and arity too
+ pred_info_name(PredInfo, PredName),
string__append_list([
"polymorphism__make_var:\n",
ContextMessage, "In predicate `", PredName, "':\n",
@@ -2650,31 +2778,48 @@
%---------------------------------------------------------------------------%
-:- pred extract_type_info(type, tvar, prog_var, int, list(hlds_goal),
+% Generate code to get the value of a type variable.
+
+:- pred get_type_info(type_info_locn, tvar, list(hlds_goal),
+ prog_var, poly_info, poly_info).
+:- mode get_type_info(in, in, out, out, in, out) is det.
+
+get_type_info(TypeInfoLocn, TypeVar, ExtraGoals, Var, Info0, Info) :-
+ (
+ % If the typeinfo is available in a variable,
+ % just use it
+ TypeInfoLocn = type_info(TypeInfoVar),
+ Var = TypeInfoVar,
+ ExtraGoals = [],
+ Info = Info0
+ ;
+ % 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)
+ ).
+
+:- pred extract_type_info(tvar, prog_var, int, list(hlds_goal),
prog_var, poly_info, poly_info).
-:- mode extract_type_info(in, in, in, in, out, out, in, out) is det.
+:- mode extract_type_info(in, in, in, out, out, in, out) is det.
-extract_type_info(Type, TypeVar, TypeClassInfoVar, Index, Goals,
+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_type_info_map(PolyInfo0, TypeInfoLocns0),
poly_info_get_module_info(PolyInfo0, ModuleInfo),
- extract_type_info_2(Type, TypeVar, TypeClassInfoVar, Index, ModuleInfo,
- Goals, TypeInfoVar, VarSet0, VarTypes0, TypeInfoLocns0,
+ polymorphism__gen_extract_type_info(TypeVar, TypeClassInfoVar, Index,
+ ModuleInfo, Goals, TypeInfoVar,
+ VarSet0, VarTypes0, TypeInfoLocns0,
VarSet, VarTypes, TypeInfoLocns),
poly_info_set_varset_and_types(VarSet, VarTypes, PolyInfo0, PolyInfo1),
poly_info_set_type_info_map(TypeInfoLocns, PolyInfo1, PolyInfo).
-:- pred extract_type_info_2(type, tvar, prog_var, int, module_info,
- list(hlds_goal), prog_var, prog_varset, map(prog_var, type),
- map(tvar, type_info_locn), prog_varset, map(prog_var, type),
- map(tvar, type_info_locn)).
-:- mode extract_type_info_2(in, in, in, in, in, out, out, in, in, in, out, out,
- out) is det.
-
-extract_type_info_2(Type, _TypeVar, TypeClassInfoVar, Index, ModuleInfo, Goals,
- TypeInfoVar, VarSet0, VarTypes0, TypeInfoLocns0,
+polymorphism__gen_extract_type_info(TypeVar, TypeClassInfoVar, Index,
+ ModuleInfo, Goals, TypeInfoVar,
+ VarSet0, VarTypes0, TypeInfoLocns0,
VarSet, VarTypes, TypeInfoLocns0) :-
% We need a tvarset to pass to get_pred_id_and_proc_id
@@ -2703,8 +2848,8 @@
polymorphism__make_count_var(Index, VarSet0, VarTypes0, IndexVar,
IndexGoal, VarSet1, VarTypes1),
- polymorphism__new_type_info_var(Type, "type_info", VarSet1, VarTypes1,
- TypeInfoVar, VarSet, VarTypes),
+ polymorphism__new_type_info_var(term__variable(TypeVar), "type_info",
+ VarSet1, VarTypes1, TypeInfoVar, VarSet, VarTypes),
% Make the goal info for the call.
% `type_info_from_typeclass_info' does not require an extra
@@ -3007,6 +3152,7 @@
).
%---------------------------------------------------------------------------%
+%---------------------------------------------------------------------------%
:- type poly_info --->
poly_info(
@@ -3039,30 +3185,49 @@
% calculated here in
% polymorphism.m
- string, % pred name
+ pred_info,
module_info,
- pred_markers, % from the pred_info
- aditi_owner
+ unit,
+ unit
).
-init_poly_info(ModuleInfo, PredInfo, ProcInfo, PolyInfo) :-
- pred_info_name(PredInfo, PredName),
+%---------------------------------------------------------------------------%
+
+ % 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.
+
+init_poly_info(ModuleInfo, PredInfo, ClausesInfo, PolyInfo) :-
+ clauses_info_varset(ClausesInfo, VarSet),
+ clauses_info_vartypes(ClausesInfo, VarTypes),
pred_info_typevarset(PredInfo, TypeVarSet),
pred_info_get_constraint_proofs(PredInfo, Proofs),
- pred_info_get_markers(PredInfo, Markers),
- pred_info_get_aditi_owner(PredInfo, Owner),
- proc_info_varset(ProcInfo, VarSet),
- proc_info_vartypes(ProcInfo, VarTypes),
map__init(TypeInfoMap),
map__init(TypeClassInfoMap),
PolyInfo = poly_info(VarSet, VarTypes, TypeVarSet,
TypeInfoMap, TypeClassInfoMap,
- Proofs, PredName, ModuleInfo, Markers, Owner).
+ Proofs, PredInfo, ModuleInfo, unit, unit).
+
+ % create_poly_info creates a poly_info for an existing procedure.
+ % (See also init_poly_info.)
+create_poly_info(ModuleInfo, PredInfo, ProcInfo, PolyInfo) :-
+ pred_info_typevarset(PredInfo, TypeVarSet),
+ pred_info_get_constraint_proofs(PredInfo, Proofs),
+ proc_info_varset(ProcInfo, VarSet),
+ 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, unit, unit).
poly_info_extract(Info, PredInfo0, PredInfo,
ProcInfo0, ProcInfo, ModuleInfo) :-
Info = poly_info(VarSet, VarTypes, TypeVarSet, TypeInfoMap,
- TypeclassInfoLocations, _Proofs, _Name, ModuleInfo, _, _),
+ TypeclassInfoLocations, _Proofs, _OldPredInfo, ModuleInfo,
+ _, _),
% set the new values of the fields in proc_info and pred_info
proc_info_set_varset(ProcInfo0, VarSet, ProcInfo1),
@@ -3072,6 +3237,8 @@
ProcInfo),
pred_info_set_typevarset(PredInfo0, TypeVarSet, PredInfo).
+%---------------------------------------------------------------------------%
+
:- pred poly_info_get_varset(poly_info, prog_varset).
:- mode poly_info_get_varset(in, out) is det.
@@ -3110,29 +3277,17 @@
poly_info_get_proofs(PolyInfo, Proofs) :-
PolyInfo = poly_info(_, _, _, _, _, Proofs, _, _, _, _).
-:- pred poly_info_get_pred_name(poly_info, string).
-:- mode poly_info_get_pred_name(in, out) is det.
+:- pred poly_info_get_pred_info(poly_info, pred_info).
+:- mode poly_info_get_pred_info(in, out) is det.
-poly_info_get_pred_name(PolyInfo, PredName) :-
- PolyInfo = poly_info(_, _, _, _, _, _, PredName, _, _, _).
+poly_info_get_pred_info(PolyInfo, PredInfo) :-
+ PolyInfo = poly_info(_, _, _, _, _, _, PredInfo, _, _, _).
:- pred poly_info_get_module_info(poly_info, module_info).
:- mode poly_info_get_module_info(in, out) is det.
poly_info_get_module_info(PolyInfo, ModuleInfo) :-
PolyInfo = poly_info(_, _, _, _, _, _, _, ModuleInfo, _, _).
-
-:- pred poly_info_get_markers(poly_info, pred_markers).
-:- mode poly_info_get_markers(in, out) is det.
-
-poly_info_get_markers(PolyInfo, Markers) :-
- PolyInfo = poly_info(_, _, _, _, _, _, _, _, Markers, _).
-
-:- pred poly_info_get_aditi_owner(poly_info, aditi_owner).
-:- mode poly_info_get_aditi_owner(in, out) is det.
-
-poly_info_get_aditi_owner(PolyInfo, Owner) :-
- PolyInfo = poly_info(_, _, _, _, _, _, _, _, _, Owner).
:- pred poly_info_set_varset(prog_varset, poly_info, poly_info).
:- mode poly_info_set_varset(in, in, out) is det.
Index: compiler/post_typecheck.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/post_typecheck.m,v
retrieving revision 1.6
diff -u -r1.6 post_typecheck.m
--- post_typecheck.m 1999/06/01 09:44:13 1.6
+++ post_typecheck.m 1999/06/09 11:12:28
@@ -58,9 +58,9 @@
:- mode post_typecheck__resolve_pred_overloading(in, in, in, in, in,
out, out) is det.
- % Do the stuff needed to initialize the proc_infos so that
- % a pred is ready for mode checking (copy clauses from the
- % clause_info to the proc_info, etc.)
+ % Do the stuff needed to initialize the pred_infos and proc_infos
+ % so that a pred is ready for running polymorphism and then
+ % mode checking.
% Also check that all predicates with an `aditi' marker have
% an `aditi:state' argument.
%
@@ -95,7 +95,8 @@
post_typecheck__check_type_bindings(PredId, PredInfo0, PredInfo, ModuleInfo,
NumErrors, IOState0, IOState) :-
- pred_info_get_unproven_body_constraints(PredInfo0, UnprovenConstraints0),
+ pred_info_get_unproven_body_constraints(PredInfo0,
+ UnprovenConstraints0),
( UnprovenConstraints0 \= [] ->
list__sort_and_remove_dups(UnprovenConstraints0,
UnprovenConstraints),
@@ -109,7 +110,8 @@
pred_info_clauses_info(PredInfo0, ClausesInfo0),
pred_info_get_head_type_params(PredInfo0, HeadTypeParams),
- ClausesInfo0 = clauses_info(VarSet, B, VarTypesMap0, HeadVars, E),
+ clauses_info_varset(ClausesInfo0, VarSet),
+ clauses_info_vartypes(ClausesInfo0, VarTypesMap0),
map__to_assoc_list(VarTypesMap0, VarTypesList),
set__init(Set0),
check_type_bindings_2(VarTypesList, HeadTypeParams,
@@ -129,7 +131,8 @@
%
pred_info_context(PredInfo0, Context),
bind_type_vars_to_void(Set, Context, VarTypesMap0, VarTypesMap),
- ClausesInfo = clauses_info(VarSet, B, VarTypesMap, HeadVars, E),
+ clauses_info_set_vartypes(ClausesInfo0, VarTypesMap,
+ ClausesInfo),
pred_info_set_clauses_info(PredInfo0, ClausesInfo, PredInfo)
),
@@ -310,7 +313,7 @@
%
pred_info_typevarset(CallerPredInfo, TVarSet),
pred_info_clauses_info(CallerPredInfo, ClausesInfo),
- ClausesInfo = clauses_info(_, _, VarTypes, _, _),
+ clauses_info_vartypes(ClausesInfo, VarTypes),
typecheck__resolve_pred_overloading(ModuleInfo, Args0,
VarTypes, TVarSet, PredName0, PredName, PredId)
;
@@ -321,15 +324,14 @@
%-----------------------------------------------------------------------------%
%
- % Copy clauses to procs, then ensure that all
- % constructors occurring in predicate mode
+ % Add a default mode for functions if none was specified, and
+ % ensure that all constructors occurring in predicate mode
% declarations are module qualified.
%
-post_typecheck__finish_pred(ModuleInfo, PredId, PredInfo1, PredInfo) -->
- { maybe_add_default_mode(PredInfo1, PredInfo2, _) },
- { copy_clauses_to_procs(PredInfo2, PredInfo3) },
+post_typecheck__finish_pred(ModuleInfo, PredId, PredInfo0, PredInfo) -->
+ { maybe_add_default_mode(PredInfo0, PredInfo1, _) },
post_typecheck__propagate_types_into_modes(ModuleInfo, PredId,
- PredInfo3, PredInfo).
+ PredInfo1, PredInfo).
%
% For ill-typed preds, we just need to set the modes up correctly
@@ -337,10 +339,8 @@
% won't result in spurious mode errors.
%
post_typecheck__finish_ill_typed_pred(ModuleInfo, PredId,
- PredInfo0, PredInfo) -->
- { maybe_add_default_mode(PredInfo0, PredInfo1, _) },
- post_typecheck__propagate_types_into_modes(ModuleInfo, PredId,
- PredInfo1, PredInfo).
+ PredInfo0, PredInfo) -->
+ post_typecheck__finish_pred(ModuleInfo, PredId, PredInfo0, PredInfo).
%
% For imported preds, we just need to ensure that all
Index: compiler/purity.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/purity.m,v
retrieving revision 1.13
diff -u -r1.13 purity.m
--- purity.m 1999/03/05 13:09:31 1.13
+++ purity.m 1999/06/09 11:08:56
@@ -216,7 +216,7 @@
% operators, and that we never need `pure' indicators/declarations.
write_purity_prefix(Purity) -->
- ( { Purity = pure } ->
+ ( { Purity = pure } ->
[]
;
write_purity(Purity),
@@ -322,36 +322,36 @@
:- mode puritycheck_pred(in, in, out, in, out, di, uo) is det.
puritycheck_pred(PredId, PredInfo0, PredInfo, ModuleInfo, NumErrors) -->
- { pred_info_get_purity(PredInfo0, DeclPurity)} ,
+ { pred_info_get_purity(PredInfo0, DeclPurity) } ,
{ pred_info_get_promised_pure(PredInfo0, Promised) },
- ( { pred_info_get_goal_type(PredInfo0, pragmas) } ->
+ ( { pred_info_get_goal_type(PredInfo0, pragmas) } ->
{ WorstPurity = (impure) },
{ Purity = pure },
{ PredInfo = PredInfo0 },
{ NumErrors0 = 0 }
;
{ pred_info_clauses_info(PredInfo0, ClausesInfo0) },
- { ClausesInfo0 = clauses_info(A, B, C, D, Clauses0) },
- { ClausesInfo = clauses_info(A, B, C, D, Clauses) },
- { pred_info_set_clauses_info(PredInfo0, ClausesInfo,
- PredInfo) },
+ { clauses_info_clauses(ClausesInfo0, Clauses0) },
compute_purity(Clauses0, Clauses, PredInfo0, ModuleInfo,
- pure, Purity, 0, NumErrors0),
+ pure, Purity, 0, NumErrors0),
+ { clauses_info_set_clauses(ClausesInfo0, Clauses,
+ ClausesInfo) },
+ { pred_info_set_clauses_info(PredInfo0, ClausesInfo,
+ PredInfo) },
{ WorstPurity = Purity }
),
- (
- { DeclPurity \= pure, Promised = yes } ->
+ ( { DeclPurity \= pure, Promised = yes } ->
{ NumErrors is NumErrors0 + 1 },
error_inconsistent_promise(ModuleInfo, PredInfo, PredId,
DeclPurity)
- ; { less_pure(DeclPurity, WorstPurity) } ->
+ ; { less_pure(DeclPurity, WorstPurity) } ->
{ NumErrors = NumErrors0 },
warn_exaggerated_impurity_decl(ModuleInfo, PredInfo, PredId,
DeclPurity, WorstPurity)
- ; { less_pure(Purity, DeclPurity), Promised = no } ->
+ ; { less_pure(Purity, DeclPurity), Promised = no } ->
{ NumErrors is NumErrors0 + 1 },
error_inferred_impure(ModuleInfo, PredInfo, PredId, Purity)
- ; { Purity = pure, Promised = yes } ->
+ ; { Purity = pure, Promised = yes } ->
{ NumErrors = NumErrors0 },
warn_unnecessary_promise_pure(ModuleInfo, PredInfo, PredId)
;
@@ -402,17 +402,17 @@
{ pred_info_get_purity(CalleePredInfo, ActualPurity) },
{ infer_goal_info_purity(GoalInfo, DeclaredPurity) },
{ goal_info_get_context(GoalInfo, CallContext) },
- ( { code_util__compiler_generated(PredInfo) } ->
+ ( { code_util__compiler_generated(PredInfo) } ->
% Don't require purity annotations on calls in
% compiler-generated code
{ NumErrors = NumErrors0 }
- ; { ActualPurity = DeclaredPurity } ->
+ ; { ActualPurity = DeclaredPurity } ->
{ NumErrors = NumErrors0 }
- ; { InClosure = yes } ->
+ ; { InClosure = yes } ->
% Don't report purity errors inside closures: the whole
% closure is an error if it's not pure
{ NumErrors = NumErrors0 }
- ; { less_pure(ActualPurity, DeclaredPurity) } ->
+ ; { less_pure(ActualPurity, DeclaredPurity) } ->
error_missing_body_impurity_decl(ModuleInfo, CalleePredInfo,
PredId, CallContext,
ActualPurity),
@@ -437,7 +437,7 @@
pure, NumErrors0, NumErrors) -->
{ Unif0 = unify(A,RHS0,C,D,E) },
{ Unif = unify(A,RHS,C,D,E) },
- ( { RHS0 = lambda_goal(F, G, H, I, J, Goal0 - Info0) } ->
+ ( { RHS0 = lambda_goal(F, G, H, I, J, Goal0 - Info0) } ->
{ RHS = lambda_goal(F, G, H, I, J, Goal - Info0) },
compute_expr_purity(Goal0, Goal, Info0, PredInfo, ModuleInfo,
yes, Purity, NumErrors0, NumErrors1),
@@ -617,7 +617,7 @@
write_purity(Purity),
io__write_string(".\n"),
prog_out__write_context(Context),
- ( { code_util__compiler_generated(PredInfo) } ->
+ ( { code_util__compiler_generated(PredInfo) } ->
io__write_string(" It must be pure.\n")
;
io__write_string(" It must be declared `"),
@@ -660,7 +660,7 @@
write_purity(DeclaredPurity),
io__write_string("' indicator.\n"),
prog_out__write_context(Context),
- ( { ActualPurity = pure } ->
+ ( { ActualPurity = pure } ->
io__write_string(" No purity indicator is necessary.\n")
;
io__write_string(" A purity indicator of `"),
@@ -674,7 +674,7 @@
:- mode error_if_closure_impure(in, in, in, out, di, uo) is det.
error_if_closure_impure(GoalInfo, Purity, NumErrors0, NumErrors) -->
- ( { Purity = pure } ->
+ ( { Purity = pure } ->
{ NumErrors = NumErrors0 }
;
{ NumErrors is NumErrors0 + 1 },
@@ -684,7 +684,7 @@
write_purity(Purity),
io__write_string(".\n"),
globals__io_lookup_bool_option(verbose_errors, VerboseErrors),
- ( { VerboseErrors = yes } ->
+ ( { VerboseErrors = yes } ->
prog_out__write_context(Context),
io__write_string(" All closures must be pure.\n")
;
Index: compiler/quantification.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/quantification.m,v
retrieving revision 1.64
diff -u -r1.64 quantification.m
--- quantification.m 1999/03/13 01:29:10 1.64
+++ quantification.m 1999/06/09 18:08:47
@@ -68,8 +68,11 @@
%-----------------------------------------------------------------------------%
:- implementation.
+
+:- import_module instmap, goal_util.
+
:- import_module term, varset.
-:- import_module std_util, bool, goal_util, require.
+:- import_module std_util, bool, require.
% The `outside vars', `lambda outside vars', and `quant vars'
% fields are inputs; the `nonlocals' field is output; and
@@ -168,7 +171,16 @@
{ Goal = Goal1 },
{ GoalInfo1 = GoalInfo0 }
),
- { goal_info_set_nonlocals(GoalInfo1, NonLocalVars, GoalInfo) }.
+ { goal_info_set_nonlocals(GoalInfo1, NonLocalVars, GoalInfo2) },
+ %
+ % If the non-locals set has shrunk (e.g. because some optimization
+ % optimizes away the other occurrences of a variable, causing it
+ % to become local when previously it was non-local),
+ % then we may need to likewise shrink the instmap delta.
+ %
+ { goal_info_get_instmap_delta(GoalInfo2, InstMapDelta0) },
+ { instmap_delta_restrict(InstMapDelta0, NonLocalVars, InstMapDelta) },
+ { goal_info_set_instmap_delta(GoalInfo2, InstMapDelta, GoalInfo) }.
:- pred implicitly_quantify_goal_2(hlds_goal_expr, prog_context,
hlds_goal_expr, quant_info, quant_info).
Index: compiler/rl_exprn.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/rl_exprn.m,v
retrieving revision 1.3
diff -u -r1.3 rl_exprn.m
--- rl_exprn.m 1999/04/28 01:18:39 1.3
+++ rl_exprn.m 1999/06/03 17:41:49
@@ -915,7 +915,7 @@
{ ArgCodes = empty }
),
{ Code = tree(TestCode, ArgCodes) }.
-rl_exprn__unify(complicated_unify(_, _), _, _, _) -->
+rl_exprn__unify(complicated_unify(_, _, _), _, _, _) -->
{ error("rl_gen__unify: complicated_unify") }.
rl_exprn__unify(assign(Var1, Var2), _GoalInfo, _Fail, Code) -->
rl_exprn_info_lookup_var(Var1, Var1Loc),
Index: compiler/rl_key.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/rl_key.m,v
retrieving revision 1.1
diff -u -r1.1 rl_key.m
--- rl_key.m 1998/12/06 23:45:23 1.1
+++ rl_key.m 1999/06/03 17:41:55
@@ -693,7 +693,7 @@
rl_key__extract_key_range_unify(
deconstruct(Var, ConsId, Args, _, _)) -->
rl_key__unify_functor(Var, ConsId, Args).
-rl_key__extract_key_range_unify(complicated_unify(_, _)) -->
+rl_key__extract_key_range_unify(complicated_unify(_, _, _)) -->
{ error("rl_key__extract_key_range_unify") }.
:- pred rl_key__unify_functor(prog_var::in, cons_id::in, list(prog_var)::in,
Index: compiler/simplify.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/simplify.m,v
retrieving revision 1.66
diff -u -r1.66 simplify.m
--- simplify.m 1998/12/06 23:45:50 1.66
+++ simplify.m 1999/06/10 15:04:06
@@ -77,7 +77,9 @@
:- import_module hlds_module, hlds_data, (inst), inst_match, varset.
:- import_module options, passes_aux, prog_data, mode_util, type_util.
:- import_module code_util, quantification, modes, purity, pd_cost.
-:- import_module set, require, std_util, int.
+:- import_module prog_util, unify_proc, special_pred, polymorphism.
+
+:- import_module set, require, std_util, int, term.
%-----------------------------------------------------------------------------%
@@ -339,14 +341,6 @@
% code generator would fail for these.
% XXX we should warn about this (if the goal wasn't `true')
%
-
- % XXX this optimization is currently disabled for anything
- % other than unifications, since it mishandles calls to
- % existentially typed predicates.
- % The fix for this is to run polymorphism.m before simplify.m.
- % When that is done, we can re-enable this optimization.
- Goal0 = unify(_, _, _, _, _) - _,
-
determinism_components(Detism, cannot_fail, MaxSoln),
MaxSoln \= at_most_zero,
goal_info_get_instmap_delta(GoalInfo0, InstMapDelta),
@@ -776,6 +770,18 @@
Goal = unify(LT0, RT, M, U0, C),
GoalInfo = GoalInfo0
;
+ U0 = complicated_unify(UniMode, CanFail, TypeInfoVars)
+ ->
+ ( RT0 = var(V) ->
+ simplify__process_compl_unify(LT0, V,
+ UniMode, CanFail, TypeInfoVars,
+ C, GoalInfo0, Goal1,
+ Info0, Info),
+ Goal1 = Goal - GoalInfo
+ ;
+ error("simplify.m: invalid RHS for complicated unify")
+ )
+ ;
simplify_do_common(Info0)
->
common__optimise_unification(U0, LT0, RT0, M, C,
@@ -999,6 +1005,220 @@
%-----------------------------------------------------------------------------%
+:- pred simplify__process_compl_unify(prog_var, prog_var,
+ uni_mode, can_fail, list(prog_var), unify_context,
+ hlds_goal_info, hlds_goal, simplify_info, simplify_info).
+:- mode simplify__process_compl_unify(in, in, in, in, in, in, in, out,
+ in, out) is det.
+
+simplify__process_compl_unify(XVar, YVar, UniMode, CanFail, OldTypeInfoVars,
+ Context, GoalInfo0, Goal) -->
+ %
+ % XXX FIXME change mode analysis to check modes of typeinfos for
+ % complicated unifications
+ %
+ =(Info0),
+ { simplify_info_get_module_info(Info0, ModuleInfo) },
+ { simplify_info_get_var_types(Info0, VarTypes) },
+ { map__lookup(VarTypes, XVar, Type) },
+ ( { Type = term__variable(TypeVar) } ->
+ %
+ % Convert polymorphic unifications into calls to
+ % `unify/2', the general unification predicate, passing
+ % the appropriate type_info
+ % unify(TypeInfoVar, X, Y)
+ % where TypeInfoVar is the type_info variable
+ % associated with the type of the variables that
+ % are being unified.
+ %
+ simplify__type_info_locn(TypeVar, TypeInfoVar, ExtraGoals),
+ { ArgVars = [TypeInfoVar, XVar, YVar] },
+
+ % sanity check: the TypeInfoVars we computed here should
+ % match with what was stored in the complicated_unify struct
+ { require(unify(OldTypeInfoVars, [TypeInfoVar]),
+ "simplify__process_compl_unify: mismatched type_info vars") },
+
+ { module_info_get_predicate_table(ModuleInfo,
+ PredicateTable) },
+ { mercury_public_builtin_module(MercuryBuiltin) },
+ { predicate_table_search_pred_m_n_a(PredicateTable,
+ MercuryBuiltin, "unify", 2, [CallPredId])
+ ->
+ PredId = CallPredId
+ ;
+ error("simplify.m: can't find `builtin:unify/2'")
+ },
+ % Note: the mode for polymorphic unifications
+ % should be `in, in'.
+ % (This should have been checked by mode analysis.)
+ { hlds_pred__in_in_unification_proc_id(ProcId) },
+
+ { SymName = unqualified("unify") },
+ { code_util__builtin_state(ModuleInfo, PredId, ProcId,
+ BuiltinState) },
+ { CallContext = call_unify_context(XVar, var(YVar), Context) },
+ { Call = call(PredId, ProcId, ArgVars,
+ BuiltinState, yes(CallContext), SymName)
+ - GoalInfo0 }
+
+ ; { type_is_higher_order(Type, _, _) } ->
+ %
+ % convert higher-order unifications into calls to
+ % builtin_unify_pred (which calls error/1)
+ %
+ { SymName = unqualified("builtin_unify_pred") },
+ { ArgVars = [XVar, YVar] },
+ { module_info_get_predicate_table(ModuleInfo,
+ PredicateTable) },
+ {
+ mercury_private_builtin_module(PrivateBuiltin),
+ predicate_table_search_pred_m_n_a(
+ PredicateTable,
+ PrivateBuiltin, "builtin_unify_pred", 2,
+ [PredId0])
+ ->
+ PredId = PredId0
+ ;
+ error("can't locate private_builtin:builtin_unify_pred/2")
+ },
+ { hlds_pred__in_in_unification_proc_id(ProcId) },
+ { CallContext = call_unify_context(XVar, var(YVar), Context) },
+ { Call0 = call(PredId, ProcId, ArgVars, not_builtin,
+ yes(CallContext), SymName) },
+ simplify__goal_2(Call0, GoalInfo0, Call1, GoalInfo),
+ { Call = Call1 - GoalInfo },
+ { ExtraGoals = [] }
+
+ ; { type_to_type_id(Type, TypeId, TypeArgs) } ->
+ %
+ % Convert other complicated unifications into
+ % calls to specific unification predicates,
+ % inserting extra typeinfo arguments if necessary.
+ %
+ simplify__make_type_info_vars(TypeArgs, TypeInfoVars,
+ ExtraGoals),
+ { list__append(TypeInfoVars, [XVar, YVar], ArgVars) },
+
+ % sanity check: the TypeInfoVars we computed here should
+ % match with what was stored in the complicated_unify struct
+ { require(unify(OldTypeInfoVars, TypeInfoVars),
+ "simplify__process_compl_unify: mismatched type_info vars") },
+
+ { module_info_get_special_pred_map(ModuleInfo,
+ SpecialPredMap) },
+ { map__lookup(SpecialPredMap, unify - TypeId, PredId) },
+ { determinism_components(Det, CanFail, at_most_one) },
+ { unify_proc__lookup_mode_num(ModuleInfo, TypeId,
+ UniMode, Det, ProcId) },
+ { SymName = unqualified("__Unify__") },
+ { CallContext = call_unify_context(XVar, var(YVar), Context) },
+ { Call0 = call(PredId, ProcId, ArgVars, not_builtin,
+ yes(CallContext), SymName) },
+ simplify__goal_2(Call0, GoalInfo0, Call1, GoalInfo),
+ { Call = Call1 - GoalInfo }
+ ;
+ { error("simplify: type_to_type_id failed") }
+ ),
+ { list__append(ExtraGoals, [Call], ConjList) },
+ { conj_list_to_goal(ConjList, GoalInfo0, Goal) }.
+
+:- pred simplify__make_type_info_vars(list(type)::in, list(prog_var)::out,
+ list(hlds_goal)::out, simplify_info::in, simplify_info::out) is det.
+
+simplify__make_type_info_vars(Types, TypeInfoVars, TypeInfoGoals,
+ Info0, Info) :-
+ %
+ % Extract the information from simplify_info
+ %
+ simplify_info_get_det_info(Info0, DetInfo0),
+ simplify_info_get_varset(Info0, VarSet0),
+ simplify_info_get_var_types(Info0, VarTypes0),
+ det_info_get_module_info(DetInfo0, ModuleInfo0),
+ det_info_get_pred_id(DetInfo0, PredId),
+ det_info_get_proc_id(DetInfo0, ProcId),
+
+ %
+ % Put the varset and vartypes from the simplify_info
+ % back in the proc_info
+ %
+ module_info_pred_proc_info(ModuleInfo0, PredId, ProcId,
+ PredInfo0, ProcInfo0),
+ proc_info_set_vartypes(ProcInfo0, VarTypes0, ProcInfo1),
+ proc_info_set_varset(ProcInfo1, VarSet0, ProcInfo2),
+
+ %
+ % Call polymorphism.m to create the type_infos
+ %
+ create_poly_info(ModuleInfo0, PredInfo0, ProcInfo2, PolyInfo0),
+ ExistQVars = [],
+ term__context_init(Context),
+ polymorphism__make_type_info_vars(Types, ExistQVars, Context,
+ TypeInfoVars, TypeInfoGoals, PolyInfo0, PolyInfo),
+ poly_info_extract(PolyInfo, PredInfo0, PredInfo,
+ ProcInfo0, ProcInfo, ModuleInfo1),
+
+ %
+ % Get the new varset and vartypes from the proc_info
+ % and put them back in the simplify_info.
+ %
+ proc_info_vartypes(ProcInfo, VarTypes),
+ proc_info_varset(ProcInfo, VarSet),
+ simplify_info_set_var_types(Info0, VarTypes, Info1),
+ simplify_info_set_varset(Info1, VarSet, Info2),
+
+ %
+ % Put the new proc_info and pred_info back
+ % in the module_info and put the new module_info
+ % back in the simplify_info.
+ %
+ module_info_set_pred_proc_info(ModuleInfo1, PredId, ProcId,
+ PredInfo, ProcInfo, ModuleInfo),
+ simplify_info_set_module_info(Info2, ModuleInfo, Info).
+
+:- pred simplify__type_info_locn(tvar, prog_var, list(hlds_goal),
+ simplify_info, simplify_info).
+:- mode simplify__type_info_locn(in, out, out, in, out) is det.
+
+simplify__type_info_locn(TypeVar, TypeInfoVar, Goals) -->
+ =(Info0),
+ { simplify_info_get_typeinfo_map(Info0, TypeInfoMap) },
+ { map__lookup(TypeInfoMap, TypeVar, TypeInfoLocn) },
+ (
+ % If the typeinfo is available in a variable,
+ % just use it
+ { TypeInfoLocn = type_info(TypeInfoVar) },
+ { Goals = [] }
+ ;
+ % If the typeinfo is in a typeclass_info
+ % then we need to extract it
+ { TypeInfoLocn =
+ typeclass_info(TypeClassInfoVar, Index) },
+ simplify__extract_type_info(TypeVar, TypeClassInfoVar, Index,
+ Goals, TypeInfoVar)
+ ).
+
+:- pred simplify__extract_type_info(tvar, prog_var, int,
+ list(hlds_goal), prog_var, simplify_info, simplify_info).
+:- mode simplify__extract_type_info(in, in, in, out, out, in, out) is det.
+
+simplify__extract_type_info(TypeVar, TypeClassInfoVar, Index,
+ Goals, TypeInfoVar, Info0, Info) :-
+ simplify_info_get_module_info(Info0, ModuleInfo),
+ simplify_info_get_varset(Info0, VarSet0),
+ simplify_info_get_var_types(Info0, VarTypes0),
+ simplify_info_get_typeinfo_map(Info0, TypeInfoLocns0),
+
+ polymorphism__gen_extract_type_info(TypeVar, TypeClassInfoVar, Index,
+ ModuleInfo, Goals, TypeInfoVar,
+ VarSet0, VarTypes0, TypeInfoLocns0,
+ VarSet, VarTypes, _TypeInfoLocns),
+
+ simplify_info_set_var_types(Info0, VarTypes, Info1),
+ simplify_info_set_varset(Info1, VarSet, Info).
+
+%-----------------------------------------------------------------------------%
+
% simplify__input_args_are_equiv(Args, HeadVars, Modes,
% CommonInfo, ModuleInfo1):
% Succeeds if all the input arguments (determined by looking at
@@ -1728,6 +1948,18 @@
simplify_do_more_common(Info) :-
simplify_info_get_simplifications(Info, Simplifications),
set__member(extra_common_struct, Simplifications).
+
+:- pred simplify_info_get_typeinfo_map(simplify_info::in,
+ map(tvar, type_info_locn)::out) is det.
+
+simplify_info_get_typeinfo_map(Info0, TypeInfoMap) :-
+ simplify_info_get_det_info(Info0, DetInfo0),
+ det_info_get_module_info(DetInfo0, ModuleInfo),
+ det_info_get_pred_id(DetInfo0, ThisPredId),
+ det_info_get_proc_id(DetInfo0, ThisProcId),
+ module_info_pred_proc_info(ModuleInfo, ThisPredId, ThisProcId,
+ _PredInfo, ProcInfo),
+ proc_info_typeinfo_varmap(ProcInfo, TypeInfoMap).
:- pred simplify_info_update_instmap(simplify_info::in, hlds_goal::in,
simplify_info::out) is det.
Index: compiler/term_traversal.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/term_traversal.m,v
retrieving revision 1.8
diff -u -r1.8 term_traversal.m
--- term_traversal.m 1998/11/20 04:09:26 1.8
+++ term_traversal.m 1999/06/03 17:42:05
@@ -151,7 +151,7 @@
Unification = simple_test(_InVar1, _InVar2),
Info = Info0
;
- Unification = complicated_unify(_, _),
+ Unification = complicated_unify(_, _, _),
error("Unexpected complicated_unify in termination analysis")
).
Index: compiler/typecheck.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/typecheck.m,v
retrieving revision 1.258
diff -u -r1.258 typecheck.m
--- typecheck.m 1999/03/26 11:15:45 1.258
+++ typecheck.m 1999/06/09 11:39:13
@@ -318,7 +318,7 @@
)
->
pred_info_clauses_info(PredInfo0, ClausesInfo0),
- ClausesInfo0 = clauses_info(_, _, _, _, Clauses0),
+ clauses_info_clauses(ClausesInfo0, Clauses0),
( Clauses0 = [] ->
pred_info_mark_as_external(PredInfo0, PredInfo)
;
@@ -331,8 +331,10 @@
pred_info_arg_types(PredInfo0, _ArgTypeVarSet, ExistQVars0,
ArgTypes0),
pred_info_clauses_info(PredInfo0, ClausesInfo0),
- ClausesInfo0 = clauses_info(VarSet, ExplicitVarTypes,
- _OldInferredVarTypes, HeadVars, Clauses0),
+ clauses_info_clauses(ClausesInfo0, Clauses0),
+ clauses_info_headvars(ClausesInfo0, HeadVars),
+ clauses_info_varset(ClausesInfo0, VarSet),
+ clauses_info_explicit_vartypes(ClausesInfo0, ExplicitVarTypes),
(
Clauses0 = []
->
@@ -346,8 +348,8 @@
% of the head vars into the clauses_info
map__from_corresponding_lists(HeadVars, ArgTypes0,
VarTypes),
- ClausesInfo = clauses_info(VarSet, VarTypes,
- VarTypes, HeadVars, Clauses0),
+ clauses_info_set_vartypes(ClausesInfo0, VarTypes,
+ ClausesInfo),
pred_info_set_clauses_info(PredInfo0, ClausesInfo,
PredInfo),
Error = no,
@@ -415,8 +417,9 @@
ConstraintProofs, TVarRenaming,
ExistTypeRenaming),
map__optimize(InferredVarTypes0, InferredVarTypes),
- ClausesInfo = clauses_info(VarSet, ExplicitVarTypes,
- InferredVarTypes, HeadVars, Clauses),
+ clauses_info_set_vartypes(ClausesInfo0, InferredVarTypes,
+ ClausesInfo1),
+ clauses_info_set_clauses(ClausesInfo1, Clauses, ClausesInfo),
pred_info_set_clauses_info(PredInfo0, ClausesInfo, PredInfo1),
pred_info_set_typevarset(PredInfo1, TypeVarSet, PredInfo2),
pred_info_set_constraint_proofs(PredInfo2, ConstraintProofs,
Index: compiler/unify_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/unify_gen.m,v
retrieving revision 1.98
diff -u -r1.98 unify_gen.m
--- unify_gen.m 1999/06/01 09:44:16 1.98
+++ unify_gen.m 1999/06/08 00:42:43
@@ -79,7 +79,7 @@
;
% These should have been transformed into calls
% to unification procedures by polymorphism.m.
- { Uni = complicated_unify(_UniMode, _CanFail) },
+ { Uni = complicated_unify(_UniMode, _CanFail, _TypeInfoVars) },
{ error("complicated unify during code generation") }
).
Index: compiler/unify_proc.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/unify_proc.m,v
retrieving revision 1.75
diff -u -r1.75 unify_proc.m
--- unify_proc.m 1999/06/01 09:44:17 1.75
+++ unify_proc.m 1999/06/09 10:51:54
@@ -239,7 +239,13 @@
% convert from `uni_mode' to `list(mode)'
UnifyMode = ((X_Initial - Y_Initial) -> (X_Final - Y_Final)),
- ArgModes = [(X_Initial -> X_Final), (Y_Initial -> Y_Final)],
+ ArgModes0 = [(X_Initial -> X_Final), (Y_Initial -> Y_Final)],
+
+ % for polymorphic types, add extra modes for the type_infos
+ TypeId = _TypeName - TypeArity,
+ in_mode(InMode),
+ list__duplicate(TypeArity, InMode, TypeInfoModes),
+ list__append(TypeInfoModes, ArgModes0, ArgModes),
ArgLives = no, % XXX ArgLives should be part of the UnifyId
@@ -481,7 +487,10 @@
VarTypeInfo = VarTypeInfo1
),
unify_proc__info_extract(VarTypeInfo, VarSet, Types),
- ClauseInfo = clauses_info(VarSet, Types, Types, Args, Clauses).
+ map__init(TI_VarMap),
+ map__init(TCI_VarMap),
+ ClauseInfo = clauses_info(VarSet, Types, Types, Args, Clauses,
+ TI_VarMap, TCI_VarMap).
:- pred unify_proc__generate_unify_clauses(hlds_type_body, prog_var, prog_var,
prog_context, list(clause), unify_proc_info, unify_proc_info).
Index: compiler/unused_args.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/unused_args.m,v
retrieving revision 1.56
diff -u -r1.56 unused_args.m
--- unused_args.m 1998/12/06 23:46:01 1.56
+++ unused_args.m 1999/06/03 17:43:02
@@ -514,7 +514,7 @@
).
% These should be transformed into calls by polymorphism.m.
-traverse_goal(_, unify(Var, Rhs, _, complicated_unify(_, _), _),
+traverse_goal(_, unify(Var, Rhs, _, complicated_unify(_, _, _), _),
UseInf0, UseInf) :-
% This is here to cover the case where unused arguments is called
% with --error-check-only and polymorphism has not been run.
@@ -1397,7 +1397,7 @@
).
% These should be transformed into calls by polymorphism.m.
-fixup_unify(_, _, _, complicated_unify(_, _), _) :-
+fixup_unify(_, _, _, complicated_unify(_, _, _), _) :-
error("unused_args:fixup_goal : complicated unify").
% Check if any of the arguments of a deconstruction are unused, if
Index: compiler/notes/compiler_design.html
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/notes/compiler_design.html,v
retrieving revision 1.24
diff -u -r1.24 compiler_design.html
--- compiler_design.html 1999/03/30 05:38:14 1.24
+++ compiler_design.html 1999/06/10 15:10:03
@@ -258,9 +258,30 @@
operations on it. It also calls post_typecheck.m to
complete the handling of predicate
overloading for cases which typecheck.m is unable to handle,
- to check for unbound type variables,
- and to copy the clauses to the proc_infos in
- preparation for mode analysis.
+ and to check for unbound type variables.
+
+<dt> polymorphism transformation
+
+ <dd>
+ polymorphism.m handles introduction of type_info arguments for
+ polymorphic predicates and introduction of typeclass_info arguments
+ for typeclass-constrained predicates.
+ This phase needs to come before mode analysis so that mode analysis
+ can properly reorder code involving existential types.
+ (It also needs to come before simplification so that simplify.m's
+ optimization of goals with no output variables doesn't do the
+ wrong thing for goals whose only output is the type_info for
+ an existentially quantified type parameter.)
+ <p>
+ This phase also converts function calls into predicate calls,
+ converts higher-order predicate terms into lambda expressions,
+ and copies the clauses to the proc_infos in preparation for
+ mode analysis.
+ <p>
+ The polymorphism.m module also exports some utility routines that
+ are used by other modules. These include some routines for generating
+ code to create type_infos, which are used by simplify.m and magic.m
+ when those modules introduce new calls to polymorphic procedures.
<dt> mode analysis
@@ -272,10 +293,9 @@
that specifies the changes in instantiatedness of each
variable over that goal.
<li> modecheck_unify.m is the sub-module which analyses
- unification goals. It also converts higher-order pred terms
- into lambda expressions and module qualifies data constructors.
+ unification goals.
+ It also module qualifies data constructors.
<li> modecheck_call.m is the sub-module which analyses calls.
- It also converts function calls into predicate calls.
<p>
@@ -354,12 +374,13 @@
that they should not have been included in the program in the first
place. (That's why this pass needs to be part of semantic analysis:
because it can report warnings.)
+ simplify.m converts complicated unifications into procedure calls.
simplify.m calls common.m which looks for (a) construction unifications
that construct a term that is the same as one that already exists,
or (b) repeated calls to a predicate with the same inputs, and replaces
them with assignment unifications.
simplify.m also attempts to partially evaluate calls to builtin
- procedures if the inputs are all constants (see const_prop.m).
+ procedures if the inputs are all constants (see const_prop.m),
</dl>
@@ -373,17 +394,11 @@
<p>
-The next two passes of this stage are code simplifications.
+The next pass of this stage is a code simplification, namely
+removal of lambda expressions (lambda.m):
<ul>
-<li> introduction of type_info arguments for polymorphic predicates,
- introduction of typeclass_info arguments for typeclass-constrained predicates
- and transformation of complicated unifications into predicate calls
- (polymorphism.m)
-
-<li> removal of lambda expressions (lambda.m) <br>
- <p>
-
+<li>
lambda.m converts lambda expressions into higher-order predicate
terms referring to freshly introduced separate predicates.
This pass needs to come after unique_modes.m to ensure that
@@ -392,10 +407,7 @@
doesn't handle higher-order predicate constants.
</ul>
-<p>
-
-To improve efficiency, the above two passes are actually combined into
-one - polymorphism.m calls calls lambda__transform_lambda directly.
+(Is there any good reason why lambda.m comes after table_gen.m?)
<p>
--
Fergus Henderson <fjh at cs.mu.oz.au> | "I have always known that the pursuit
WWW: <http://www.cs.mu.oz.au/~fjh> | of excellence is a lethal habit"
PGP: finger fjh at 128.250.37.3 | -- the last words of T. S. Garp.
--------------------------------------------------------------------------
mercury-developers mailing list
Post messages to: mercury-developers at cs.mu.oz.au
Administrative Queries: owner-mercury-developers at cs.mu.oz.au
Subscriptions: mercury-developers-request at cs.mu.oz.au
--------------------------------------------------------------------------
More information about the developers
mailing list