diff --git a/compiler/accumulator.m b/compiler/accumulator.m index d9953671f..2004fbd5f 100644 --- a/compiler/accumulator.m +++ b/compiler/accumulator.m @@ -1434,7 +1434,7 @@ accumulator__check_assoc_unify(assign(L, _R)) --> assoc_info_set_dynamic_set(DynamicSet). accumulator__check_assoc_unify(simple_test(_L, _R)) --> { fail }. -accumulator__check_assoc_unify(complicated_unify(_Modes, _Cat)) --> +accumulator__check_assoc_unify(complicated_unify(_Modes, _Cat, _)) --> { fail }. % XXX not sure what this should be. %-----------------------------------------------------------------------------% diff --git a/compiler/bytecode_gen.m b/compiler/bytecode_gen.m index 9f255a719..3f3aa1673 100644 --- a/compiler/bytecode_gen.m +++ b/compiler/bytecode_gen.m @@ -465,7 +465,7 @@ bytecode_gen__unify(simple_test(Var1, Var2), _, _, ByteInfo, Code) :- bytecode_gen__map_var(ByteInfo, Var1, ByteVar1), bytecode_gen__map_var(ByteInfo, Var2, ByteVar2), Code = node([test(ByteVar1, ByteVar2)]). -bytecode_gen__unify(complicated_unify(_, _), _Var, _RHS, _ByteInfo, _Code) :- +bytecode_gen__unify(complicated_unify(_,_,_), _Var, _RHS, _ByteInfo, _Code) :- error("complicated unifications should have been handled by polymorphism.m"). :- pred bytecode_gen__map_uni_modes(list(uni_mode)::in, list(prog_var)::in, diff --git a/compiler/check_typeclass.m b/compiler/check_typeclass.m index 05c1dc5ee..029a32aae 100644 --- a/compiler/check_typeclass.m +++ b/compiler/check_typeclass.m @@ -524,11 +524,13 @@ produce_auxiliary_procs(ClassVars, varset__init(VarSet0), make_n_fresh_vars("HeadVar__", PredArity, VarSet0, HeadVars, VarSet), map__from_corresponding_lists(HeadVars, ArgTypes, VarTypes), - DummyClausesInfo = clauses_info(VarSet, VarTypes, VarTypes, HeadVars, - DummyClause), + map__init(TI_VarMap), + map__init(TCI_VarMap), + ClausesInfo0 = clauses_info(VarSet, VarTypes, VarTypes, HeadVars, + DummyClause, TI_VarMap, TCI_VarMap), pred_info_init(ModuleName, PredName, PredArity, ArgTypeVars, - ExistQVars, ArgTypes, Cond, Context, DummyClausesInfo, Status, + ExistQVars, ArgTypes, Cond, Context, ClausesInfo0, Status, Markers, none, PredOrFunc, ClassContext, Proofs, User, PredInfo0), @@ -572,8 +574,7 @@ produce_auxiliary_procs(ClassVars, IntroducedGoal = IntroducedGoalExpr - GoalInfo ), IntroducedClause = clause(InstanceProcIds, IntroducedGoal, Context), - ClausesInfo = clauses_info(VarSet, VarTypes, VarTypes, HeadVars, - [IntroducedClause]), + clauses_info_set_clauses(ClausesInfo0, [IntroducedClause], ClausesInfo), pred_info_set_clauses_info(PredInfo1, ClausesInfo, PredInfo), module_info_get_predicate_table(ModuleInfo0, PredicateTable0), diff --git a/compiler/clause_to_proc.m b/compiler/clause_to_proc.m index 01e39af24..0bd885ffa 100644 --- a/compiler/clause_to_proc.m +++ b/compiler/clause_to_proc.m @@ -107,8 +107,17 @@ copy_module_clauses_to_procs(PredIds, ModuleInfo0, ModuleInfo) :- copy_module_clauses_to_procs_2([], Preds, Preds). copy_module_clauses_to_procs_2([PredId | PredIds], Preds0, Preds) :- map__lookup(Preds0, PredId, PredInfo0), - copy_clauses_to_procs(PredInfo0, PredInfo), - map__det_update(Preds0, PredId, PredInfo, Preds1), + ( + % don't process typeclass methods, because their proc_infos + % are generated already mode-correct + pred_info_get_markers(PredInfo0, PredMarkers), + check_marker(PredMarkers, class_method) + -> + Preds1 = Preds0 + ; + copy_clauses_to_procs(PredInfo0, PredInfo), + map__det_update(Preds0, PredId, PredInfo, Preds1) + ), copy_module_clauses_to_procs_2(PredIds, Preds1, Preds). @@ -131,7 +140,8 @@ copy_clauses_to_procs_2([ProcId | ProcIds], ClausesInfo, Procs0, Procs) :- copy_clauses_to_procs_2(ProcIds, ClausesInfo, Procs1, Procs). copy_clauses_to_proc(ProcId, ClausesInfo, Proc0, Proc) :- - ClausesInfo = clauses_info(VarSet, _, VarTypes, HeadVars, Clauses), + ClausesInfo = clauses_info(VarSet, _, VarTypes, HeadVars, Clauses, + TI_VarMap, TCI_VarMap), select_matching_clauses(Clauses, ProcId, MatchingClauses), get_clause_goals(MatchingClauses, GoalList), ( GoalList = [SingleGoal] -> @@ -181,7 +191,8 @@ copy_clauses_to_proc(ProcId, ClausesInfo, Proc0, Proc) :- map__init(Empty), Goal = disj(GoalList, Empty) - GoalInfo ), - proc_info_set_body(Proc0, VarSet, VarTypes, HeadVars, Goal, Proc). + proc_info_set_body(Proc0, VarSet, VarTypes, HeadVars, Goal, + TI_VarMap, TCI_VarMap, Proc). :- pred get_purity(hlds_goal, purity). :- mode get_purity(in, out) is det. diff --git a/compiler/code_util.m b/compiler/code_util.m index 2ae187724..9235fc323 100644 --- a/compiler/code_util.m +++ b/compiler/code_util.m @@ -746,7 +746,7 @@ code_util__cannot_stack_flush(GoalExpr - _) :- :- mode code_util__cannot_stack_flush_2(in) is semidet. code_util__cannot_stack_flush_2(unify(_, _, _, Unify, _)) :- - Unify \= complicated_unify(_, _). + Unify \= complicated_unify(_, _, _). code_util__cannot_stack_flush_2(call(_, _, _, BuiltinState, _, _)) :- BuiltinState = inline_builtin. code_util__cannot_stack_flush_2(conj(Goals)) :- diff --git a/compiler/dead_proc_elim.m b/compiler/dead_proc_elim.m index bd42c6b98..bbc812a2c 100644 --- a/compiler/dead_proc_elim.m +++ b/compiler/dead_proc_elim.m @@ -788,7 +788,7 @@ dead_pred_elim_analyze(DeadInfo0, DeadInfo) :- Needed, NeededNames), module_info_pred_info(ModuleInfo, PredId, PredInfo), pred_info_clauses_info(PredInfo, ClausesInfo), - ClausesInfo = clauses_info(_,_,_,_, Clauses), + clauses_info_clauses(ClausesInfo, Clauses), list__foldl(dead_pred_elim_process_clause, Clauses, DeadInfo1, DeadInfo2) ), diff --git a/compiler/dependency_graph.m b/compiler/dependency_graph.m index 9a2eb997c..de0c31971 100644 --- a/compiler/dependency_graph.m +++ b/compiler/dependency_graph.m @@ -10,6 +10,8 @@ % The dependency_graph records which procedures depend on which other % procedures. It is defined as a relation (see hlds_module.m) R where xRy % means that the definition of x depends on the definition of y. +% Note that imported procedures are not included in the dependency_graph +% (although opt_imported procedures are included). % % The other important structure is the dependency_ordering which is % a list of the cliques (strongly-connected components) of this relation, @@ -119,19 +121,14 @@ dependency_graph__add_pred_nodes([PredId | PredIds], ModuleInfo, DepGraph0, DepGraph) :- module_info_preds(ModuleInfo, PredTable), map__lookup(PredTable, PredId, PredInfo), - ( - % Don't bother adding nodes (or arcs) for predicates - % which which are imported (ie we don't have any `clauses' - % for). - pred_info_is_imported(PredInfo) - -> - DepGraph1 = DepGraph0 - ; - pred_info_procids(PredInfo, ProcIds), - dependency_graph__add_proc_nodes(ProcIds, PredId, ModuleInfo, - DepGraph0, DepGraph1) - ), - dependency_graph__add_pred_nodes(PredIds, ModuleInfo, DepGraph1, DepGraph). + % Don't bother adding nodes (or arcs) for procedures + % which which are imported (ie we don't have any `clauses' + % for). + pred_info_non_imported_procids(PredInfo, ProcIds), + dependency_graph__add_proc_nodes(ProcIds, PredId, ModuleInfo, + DepGraph0, DepGraph1), + dependency_graph__add_pred_nodes(PredIds, ModuleInfo, + DepGraph1, DepGraph). :- pred dependency_graph__add_proc_nodes(list(proc_id), pred_id, module_info, dependency_graph, dependency_graph). @@ -156,16 +153,11 @@ dependency_graph__add_pred_arcs([PredId | PredIds], ModuleInfo, DepGraph0, DepGraph) :- module_info_preds(ModuleInfo, PredTable), map__lookup(PredTable, PredId, PredInfo), - ( - pred_info_is_imported(PredInfo) - -> - DepGraph1 = DepGraph0 - ; - pred_info_procids(PredInfo, ProcIds), - dependency_graph__add_proc_arcs(ProcIds, PredId, ModuleInfo, - DepGraph0, DepGraph1) - ), - dependency_graph__add_pred_arcs(PredIds, ModuleInfo, DepGraph1, DepGraph). + pred_info_non_imported_procids(PredInfo, ProcIds), + dependency_graph__add_proc_arcs(ProcIds, PredId, ModuleInfo, + DepGraph0, DepGraph1), + dependency_graph__add_pred_arcs(PredIds, ModuleInfo, + DepGraph1, DepGraph). :- pred dependency_graph__add_proc_arcs(list(proc_id), pred_id, module_info, dependency_graph, dependency_graph). @@ -271,7 +263,7 @@ dependency_graph__add_arcs_in_goal_2(unify(_,_,_,Unify,_), Caller, ; Unify = deconstruct(_, Cons, _, _, _), dependency_graph__add_arcs_in_cons(Cons, Caller, DepGraph0, DepGraph) - ; Unify = complicated_unify(_, _), + ; Unify = complicated_unify(_, _, _), DepGraph0 = DepGraph ). diff --git a/compiler/det_analysis.m b/compiler/det_analysis.m index 3d0453176..bd8639990 100644 --- a/compiler/det_analysis.m +++ b/compiler/det_analysis.m @@ -1,5 +1,5 @@ %-----------------------------------------------------------------------------% -% Copyright (C) 1994-1998 The University of Melbourne. +% Copyright (C) 1994-1999 The University of Melbourne. % This file may only be copied under the terms of the GNU General % Public License - see the file COPYING in the Mercury distribution. %-----------------------------------------------------------------------------% @@ -925,7 +925,7 @@ det_infer_unify_examines_rep(assign(_, _), no). det_infer_unify_examines_rep(construct(_, _, _, _), no). det_infer_unify_examines_rep(deconstruct(_, _, _, _, _), yes). det_infer_unify_examines_rep(simple_test(_, _), yes). -det_infer_unify_examines_rep(complicated_unify(_, _), no). +det_infer_unify_examines_rep(complicated_unify(_, _, _), no). % Some complicated modes of complicated unifications _do_ % examine the representation... % but we will catch those by reporting errors in the @@ -949,7 +949,7 @@ det_infer_unify_canfail(deconstruct(_, _, _, _, CanFail), CanFail). det_infer_unify_canfail(assign(_, _), cannot_fail). det_infer_unify_canfail(construct(_, _, _, _), cannot_fail). det_infer_unify_canfail(simple_test(_, _), can_fail). -det_infer_unify_canfail(complicated_unify(_, CanFail), CanFail). +det_infer_unify_canfail(complicated_unify(_, CanFail, _), CanFail). %-----------------------------------------------------------------------------% diff --git a/compiler/det_report.m b/compiler/det_report.m index efef4371f..d075f341a 100644 --- a/compiler/det_report.m +++ b/compiler/det_report.m @@ -1,5 +1,5 @@ %-----------------------------------------------------------------------------% -% Copyright (C) 1995-1998 The University of Melbourne. +% Copyright (C) 1995-1999 The University of Melbourne. % This file may only be copied under the terms of the GNU General % Public License - see the file COPYING in the Mercury distribution. %-----------------------------------------------------------------------------% @@ -29,6 +29,8 @@ ; ite_cond_cannot_succeed(prog_context) ; negated_goal_cannot_fail(prog_context) ; negated_goal_cannot_succeed(prog_context) + ; goal_cannot_succeed(prog_context) + ; det_goal_has_no_outputs(prog_context) ; warn_obsolete(pred_id, prog_context) % warning about calls to predicates % for which there is a `:- pragma obsolete' @@ -997,7 +999,9 @@ det_msg_get_type(ite_cond_cannot_fail(_), simple_code_warning). det_msg_get_type(ite_cond_cannot_succeed(_), simple_code_warning). det_msg_get_type(negated_goal_cannot_fail(_), simple_code_warning). det_msg_get_type(negated_goal_cannot_succeed(_), simple_code_warning). - % XXX this isn't really a simple code warning. +det_msg_get_type(goal_cannot_succeed(_), simple_code_warning). +det_msg_get_type(det_goal_has_no_outputs(_), simple_code_warning). + % XXX warn_obsolete isn't really a simple code warning. % We should add a separate warning type for this. det_msg_get_type(warn_obsolete(_, _), simple_code_warning). det_msg_get_type(warn_infinite_recursion(_), simple_code_warning). @@ -1019,6 +1023,8 @@ det_msg_is_any_mode_msg(ite_cond_cannot_fail(_), all_modes). det_msg_is_any_mode_msg(ite_cond_cannot_succeed(_), all_modes). det_msg_is_any_mode_msg(negated_goal_cannot_fail(_), all_modes). det_msg_is_any_mode_msg(negated_goal_cannot_succeed(_), all_modes). +det_msg_is_any_mode_msg(goal_cannot_succeed(_), all_modes). +det_msg_is_any_mode_msg(det_goal_has_no_outputs(_), all_modes). det_msg_is_any_mode_msg(warn_obsolete(_, _), all_modes). det_msg_is_any_mode_msg(warn_infinite_recursion(_), any_mode). det_msg_is_any_mode_msg(duplicate_call(_, _, _), any_mode). @@ -1076,6 +1082,28 @@ det_report_msg(negated_goal_cannot_fail(Context), _) --> det_report_msg(negated_goal_cannot_succeed(Context), _) --> prog_out__write_context(Context), io__write_string("Warning: the negated goal cannot succeed.\n"). +det_report_msg(goal_cannot_succeed(Context), _) --> + prog_out__write_context(Context), + io__write_string("Warning: this goal cannot succeed.\n"), + globals__io_lookup_bool_option(verbose_errors, VerboseErrors), + ( { VerboseErrors = yes } -> + io__write_string( +"\tThe compiler will optimize away this goal, replacing it with `fail'. +\tTo disable this optimization, use the `--fully-strict' option.\n") + ; + [] + ). +det_report_msg(det_goal_has_no_outputs(Context), _) --> + prog_out__write_context(Context), + io__write_string("Warning: det goal has no outputs.\n"), + globals__io_lookup_bool_option(verbose_errors, VerboseErrors), + ( { VerboseErrors = yes } -> + io__write_string( +"\tThe compiler will optimize away this goal, replacing it with `true'. +\tTo disable this optimization, use the `--fully-strict' option.\n") + ; + [] + ). det_report_msg(warn_obsolete(PredId, Context), ModuleInfo) --> prog_out__write_context(Context), io__write_string("Warning: call to obsolete "), diff --git a/compiler/follow_code.m b/compiler/follow_code.m index fd69e5238..19d09b79d 100644 --- a/compiler/follow_code.m +++ b/compiler/follow_code.m @@ -1,5 +1,5 @@ %-----------------------------------------------------------------------------% -% Copyright (C) 1994-1998 The University of Melbourne. +% Copyright (C) 1994-1999 The University of Melbourne. % This file may only be copied under the terms of the GNU General % Public License - see the file COPYING in the Mercury distribution. %-----------------------------------------------------------------------------% @@ -312,7 +312,7 @@ check_follow_code_detism([_ - GoalInfo | Goals], Detism0) :- :- mode move_follow_code_is_builtin(in) is semidet. move_follow_code_is_builtin(unify(_, _, _, Unification, _) - _GoalInfo) :- - Unification \= complicated_unify(_, _). + Unification \= complicated_unify(_, _, _). move_follow_code_is_builtin(call(_, _, _, Builtin, _, _) - _GoalInfo) :- Builtin = inline_builtin. diff --git a/compiler/follow_vars.m b/compiler/follow_vars.m index 34d00b01d..99a9f7c3e 100644 --- a/compiler/follow_vars.m +++ b/compiler/follow_vars.m @@ -342,7 +342,7 @@ find_follow_vars_in_conj([Goal0 | Goals0], ModuleInfo, FollowVars0, BuiltinState = inline_builtin ; GoalExpr0 = unify(_, _, _, Unification, _), - Unification \= complicated_unify(_, _) + Unification \= complicated_unify(_, _, _) ) -> AttachToNext = no diff --git a/compiler/goal_util.m b/compiler/goal_util.m index 833a21f35..ca27d4894 100644 --- a/compiler/goal_util.m +++ b/compiler/goal_util.m @@ -414,8 +414,9 @@ goal_util__rename_unify(assign(L0, R0), Must, Subn, assign(L, R)) :- goal_util__rename_unify(simple_test(L0, R0), Must, Subn, simple_test(L, R)) :- goal_util__rename_var(L0, Must, Subn, L), goal_util__rename_var(R0, Must, Subn, R). -goal_util__rename_unify(complicated_unify(Modes, Cat), _Must, _Subn, - complicated_unify(Modes, Cat)). +goal_util__rename_unify(complicated_unify(Modes, Cat, TypeInfoVars), + _Must, _Subn, + complicated_unify(Modes, Cat, TypeInfoVars)). %-----------------------------------------------------------------------------% diff --git a/compiler/higher_order.m b/compiler/higher_order.m index f7d64e368..9ab215a22 100644 --- a/compiler/higher_order.m +++ b/compiler/higher_order.m @@ -607,7 +607,7 @@ check_unify(construct(LVar, ConsId, Args, _Modes), Info0, Info) :- Info = info(PredVars, Requests, NewPreds, PredProcId, PredInfo, ProcInfo, ModuleInfo, Params, Changed). -check_unify(complicated_unify(_, _)) --> +check_unify(complicated_unify(_, _, _)) --> { error("higher_order:check_unify - complicated unification") }. :- pred is_interesting_cons_id(ho_params::in, cons_id::in) is semidet. @@ -1748,11 +1748,13 @@ create_new_pred(Request, NewPred, NextHOid0, NextHOid, varset__init(EmptyVarSet), map__init(EmptyVarTypes), map__init(EmptyProofs), + map__init(EmptyTIMap), + map__init(EmptyTCIMap), % This isn't looked at after here, and just clutters up % hlds dumps if it's filled in. ClausesInfo = clauses_info(EmptyVarSet, EmptyVarTypes, - EmptyVarTypes, [], []), + EmptyVarTypes, [], [], EmptyTIMap, EmptyTCIMap), pred_info_init(PredModule, SymName, Arity, ArgTVarSet, ExistQVars, Types, true, Context, ClausesInfo, Status, MarkerList, GoalType, PredOrFunc, ClassContext, EmptyProofs, Owner, PredInfo1), diff --git a/compiler/hlds_goal.m b/compiler/hlds_goal.m index cebbf75e9..d03f49abd 100644 --- a/compiler/hlds_goal.m +++ b/compiler/hlds_goal.m @@ -310,7 +310,29 @@ ; complicated_unify( uni_mode, % The mode of the unification. - can_fail % Whether or not it could possibly fail + can_fail, % Whether or not it could possibly fail + + % When unifying polymorphic types such as + % map/2, we need to pass type_info variables + % to the unification procedure for map/2 + % so that it knows how to unify the + % polymorphically typed components of the + % data structure. Likewise for comparison + % predicates. + % This field records which type_info variables + % we will need. + % This field is set by polymorphism.m. + % It is used by quantification.m + % when recomputing the nonlocals. + % It is also used by modecheck_unify.m, + % which checks that the type_info + % variables needed are all ground. + % It is also checked by simplify.m when + % it converts complicated unifications + % into procedure calls. + list(prog_var) % The type_info variables needed + % by this unification, if it ends up + % being a complicated unify. ). % A unify_context describes the location in the original source diff --git a/compiler/hlds_out.m b/compiler/hlds_out.m index 5e300a2fd..ce4b2e362 100644 --- a/compiler/hlds_out.m +++ b/compiler/hlds_out.m @@ -542,7 +542,8 @@ hlds_out__write_pred(Indent, ModuleInfo, PredId, PredInfo) --> ; [] ), - { ClausesInfo = clauses_info(VarSet, _, VarTypes, HeadVars, Clauses) }, + { ClausesInfo = clauses_info(VarSet, _, VarTypes, HeadVars, Clauses, + TypeInfoMap, TypeClassInfoMap) }, ( { string__contains_char(Verbose, 'C') } -> hlds_out__write_indent(Indent), io__write_string("% pred id: "), @@ -561,6 +562,10 @@ hlds_out__write_pred(Indent, ModuleInfo, PredId, PredInfo) --> hlds_out__write_marker_list(MarkerList), io__write_string("\n") ), + hlds_out__write_typeinfo_varmap(Indent, AppendVarnums, + TypeInfoMap, VarSet, TVarSet), + hlds_out__write_typeclass_info_varmap(Indent, AppendVarnums, + TypeClassInfoMap, VarSet, TVarSet), ( { map__is_empty(Proofs) } -> [] ; @@ -568,6 +573,12 @@ hlds_out__write_pred(Indent, ModuleInfo, PredId, PredInfo) --> Proofs), io__write_string("\n") ), + + % XXX The indexes are not part of the clauses_info, + % so why is this code inside this if-then-else + % with the condition `string__contains_char(Verbose, 'C')'? + % Shouldn't it be dependent on a different letter? + ( { Indexes = [] } -> [] ; @@ -1262,9 +1273,11 @@ hlds_out__write_goal_2(unify(A, B, _, Unification, _), ModuleInfo, VarSet, ( % don't output bogus info if we haven't been through % mode analysis yet - { Unification = complicated_unify(Mode, CanFail) }, + { Unification = complicated_unify(Mode, CanFail, + TypeInfoVars) }, { CanFail = can_fail }, - { Mode = (free - free -> free - free) } + { Mode = (free - free -> free - free) }, + { TypeInfoVars = [] } -> [] ; @@ -1406,8 +1419,8 @@ hlds_out__write_unification(deconstruct(Var, ConsId, ArgVars, ArgModes, !, hlds_out_write_functor_and_submodes(ConsId, ArgVars, ArgModes, ModuleInfo, ProgVarSet, InstVarSet, AppendVarnums, Indent). -hlds_out__write_unification(complicated_unify(Mode, CanFail), - _ModuleInfo, _ProgVarSet, InstVarSet, _, Indent) --> +hlds_out__write_unification(complicated_unify(Mode, CanFail, TypeInfoVars), + _ModuleInfo, ProgVarSet, InstVarSet, AppendVarNums, Indent) --> hlds_out__write_indent(Indent), io__write_string("% "), ( { CanFail = can_fail }, @@ -1418,8 +1431,13 @@ hlds_out__write_unification(complicated_unify(Mode, CanFail), !, io__write_string("mode: "), mercury_output_uni_mode(Mode, InstVarSet), + io__write_string("\n"), + hlds_out__write_indent(Indent), + io__write_string("% type-info vars: "), + mercury_output_vars(TypeInfoVars, ProgVarSet, AppendVarNums), io__write_string("\n"). + :- pred hlds_out_write_functor_and_submodes(cons_id, list(prog_var), list(uni_mode), module_info, prog_varset, inst_varset, bool, int, io__state, io__state). diff --git a/compiler/hlds_pred.m b/compiler/hlds_pred.m index c17b3776b..b982c08a4 100644 --- a/compiler/hlds_pred.m +++ b/compiler/hlds_pred.m @@ -81,6 +81,8 @@ :- type pred_proc_id ---> proc(pred_id, proc_id). :- type pred_proc_list == list(pred_proc_id). +%-----------------------------------------------------------------------------% + % The clauses_info structure contains the clauses for a predicate % after conversion from the item_list by make_hlds.m. % Typechecking is performed on the clauses info, then the clauses @@ -97,9 +99,70 @@ % variable types % inferred by typecheck.m. list(prog_var), % head vars - list(clause) + list(clause), + % the following two fields + % are computed by + % polymorphism.m + type_info_varmap, + typeclass_info_varmap ). +:- pred clauses_info_varset(clauses_info, prog_varset). +:- mode clauses_info_varset(in, out) is det. + + % This partial map holds the types specified by any explicit + % type qualifiers in the clauses. +:- pred clauses_info_explicit_vartypes(clauses_info, map(prog_var, type)). +:- mode clauses_info_explicit_vartypes(in, out) is det. + + % This map contains the types of all the variables, as inferred + % by typecheck.m. +:- pred clauses_info_vartypes(clauses_info, map(prog_var, type)). +:- mode clauses_info_vartypes(in, out) is det. + +:- pred clauses_info_type_info_varmap(clauses_info, type_info_varmap). +:- mode clauses_info_type_info_varmap(in, out) is det. + +:- pred clauses_info_typeclass_info_varmap(clauses_info, + typeclass_info_varmap). +:- mode clauses_info_typeclass_info_varmap(in, out) is det. + +:- pred clauses_info_headvars(clauses_info, list(prog_var)). +:- mode clauses_info_headvars(in, out) is det. + +:- pred clauses_info_clauses(clauses_info, list(clause)). +:- mode clauses_info_clauses(in, out) is det. + +:- pred clauses_info_set_headvars(clauses_info, list(prog_var), clauses_info). +:- mode clauses_info_set_headvars(in, in, out) is det. + +:- pred clauses_info_set_clauses(clauses_info, list(clause), clauses_info). +:- mode clauses_info_set_clauses(in, in, out) is det. + +:- pred clauses_info_set_varset(clauses_info, prog_varset, clauses_info). +:- mode clauses_info_set_varset(in, in, out) is det. + + % This partial map holds the types specified by any explicit + % type qualifiers in the clauses. +:- pred clauses_info_set_explicit_vartypes(clauses_info, map(prog_var, type), + clauses_info). +:- mode clauses_info_set_explicit_vartypes(in, in, out) is det. + + % This map contains the types of all the variables, as inferred + % by typecheck.m. +:- pred clauses_info_set_vartypes(clauses_info, map(prog_var, type), + clauses_info). +:- mode clauses_info_set_vartypes(in, in, out) is det. + +:- pred clauses_info_set_type_info_varmap(clauses_info, type_info_varmap, + clauses_info). +:- mode clauses_info_set_type_info_varmap(in, in, out) is det. + +:- pred clauses_info_set_typeclass_info_varmap(clauses_info, + typeclass_info_varmap, clauses_info). +:- mode clauses_info_set_typeclass_info_varmap(in, in, out) is det. + + :- type clause ---> clause( list(proc_id), % modes for which % this clause applies @@ -110,6 +173,8 @@ prog_context ). +%-----------------------------------------------------------------------------% + % The type of goals that have been given for a pred. :- type goal_type ---> pragmas % pragma c_code(...) @@ -320,6 +385,22 @@ % module, name and arity. :- type aditi_owner == string. + % The constraint_proof_map is a map which for each type class + % constraint records how/why that constraint was satisfied. + % This information is used to determine how to construct the + % typeclass_info for that constraint. +:- type constraint_proof_map == map(class_constraint, constraint_proof). + + % A typeclass_info_varmap is a map which for each type class constraint + % records which variable contains the typeclass_info for that + % constraint. +:- type typeclass_info_varmap == map(class_constraint, prog_var). + + % A type_info_varmap is a map which for each type variable + % records where the type_info for that type variable is stored. +:- type type_info_varmap == map(tvar, type_info_locn). + + % A type_info_locn specifies how to access a type_info. :- type type_info_locn ---> type_info(prog_var) % It is a normal type_info, i.e. the type @@ -359,10 +440,9 @@ % which were added to the front of the argument list. :- pred hlds_pred__define_new_pred(hlds_goal, hlds_goal, list(prog_var), list(prog_var), instmap, string, tvarset, map(prog_var, type), - class_constraints, map(tvar, type_info_locn), - map(class_constraint, prog_var), prog_varset, pred_markers, - aditi_owner, is_address_taken, module_info, module_info, - pred_proc_id). + class_constraints, type_info_varmap, typeclass_info_varmap, + prog_varset, pred_markers, aditi_owner, is_address_taken, + module_info, module_info, pred_proc_id). :- mode hlds_pred__define_new_pred(in, out, in, out, in, in, in, in, in, in, in, in, in, in, in, in, out, out) is det. @@ -372,7 +452,7 @@ :- pred pred_info_init(module_name, sym_name, arity, tvarset, existq_tvars, list(type), condition, prog_context, clauses_info, import_status, pred_markers, goal_type, pred_or_func, class_constraints, - map(class_constraint, constraint_proof), aditi_owner, pred_info). + constraint_proof_map, aditi_owner, pred_info). :- mode pred_info_init(in, in, in, in, in, in, in, in, in, in, in, in, in, in, in, in, out) is det. @@ -518,12 +598,11 @@ :- pred pred_info_set_class_context(pred_info, class_constraints, pred_info). :- mode pred_info_set_class_context(in, in, out) is det. -:- pred pred_info_get_constraint_proofs(pred_info, - map(class_constraint, constraint_proof)). +:- pred pred_info_get_constraint_proofs(pred_info, constraint_proof_map). :- mode pred_info_get_constraint_proofs(in, out) is det. -:- pred pred_info_set_constraint_proofs(pred_info, - map(class_constraint, constraint_proof), pred_info). +:- pred pred_info_set_constraint_proofs(pred_info, constraint_proof_map, + pred_info). :- mode pred_info_set_constraint_proofs(in, in, out) is det. :- pred pred_info_get_aditi_owner(pred_info, string). @@ -667,7 +746,7 @@ status_defined_in_this_module(local, yes). % the class constraints on the % type variables in the predicate's % type declaration - map(class_constraint, constraint_proof), + constraint_proof_map, % explanations of how redundant % constraints were eliminated. These % are needed by polymorphism.m to @@ -734,9 +813,13 @@ pred_info_create(ModuleName, SymName, TypeVarSet, ExistQVars, Types, Cond, proc_info_varset(ProcInfo, VarSet), proc_info_vartypes(ProcInfo, VarTypes), proc_info_headvars(ProcInfo, HeadVars), + proc_info_typeinfo_varmap(ProcInfo, TypeInfoMap), + proc_info_typeclass_info_varmap(ProcInfo, TypeClassInfoMap), unqualify_name(SymName, PredName), % The empty list of clauses is a little white lie. - ClausesInfo = clauses_info(VarSet, VarTypes, VarTypes, HeadVars, []), + Clauses = [], + ClausesInfo = clauses_info(VarSet, VarTypes, VarTypes, HeadVars, + Clauses, TypeInfoMap, TypeClassInfoMap), map__init(ClassProofs), term__vars_list(Types, TVars), list__delete_elems(TVars, ExistQVars, HeadTypeParams), @@ -1040,6 +1123,49 @@ marker_list_to_markers(Markers, Markers). %-----------------------------------------------------------------------------% +% :- type clauses_info ---> clauses_info( +% prog_varset, % variable names +% map(prog_var, type), +% % variable types from +% % explicit qualifications +% map(prog_var, type), +% % variable types +% % inferred by typecheck.m. +% list(prog_var), % head vars +% list(clause), +% type_info_varmap, +% typeclass_info_varmap, +% ). + +clauses_info_varset(clauses_info(VarSet, _, _, _, _, _, _), VarSet). +clauses_info_explicit_vartypes( + clauses_info(_, ExplicitVarTypes, _, _, _, _, _), ExplicitVarTypes). +clauses_info_vartypes(clauses_info(_, _, VarTypes, _, _, _, _), VarTypes). +clauses_info_headvars(clauses_info(_, _, _, HeadVars, _, _, _), HeadVars). +clauses_info_clauses(clauses_info(_, _, _, _, Clauses, _, _), Clauses). +clauses_info_type_info_varmap(clauses_info(_, _, _, _, _, TIMap, _), TIMap). +clauses_info_typeclass_info_varmap(clauses_info(_, _, _, _, _, _, TCIMap), + TCIMap). + +clauses_info_set_varset(clauses_info(_, B, C, D, E, F, G), VarSet, + clauses_info(VarSet, B, C, D, E, F, G)). +clauses_info_set_explicit_vartypes(clauses_info(A, _, C, D, E, F, G), + ExplicitVarTypes, + clauses_info(A, ExplicitVarTypes, C, D, E, F, G)). +clauses_info_set_vartypes(clauses_info(A, B, _, D, E, F, G), VarTypes, + clauses_info(A, B, VarTypes, D, E, F, G)). +clauses_info_set_headvars(clauses_info(A, B, C, _, E, F, G), HeadVars, + clauses_info(A, B, C, HeadVars, E, F, G)). +clauses_info_set_clauses(clauses_info(A, B, C, D, _, F, G), Clauses, + clauses_info(A, B, C, D, Clauses, F, G)). +clauses_info_set_type_info_varmap(clauses_info(A, B, C, D, E, _, G), TIMap, + clauses_info(A, B, C, D, E, TIMap, G)). +clauses_info_set_typeclass_info_varmap(clauses_info(A, B, C, D, E, F, _), + TCIMap, + clauses_info(A, B, C, D, E, F, TCIMap)). + +%-----------------------------------------------------------------------------% + hlds_pred__define_new_pred(Goal0, Goal, ArgVars0, ExtraTypeInfos, InstMap0, PredName, TVarSet, VarTypes0, ClassContext, TVarMap, TCVarMap, VarSet0, Markers, Owner, IsAddressTaken, @@ -1143,21 +1269,21 @@ compute_arg_types_modes([Var | Vars], VarTypes, InstMap0, InstMap, :- pred proc_info_set(maybe(determinism), prog_varset, map(prog_var, type), list(prog_var), list(mode), maybe(list(is_live)), hlds_goal, prog_context, stack_slots, determinism, bool, list(arg_info), - liveness_info, map(tvar, type_info_locn), - map(class_constraint, prog_var), maybe(arg_size_info), - maybe(termination_info), is_address_taken, proc_info). + liveness_info, type_info_varmap, typeclass_info_varmap, + maybe(arg_size_info), maybe(termination_info), is_address_taken, + proc_info). :- mode proc_info_set(in, in, in, in, in, in, in, in, in, in, in, in, in, in, in, in, in, in, out) is det. :- pred proc_info_create(prog_varset, map(prog_var, type), list(prog_var), list(mode), determinism, hlds_goal, prog_context, - map(tvar, type_info_locn), map(class_constraint, prog_var), - is_address_taken, proc_info). + type_info_varmap, typeclass_info_varmap, is_address_taken, proc_info). :- mode proc_info_create(in, in, in, in, in, in, in, in, in, in, out) is det. :- pred proc_info_set_body(proc_info, prog_varset, map(prog_var, type), - list(prog_var), hlds_goal, proc_info). -:- mode proc_info_set_body(in, in, in, in, in, out) is det. + list(prog_var), hlds_goal, type_info_varmap, + typeclass_info_varmap, proc_info). +:- mode proc_info_set_body(in, in, in, in, in, in, in, out) is det. :- pred proc_info_declared_determinism(proc_info, maybe(determinism)). :- mode proc_info_declared_determinism(in, out) is det. @@ -1266,11 +1392,10 @@ compute_arg_types_modes([Var | Vars], VarTypes, InstMap0, InstMap, :- pred proc_info_set_can_process(proc_info, bool, proc_info). :- mode proc_info_set_can_process(in, in, out) is det. -:- pred proc_info_typeinfo_varmap(proc_info, map(tvar, type_info_locn)). +:- pred proc_info_typeinfo_varmap(proc_info, type_info_varmap). :- mode proc_info_typeinfo_varmap(in, out) is det. -:- pred proc_info_set_typeinfo_varmap(proc_info, map(tvar, type_info_locn), - proc_info). +:- pred proc_info_set_typeinfo_varmap(proc_info, type_info_varmap, proc_info). :- mode proc_info_set_typeinfo_varmap(in, in, out) is det. :- pred proc_info_eval_method(proc_info, eval_method). @@ -1279,12 +1404,11 @@ compute_arg_types_modes([Var | Vars], VarTypes, InstMap0, InstMap, :- pred proc_info_set_eval_method(proc_info, eval_method, proc_info). :- mode proc_info_set_eval_method(in, in, out) is det. -:- pred proc_info_typeclass_info_varmap(proc_info, - map(class_constraint, prog_var)). +:- pred proc_info_typeclass_info_varmap(proc_info, typeclass_info_varmap). :- mode proc_info_typeclass_info_varmap(in, out) is det. -:- pred proc_info_set_typeclass_info_varmap(proc_info, - map(class_constraint, prog_var), proc_info). +:- pred proc_info_set_typeclass_info_varmap(proc_info, typeclass_info_varmap, + proc_info). :- mode proc_info_set_typeclass_info_varmap(in, in, out) is det. :- pred proc_info_maybe_declared_argmodes(proc_info, maybe(list(mode))). @@ -1355,10 +1479,9 @@ compute_arg_types_modes([Var | Vars], VarTypes, InstMap0, InstMap, % should be passed. liveness_info, % the initial liveness, % for code generation - map(tvar, type_info_locn), - % typeinfo vars for - % type parameters - map(class_constraint, prog_var), + type_info_varmap, + % typeinfo vars for type parameters + typeclass_info_varmap, % typeclass_info vars for class % constraints eval_method, % how should the proc be evaluated @@ -1430,11 +1553,12 @@ proc_info_create(VarSet, VarTypes, HeadVars, HeadModes, Detism, Goal, Liveness, TVarMap, TCVarsMap, eval_normal, no, no, no, IsAddressTaken). -proc_info_set_body(ProcInfo0, VarSet, VarTypes, HeadVars, Goal, ProcInfo) :- +proc_info_set_body(ProcInfo0, VarSet, VarTypes, HeadVars, Goal, + TI_VarMap, TCI_VarMap, ProcInfo) :- ProcInfo0 = procedure(A, _, _, _, E, F, _, - H, I, J, K, L, M, N, O, P, Q, R, S, T), + H, I, J, K, L, M, _, _, P, Q, R, S, T), ProcInfo = procedure(A, VarSet, VarTypes, HeadVars, E, F, Goal, - H, I, J, K, L, M, N, O, P, Q, R, S, T). + H, I, J, K, L, M, TI_VarMap, TCI_VarMap, P, Q, R, S, T). proc_info_interface_determinism(ProcInfo, Determinism) :- proc_info_declared_determinism(ProcInfo, MaybeDeterminism), @@ -1602,10 +1726,9 @@ proc_info_is_address_taken(ProcInfo, T) :- % % should be passed. % M liveness_info, % the initial liveness, % % for code generation -% N map(tvar, type_info_locn), -% % typeinfo vars for -% % type parameters -% O map(class_constraint, var), +% N type_info_varmap, +% % typeinfo vars for type parameters +% O typeclass_info_varmap, % % typeclass_info vars for class % % constraints % P eval_method, diff --git a/compiler/intermod.m b/compiler/intermod.m index 4f64beae5..0147302e3 100644 --- a/compiler/intermod.m +++ b/compiler/intermod.m @@ -217,14 +217,14 @@ intermod__gather_preds([PredId | PredIds], CollectTypes, -> { pred_info_clauses_info(PredInfo0, ClausesInfo0) }, { pred_info_typevarset(PredInfo0, TVarSet) }, - { ClausesInfo0 = clauses_info(VarSet, DeclTypes, VarTypes, - HeadVars, Clauses0) }, + { clauses_info_vartypes(ClausesInfo0, VarTypes) }, + { clauses_info_clauses(ClausesInfo0, Clauses0) }, intermod_info_set_var_types(VarTypes), intermod_info_set_tvarset(TVarSet), intermod__traverse_clauses(Clauses0, Clauses, DoWrite), ( { DoWrite = yes } -> - { ClausesInfo = clauses_info(VarSet, DeclTypes, - VarTypes, HeadVars, Clauses) }, + { clauses_info_set_clauses(ClausesInfo0, Clauses, + ClausesInfo) }, { pred_info_set_clauses_info(PredInfo0, ClausesInfo, PredInfo) }, { map__det_update(PredTable0, PredId, @@ -1064,15 +1064,18 @@ intermod__write_preds(ModuleInfo, [PredId | PredIds]) --> % already be in the interface file. { pred_info_clauses_info(PredInfo, ClausesInfo) }, - { ClausesInfo = clauses_info(Varset, _, _VarTypes, HeadVars, Clauses) }, + { clauses_info_varset(ClausesInfo, VarSet) }, + { clauses_info_headvars(ClausesInfo, HeadVars) }, + { clauses_info_clauses(ClausesInfo, Clauses) }, + % handle pragma c_code(...) separately ( { pred_info_get_goal_type(PredInfo, pragmas) } -> { pred_info_procedures(PredInfo, Procs) }, - intermod__write_c_code(SymName, PredOrFunc, HeadVars, Varset, + intermod__write_c_code(SymName, PredOrFunc, HeadVars, VarSet, Clauses, Procs) ; % { pred_info_typevarset(PredInfo, TVarSet) }, - hlds_out__write_clauses(1, ModuleInfo, PredId, Varset, no, + hlds_out__write_clauses(1, ModuleInfo, PredId, VarSet, no, HeadVars, PredOrFunc, Clauses, no) % HeadVars, Clauses, yes(TVarSet, VarTypes)) ), diff --git a/compiler/lambda.m b/compiler/lambda.m index 2d57e3302..3ce320e6b 100644 --- a/compiler/lambda.m +++ b/compiler/lambda.m @@ -72,6 +72,9 @@ :- import_module hlds_module, hlds_pred, hlds_goal, hlds_data, prog_data. :- import_module list, map, set. +:- pred lambda__process_module(module_info, module_info). +:- mode lambda__process_module(in, out) is det. + :- pred lambda__process_pred(pred_id, module_info, module_info). :- mode lambda__process_pred(in, in, out) is det. @@ -89,7 +92,7 @@ :- implementation. -:- import_module make_hlds, globals, options, term, varset. +:- import_module make_hlds, globals, options, term, varset, type_util. :- import_module goal_util, prog_util, mode_util, inst_match, llds, arg_info. :- import_module bool, string, std_util, require. @@ -117,6 +120,20 @@ % This whole section just traverses the module structure. +lambda__process_module(ModuleInfo0, ModuleInfo) :- + module_info_predids(ModuleInfo0, PredIds), + lambda__process_preds(PredIds, ModuleInfo0, ModuleInfo1), + % Need update the dependency graph to include the lambda predicates. + module_info_clobber_dependency_info(ModuleInfo1, ModuleInfo). + +:- pred lambda__process_preds(list(pred_id), module_info, module_info). +:- mode lambda__process_preds(in, in, out) is det. + +lambda__process_preds([], ModuleInfo, ModuleInfo). +lambda__process_preds([PredId | PredIds], ModuleInfo0, ModuleInfo) :- + lambda__process_pred(PredId, ModuleInfo0, ModuleInfo1), + lambda__process_preds(PredIds, ModuleInfo1, ModuleInfo). + lambda__process_pred(PredId, ModuleInfo0, ModuleInfo) :- module_info_pred_info(ModuleInfo0, PredId, PredInfo), pred_info_procids(PredInfo, ProcIds), @@ -200,10 +217,13 @@ lambda__process_goal_2(unify(XVar, Y, Mode, Unification, Context), GoalInfo, Unify - GoalInfo) --> ( { Y = lambda_goal(PredOrFunc, NonLocalVars, Vars, Modes, Det, LambdaGoal0) } -> - % for lambda expressions, we must convert the lambda expression - % into a new predicate + % first, process the lambda goal recursively, in case it + % contains some nested lambda expressions. + lambda__process_goal(LambdaGoal0, LambdaGoal1), + + % then, convert the lambda expression into a new predicate lambda__process_lambda(PredOrFunc, Vars, Modes, Det, - NonLocalVars, LambdaGoal0, + NonLocalVars, LambdaGoal1, Unification, Y1, Unification1), { Unify = unify(XVar, Y1, Mode, Unification1, Context) } ; @@ -274,9 +294,22 @@ lambda__process_cases([case(ConsId, Goal0) | Cases0], lambda__process_lambda(PredOrFunc, Vars, Modes, Det, OrigNonLocals0, LambdaGoal, Unification0, Functor, Unification, LambdaInfo0, LambdaInfo) :- - LambdaInfo0 = lambda_info(VarSet, VarTypes, Constraints, TVarSet, + LambdaInfo0 = lambda_info(VarSet, VarTypes, _PredConstraints, TVarSet, TVarMap, TCVarMap, Markers, POF, PredName, Owner, ModuleInfo0), - % XXX existentially typed lambda expressions are not yet supported + + % Calculate the constraints which apply to this lambda + % expression. + % 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(lambda__constraint_contains_vars(LambdaTypeVars), + AllConstraints, UnivConstraints), + Constraints = constraints(UnivConstraints, []), + + % existentially typed lambda expressions are not yet supported % (see the documentation at top of this file) ExistQVars = [], LambdaGoal = _ - LambdaGoalInfo, @@ -290,6 +323,19 @@ lambda__process_lambda(PredOrFunc, Vars, Modes, Det, OrigNonLocals0, LambdaGoal, LambdaInfo = lambda_info(VarSet, VarTypes, Constraints, TVarSet, TVarMap, TCVarMap, Markers, POF, PredName, Owner, ModuleInfo). +:- pred lambda__constraint_contains_vars(list(tvar), class_constraint). +:- mode lambda__constraint_contains_vars(in, in) is semidet. + +lambda__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). + lambda__transform_lambda(PredOrFunc, OrigPredName, Vars, Modes, Detism, OrigVars, ExtraTypeInfos, LambdaGoal, Unification0, VarSet, VarTypes, Constraints, TVarSet, TVarMap, TCVarMap, @@ -301,7 +347,7 @@ lambda__transform_lambda(PredOrFunc, OrigPredName, Vars, Modes, Detism, Var = Var0, UniModes1 = UniModes0 ; - error("polymorphism__transform_lambda: weird unification") + error("lambda__transform_lambda: weird unification") ), % Optimize a special case: replace diff --git a/compiler/live_vars.m b/compiler/live_vars.m index d17abc639..e7e031761 100644 --- a/compiler/live_vars.m +++ b/compiler/live_vars.m @@ -359,7 +359,7 @@ build_live_sets_in_goal_2(call(PredId, ProcId, ArgVars, BuiltinState, _, _), build_live_sets_in_goal_2(unify(_,_,_,D,_), Liveness, ResumeVars0, LiveSets0, _, _, _, Liveness, ResumeVars0, LiveSets) :- ( - D = complicated_unify(_, _) + D = complicated_unify(_, _, _) -> % we have to save all live and protected variables % across complicated unifications. diff --git a/compiler/magic.m b/compiler/magic.m index 796ec75c9..7129f1bd9 100644 --- a/compiler/magic.m +++ b/compiler/magic.m @@ -1216,7 +1216,7 @@ magic__interface_pred_info(CPredProcId, PredProcId, magic__make_type_info_vars(Types, TypeInfoVars, TypeInfoGoals, PredInfo0, PredInfo, ProcInfo0, ProcInfo) --> magic_info_get_module_info(ModuleInfo0), - { init_poly_info(ModuleInfo0, PredInfo0, ProcInfo0, PolyInfo0) }, + { create_poly_info(ModuleInfo0, PredInfo0, ProcInfo0, PolyInfo0) }, { ExistQVars = [] }, { term__context_init(Context) }, { polymorphism__make_type_info_vars(Types, ExistQVars, Context, diff --git a/compiler/make_hlds.m b/compiler/make_hlds.m index 4f0f2281e..e27c78db2 100644 --- a/compiler/make_hlds.m +++ b/compiler/make_hlds.m @@ -856,8 +856,10 @@ add_pragma_type_spec_2(Pragma, SymName, SpecName, Arity, Goal = call(PredId, DummyProcId, Args, not_builtin, no, SymName) - GoalInfo, Clause = clause(ProcIds, Goal, Context), + map__init(TI_VarMap), + map__init(TCI_VarMap), Clauses = clauses_info(ArgVarSet, VarTypes0, - VarTypes0, Args, [Clause]), + VarTypes0, Args, [Clause], TI_VarMap, TCI_VarMap), pred_info_get_markers(PredInfo0, Markers), map__init(Proofs), ( pred_info_is_imported(PredInfo0) -> @@ -2357,8 +2359,8 @@ add_builtin(PredId, Types, PredInfo0, PredInfo) :- pred_info_name(PredInfo0, Name), pred_info_context(PredInfo0, Context), pred_info_clauses_info(PredInfo0, ClausesInfo0), - ClausesInfo0 = clauses_info(VarSet, _VarTypes0, _VarTypes1, - HeadVars, _ClauseList0), + clauses_info_varset(ClausesInfo0, VarSet), + clauses_info_headvars(ClausesInfo0, HeadVars), % % construct the pseudo-recursive call to Module:Name(HeadVars) @@ -2385,8 +2387,10 @@ add_builtin(PredId, Types, PredInfo0, PredInfo) :- % ClauseList = [Clause], map__from_corresponding_lists(HeadVars, Types, VarTypes), + map__init(TI_VarMap), + map__init(TCI_VarMap), ClausesInfo = clauses_info(VarSet, VarTypes, VarTypes, - HeadVars, ClauseList), + HeadVars, ClauseList, TI_VarMap, TCI_VarMap), pred_info_set_clauses_info(PredInfo0, ClausesInfo, PredInfo). %-----------------------------------------------------------------------------% @@ -4177,7 +4181,10 @@ clauses_info_init(Arity, ClausesInfo) :- map__init(VarTypes), varset__init(VarSet0), make_n_fresh_vars("HeadVar__", Arity, VarSet0, HeadVars, VarSet), - ClausesInfo = clauses_info(VarSet, VarTypes, VarTypes, HeadVars, []). + map__init(TI_VarMap), + map__init(TCI_VarMap), + ClausesInfo = clauses_info(VarSet, VarTypes, VarTypes, HeadVars, [], + TI_VarMap, TCI_VarMap). :- pred clauses_info_add_clause(clauses_info::in, pred_id::in, list(proc_id)::in, prog_varset::in, tvarset::in, @@ -4190,7 +4197,8 @@ clauses_info_add_clause(ClausesInfo0, PredId, ModeIds, CVarSet, TVarSet0, Args, Body, Context, Goal, VarSet, TVarSet0, ClausesInfo, Warnings, Info0, Info) --> { ClausesInfo0 = clauses_info(VarSet0, VarTypes0, VarTypes1, - HeadVars, ClauseList0) }, + HeadVars, ClauseList0, + TI_VarMap, TCI_VarMap) }, { update_qual_info(Info0, TVarSet0, VarTypes0, PredId, Info1) }, { varset__merge_subst(VarSet0, CVarSet, VarSet1, Subst) }, transform(Subst, HeadVars, Args, Body, VarSet1, Context, @@ -4200,7 +4208,8 @@ clauses_info_add_clause(ClausesInfo0, PredId, ModeIds, CVarSet, TVarSet0, ClauseList) }, { qual_info_get_var_types(Info, VarTypes) }, { ClausesInfo = clauses_info(VarSet, VarTypes, VarTypes1, - HeadVars, ClauseList) }. + HeadVars, ClauseList, + TI_VarMap, TCI_VarMap) }. %----------------------------------------------------------------------------- @@ -4221,7 +4230,7 @@ clauses_info_add_pragma_c_code(ClausesInfo0, Purity, Attributes, PredId, ClausesInfo, Info0, Info) --> { ClausesInfo0 = clauses_info(VarSet0, VarTypes, VarTypes1, - HeadVars, ClauseList), + HeadVars, ClauseList, TI_VarMap, TCI_VarMap), pragma_get_vars(PVars, Args0), pragma_get_var_infos(PVars, ArgInfo), @@ -4250,7 +4259,7 @@ clauses_info_add_pragma_c_code(ClausesInfo0, Purity, Attributes, PredId, HldsGoal, VarSet, _, _Warnings), NewClause = clause([ModeId], HldsGoal, Context), ClausesInfo = clauses_info(VarSet, VarTypes, VarTypes1, HeadVars, - [NewClause|ClauseList]) + [NewClause|ClauseList], TI_VarMap, TCI_VarMap) }. :- pred allocate_vars_for_saved_vars(list(string), list(pair(prog_var, string)), @@ -5023,7 +5032,7 @@ create_atomic_unification(A, B, Context, UnifyMainContext, UnifySubContext, Goal) :- UMode = ((free - free) -> (free - free)), Mode = ((free -> free) - (free -> free)), - UnifyInfo = complicated_unify(UMode, can_fail), + UnifyInfo = complicated_unify(UMode, can_fail, []), UnifyC = unify_context(UnifyMainContext, UnifySubContext), goal_info_init(GoalInfo0), goal_info_set_context(GoalInfo0, Context, GoalInfo), diff --git a/compiler/mercury_compile.m b/compiler/mercury_compile.m index f4350717e..5d84f9172 100644 --- a/compiler/mercury_compile.m +++ b/compiler/mercury_compile.m @@ -30,12 +30,12 @@ % the main compiler passes (mostly in order of execution) :- import_module handle_options, prog_io, prog_out, modules, module_qual. -:- import_module equiv_type, make_hlds, typecheck, purity, modes. +:- import_module equiv_type, make_hlds, typecheck, purity, polymorphism, modes. :- import_module switch_detection, cse_detection, det_analysis, unique_modes. :- import_module stratify, check_typeclass, simplify, intermod, trans_opt. :- import_module table_gen. :- import_module bytecode_gen, bytecode. -:- import_module (lambda), polymorphism, termination, higher_order, inlining. +:- import_module (lambda), termination, higher_order, inlining. :- import_module deforest, dnf, unused_args, magic, dead_proc_elim. :- import_module accumulator, lco, saved_vars, liveness. :- import_module follow_code, live_vars, arg_info, store_alloc, goal_path. @@ -388,12 +388,8 @@ mercury_compile(Module) --> % the appropriate warnings globals__io_lookup_bool_option(warn_unused_args, UnusedArgs), ( { UnusedArgs = yes } -> - % Run polymorphism so that the unused argument numbers - % read in from `.opt' files are correct. - mercury_compile__maybe_polymorphism(HLDS21, - Verbose, Stats, HLDS22), globals__io_set_option(optimize_unused_args, bool(no)), - mercury_compile__maybe_unused_args(HLDS22, + mercury_compile__maybe_unused_args(HLDS21, Verbose, Stats, _) ; [] @@ -717,7 +713,17 @@ mercury_compile__frontend_pass(HLDS1, HLDS, FoundUndefTypeError, { HLDS = HLDS4 }, { bool__or(FoundTypeError, FoundTypeclassError, FoundError) } - ; + ; { FoundTypeError = yes } -> + % + % XXX it would be nice if we could go on and mode-check + % the predicates which didn't have type errors, but + % we need to run polymorphism before running mode + % analysis, and currently polymorphism may get internal + % errors if any of the predicates are not type-correct. + % + { HLDS = HLDS4 }, + { FoundError = yes } + ; % only write out the `.opt' file if there are no type errors % or undefined modes ( { FoundTypeError = no, FoundUndefModeError = no } -> @@ -764,27 +770,25 @@ mercury_compile__maybe_write_optfile(MakeOptInt, HLDS0, HLDS) --> ( { MakeOptInt = yes } -> intermod__write_optfile(HLDS0, HLDS1), - % If intermod_unused_args is being performed, run mode and - % determinism analysis and polymorphism, then run unused_args + % If intermod_unused_args is being performed, run polymorphism, + % mode analysis and determinism analysis, then run unused_args % to append the unused argument information to the `.opt.tmp' % file written above. ( { IntermodArgs = yes ; Termination = yes } -> mercury_compile__frontend_pass_2_by_phases( HLDS1, HLDS2, FoundModeError), ( { FoundModeError = no } -> - mercury_compile__maybe_polymorphism(HLDS2, - Verbose, Stats, HLDS3), ( { IntermodArgs = yes } -> mercury_compile__maybe_unused_args( - HLDS3, Verbose, Stats, HLDS4) + HLDS2, Verbose, Stats, HLDS3) ; - { HLDS4 = HLDS3 } + { HLDS3 = HLDS2 } ), ( { Termination = yes } -> mercury_compile__maybe_termination( - HLDS4, Verbose, Stats, HLDS) + HLDS3, Verbose, Stats, HLDS) ; - { HLDS = HLDS4 } + { HLDS = HLDS3 } ) ; @@ -835,10 +839,7 @@ mercury_compile__output_trans_opt_file(HLDS25) --> globals__io_lookup_bool_option(verbose, Verbose), globals__io_lookup_bool_option(statistics, Stats), - mercury_compile__maybe_polymorphism(HLDS25, Verbose, Stats, HLDS26), - mercury_compile__maybe_dump_hlds(HLDS26, "26", "polymorphism"), !, - - mercury_compile__maybe_termination(HLDS26, Verbose, Stats, HLDS28), + mercury_compile__maybe_termination(HLDS25, Verbose, Stats, HLDS28), mercury_compile__maybe_dump_hlds(HLDS28, "28", "termination"), !, trans_opt__write_optfile(HLDS28). @@ -870,33 +871,36 @@ mercury_compile__frontend_pass_2_by_phases(HLDS4, HLDS20, FoundError) --> globals__io_lookup_bool_option(verbose, Verbose), globals__io_lookup_bool_option(statistics, Stats), - mercury_compile__modecheck(HLDS4, Verbose, Stats, HLDS5, + mercury_compile__maybe_polymorphism(HLDS4, Verbose, Stats, HLDS5), !, + mercury_compile__maybe_dump_hlds(HLDS5, "05", "polymorphism"), + + mercury_compile__modecheck(HLDS5, Verbose, Stats, HLDS6, FoundModeError, UnsafeToContinue), - mercury_compile__maybe_dump_hlds(HLDS5, "05", "modecheck"), + mercury_compile__maybe_dump_hlds(HLDS6, "06", "modecheck"), ( { UnsafeToContinue = yes } -> { FoundError = yes }, - { HLDS12 = HLDS5 } + { HLDS12 = HLDS6 } ; - mercury_compile__detect_switches(HLDS5, Verbose, Stats, HLDS6), + mercury_compile__detect_switches(HLDS6, Verbose, Stats, HLDS7), !, - mercury_compile__maybe_dump_hlds(HLDS6, "06", "switch_detect"), + mercury_compile__maybe_dump_hlds(HLDS7, "07", "switch_detect"), !, - mercury_compile__detect_cse(HLDS6, Verbose, Stats, HLDS7), !, - mercury_compile__maybe_dump_hlds(HLDS7, "07", "cse"), !, + mercury_compile__detect_cse(HLDS7, Verbose, Stats, HLDS8), !, + mercury_compile__maybe_dump_hlds(HLDS8, "08", "cse"), !, - mercury_compile__check_determinism(HLDS7, Verbose, Stats, HLDS8, + mercury_compile__check_determinism(HLDS8, Verbose, Stats, HLDS9, FoundDetError), !, - mercury_compile__maybe_dump_hlds(HLDS8, "08", "determinism"), + mercury_compile__maybe_dump_hlds(HLDS9, "09", "determinism"), !, - mercury_compile__check_unique_modes(HLDS8, Verbose, Stats, - HLDS9, FoundUniqError), !, - mercury_compile__maybe_dump_hlds(HLDS9, "09", "unique_modes"), + mercury_compile__check_unique_modes(HLDS9, Verbose, Stats, + HLDS10, FoundUniqError), !, + mercury_compile__maybe_dump_hlds(HLDS10, "10", "unique_modes"), !, - mercury_compile__check_stratification(HLDS9, Verbose, Stats, + mercury_compile__check_stratification(HLDS10, Verbose, Stats, HLDS11, FoundStratError), !, mercury_compile__maybe_dump_hlds(HLDS11, "11", "stratification"), !, @@ -953,16 +957,16 @@ mercury_compile__middle_pass(ModuleName, HLDS24, HLDS50) --> mercury_compile__tabling(HLDS24, Verbose, HLDS25), mercury_compile__maybe_dump_hlds(HLDS25, "25", "tabling"), !, - mercury_compile__maybe_polymorphism(HLDS25, Verbose, Stats, HLDS26), - mercury_compile__maybe_dump_hlds(HLDS26, "26", "polymorphism"), !, + mercury_compile__process_lambdas(HLDS25, Verbose, HLDS26), + mercury_compile__maybe_dump_hlds(HLDS26, "26", "lambda"), !, % % Uncomment the following code to check that unique mode analysis - % works after polymorphism has been run. Currently it does not + % works after simplification has been run. Currently it does not % because common.m does not preserve unique mode correctness % (this test fails on about five modules in the compiler and library). % It is important that unique mode analysis work most of the time - % after optimizations and polymorphism because deforestation reruns it. + % after optimizations because deforestation reruns it. % { HLDS27 = HLDS26 }, @@ -1529,8 +1533,8 @@ mercury_compile__maybe_generate_schemas(ModuleInfo, Verbose) --> %-----------------------------------------------------------------------------% -:- pred mercury_compile__tabling(module_info, bool, - module_info, io__state, io__state). +:- pred mercury_compile__tabling(module_info, bool, module_info, + io__state, io__state). :- mode mercury_compile__tabling(in, in, out, di, uo) is det. mercury_compile__tabling(HLDS0, Verbose, HLDS) --> @@ -1542,6 +1546,19 @@ mercury_compile__tabling(HLDS0, Verbose, HLDS) --> %-----------------------------------------------------------------------------% +:- pred mercury_compile__process_lambdas(module_info, bool, module_info, + io__state, io__state). +:- mode mercury_compile__process_lambdas(in, in, out, di, uo) is det. + +mercury_compile__process_lambdas(HLDS0, Verbose, HLDS) --> + maybe_write_string(Verbose, + "% Transforming lambda expressions..."), + maybe_flush_output(Verbose), + { lambda__process_module(HLDS0, HLDS) }, + maybe_write_string(Verbose, " done.\n"). + +%-----------------------------------------------------------------------------% + :- pred mercury_compile__maybe_polymorphism(module_info, bool, bool, module_info, io__state, io__state). :- mode mercury_compile__maybe_polymorphism(in, in, in, out, di, uo) is det. @@ -1556,7 +1573,11 @@ mercury_compile__maybe_polymorphism(HLDS0, Verbose, Stats, HLDS) --> maybe_write_string(Verbose, " done.\n"), maybe_report_stats(Stats) ; - { HLDS = HLDS0 } + % The --no-polymorphism option really doesn't make much + % sense anymore, because the polymorphism pass is necessary + % for the proper mode analysis of code using existential + % types. + { error("sorry, `--no-polymorphism' is no longer supported") } ). :- pred mercury_compile__maybe_type_ctor_infos(module_info, bool, bool, @@ -1693,7 +1714,7 @@ mercury_compile__maybe_deforestation(HLDS0, Verbose, Stats, HLDS) --> maybe_write_string(Verbose, "% Deforestation...\n"), maybe_flush_output(Verbose), deforestation(HLDS0, HLDS), - maybe_write_string(Verbose, " done.\n"), + maybe_write_string(Verbose, "% done.\n"), maybe_report_stats(Stats) ; { HLDS0 = HLDS } diff --git a/compiler/mercury_to_c.m b/compiler/mercury_to_c.m index c5fdf1c76..b0f2c8d01 100644 --- a/compiler/mercury_to_c.m +++ b/compiler/mercury_to_c.m @@ -1,5 +1,5 @@ %-----------------------------------------------------------------------------% -% Copyright (C) 1995-1998 The University of Melbourne. +% Copyright (C) 1995-1999 The University of Melbourne. % This file may only be copied under the terms of the GNU General % Public License - see the file COPYING in the Mercury distribution. %-----------------------------------------------------------------------------% @@ -177,8 +177,9 @@ c_gen_pred(Indent, ModuleInfo, PredId, PredInfo) --> ClassContext, Context), { pred_info_clauses_info(PredInfo, ClausesInfo) }, - { ClausesInfo = clauses_info(VarSet, _VarTypes, _, HeadVars, - Clauses) }, + { clauses_info_varset(ClausesInfo, VarSet) }, + { clauses_info_headvars(ClausesInfo, HeadVars) }, + { clauses_info_clauses(ClausesInfo, Clauses) }, globals__io_lookup_string_option(dump_hlds_options, Verbose), globals__io_set_option(dump_hlds_options, string("")), @@ -727,7 +728,7 @@ c_gen_unification(construct(_, _, _, _), _Indent, CGenInfo, CGenInfo) --> c_gen_unification(deconstruct(_, _, _, _, _), _Indent, CGenInfo, CGenInfo) --> { sorry(2) }, io__write_string(" == "). -c_gen_unification(complicated_unify(_, _), _Indent, CGenInfo, CGenInfo) --> +c_gen_unification(complicated_unify(_, _, _), _Indent, CGenInfo, CGenInfo) --> { sorry(3) }, io__write_string(" = "). diff --git a/compiler/mode_errors.m b/compiler/mode_errors.m index a76f5b330..67c8f2f9a 100644 --- a/compiler/mode_errors.m +++ b/compiler/mode_errors.m @@ -50,6 +50,9 @@ % the predicate variable in a higher-order predicate % or function call didn't have a higher-order % predicate or function inst of the appropriate arity + ; mode_error_poly_unify(prog_var, inst) + % A variable in a polymorphic unification with unknown + % type has inst other than `ground' or `any'. ; mode_error_var_is_live(prog_var) % call to a predicate which will clobber its argument, % but the argument is still live @@ -189,6 +192,8 @@ report_mode_error(mode_error_higher_order_pred_var(PredOrFunc, Var, Inst, Arity), ModeInfo) --> report_mode_error_higher_order_pred_var(ModeInfo, PredOrFunc, Var, Inst, Arity). +report_mode_error(mode_error_poly_unify(Var, Inst), ModeInfo) --> + report_mode_error_poly_unify(ModeInfo, Var, Inst). report_mode_error(mode_error_var_is_live(Var), ModeInfo) --> report_mode_error_var_is_live(ModeInfo, Var). report_mode_error(mode_error_var_has_inst(Var, InstA, InstB), ModeInfo) --> @@ -541,6 +546,37 @@ report_mode_error_higher_order_pred_var(ModeInfo, PredOrFunc, Var, VarInst, ), io__write_string(").\n"). +:- pred report_mode_error_poly_unify(mode_info, prog_var, inst, + io__state, io__state). +:- mode report_mode_error_poly_unify(mode_info_ui, in, in, di, uo) is det. + +report_mode_error_poly_unify(ModeInfo, Var, VarInst) --> + { mode_info_get_context(ModeInfo, Context) }, + { mode_info_get_varset(ModeInfo, VarSet) }, + { mode_info_get_instvarset(ModeInfo, InstVarSet) }, + mode_info_write_context(ModeInfo), + prog_out__write_context(Context), + io__write_string(" in polymorphically-typed unification:\n"), + prog_out__write_context(Context), + io__write_string(" mode error: variable `"), + mercury_output_var(Var, VarSet, no), + io__write_string("' has instantiatedness `"), + output_inst(VarInst, InstVarSet), + io__write_string("',\n"), + prog_out__write_context(Context), + io__write_string( + " expected instantiatedness was `ground' or `any'.\n"), + globals__io_lookup_bool_option(verbose_errors, VerboseErrors), + ( { VerboseErrors = yes } -> + io__write_string( +"\tWhen unifying two variables whose type will not be known until +\truntime, the variables must both be ground (or have inst `any'). +\tUnifications of polymorphically-typed variables with partially +\tinstantiated modes are not allowed.\n") + ; + [] + ). + :- pred report_mode_error_var_is_live(mode_info, prog_var, io__state, io__state). :- mode report_mode_error_var_is_live(mode_info_ui, in, di, uo) is det. @@ -888,7 +924,7 @@ write_mode_context(higher_order_call(PredOrFunc, ArgNum), Context, _ModuleInfo) write_mode_context(call(PredId, ArgNum), Context, ModuleInfo) --> prog_out__write_context(Context), io__write_string(" in "), - ( { ArgNum = 0 } -> + ( { ArgNum =< 0 } -> [] ; io__write_string("argument "), diff --git a/compiler/mode_info.m b/compiler/mode_info.m index 079f654d9..cb16ce5b6 100644 --- a/compiler/mode_info.m +++ b/compiler/mode_info.m @@ -28,7 +28,10 @@ :- type mode_context ---> call( pred_id, % pred name / arity - int % argument number + int % argument number (offset so that + % the real arguments start at number 1 + % whereas the type_info arguments + % have numbers <= 0). ) ; higher_order_call( pred_or_func, % is it call/N (higher-order pred call) @@ -573,6 +576,11 @@ mode_info_set_call_arg_context(ArgNum, ModeInfo0, ModeInfo) :- mode_info_set_mode_context( higher_order_call(PredOrFunc, ArgNum), ModeInfo0, ModeInfo) + ; ModeContext0 = unify(_UnifyContext, _Side) -> + % This only happens when checking that the typeinfo variables + % for polymorphic complicated unifications are ground. + % For that case, we don't care about the ArgNum. + ModeInfo = ModeInfo0 ; error("mode_info_set_call_arg_context") ). diff --git a/compiler/mode_util.m b/compiler/mode_util.m index 112ba10b5..d9a63b18c 100644 --- a/compiler/mode_util.m +++ b/compiler/mode_util.m @@ -1,5 +1,5 @@ %-----------------------------------------------------------------------------% -% Copyright (C) 1994-1998 The University of Melbourne. +% Copyright (C) 1994-1999 The University of Melbourne. % This file may only be copied under the terms of the GNU General % Public License - see the file COPYING in the Mercury distribution. %-----------------------------------------------------------------------------% @@ -157,11 +157,11 @@ %-----------------------------------------------------------------------------% -:- pred normalise_insts(list(inst), module_info, list(inst)). -:- mode normalise_insts(in, in, out) is det. +:- pred normalise_insts(list(inst), list(type), module_info, list(inst)). +:- mode normalise_insts(in, in, in, out) is det. -:- pred normalise_inst(inst, module_info, inst). -:- mode normalise_inst(in, in, out) is det. +:- pred normalise_inst(inst, (type), module_info, inst). +:- mode normalise_inst(in, in, in, out) is det. %-----------------------------------------------------------------------------% @@ -182,7 +182,7 @@ :- implementation. :- import_module require, int, map, set, std_util, assoc_list. -:- import_module prog_util, type_util. +:- import_module prog_util, prog_io, type_util. :- import_module inst_match, inst_util, term. %-----------------------------------------------------------------------------% @@ -1509,27 +1509,39 @@ strip_builtin_qualifiers_from_pred_inst(yes(Pred0), yes(Pred)) :- %-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------% -normalise_insts([], _, []). -normalise_insts([Inst0|Insts0], ModuleInfo, [Inst|Insts]) :- - normalise_inst(Inst0, ModuleInfo, Inst), - normalise_insts(Insts0, ModuleInfo, Insts). +normalise_insts([], [], _, []). +normalise_insts([Inst0|Insts0], [Type|Types], ModuleInfo, [Inst|Insts]) :- + normalise_inst(Inst0, Type, ModuleInfo, Inst), + normalise_insts(Insts0, Types, ModuleInfo, Insts). +normalise_insts([], [_|_], _, _) :- + error("normalise_insts: length mismatch"). +normalise_insts([_|_], [], _, _) :- + error("normalise_insts: length mismatch"). % This is a bit of a hack. % The aim is to avoid non-termination due to the creation % of ever-expanding insts. % XXX should also normalise partially instantiated insts. -normalise_inst(Inst0, ModuleInfo, NormalisedInst) :- +normalise_inst(Inst0, Type, ModuleInfo, NormalisedInst) :- inst_expand(ModuleInfo, Inst0, Inst), ( Inst = bound(_, _) -> ( inst_is_ground(ModuleInfo, Inst), - inst_is_unique(ModuleInfo, Inst) + inst_is_unique(ModuleInfo, Inst), + % don't infer unique modes for introduced type_infos + % arguments, because that leads to an increase + % in the number of inferred modes without any benefit + \+ is_introduced_type_info_type(Type) -> NormalisedInst = ground(unique, no) ; inst_is_ground(ModuleInfo, Inst), - inst_is_mostly_unique(ModuleInfo, Inst) + inst_is_mostly_unique(ModuleInfo, Inst), + % don't infer unique modes for introduced type_infos + % arguments, because that leads to an increase + % in the number of inferred modes without any benefit + \+ is_introduced_type_info_type(Type) -> NormalisedInst = ground(mostly_unique, no) ; diff --git a/compiler/modecheck_call.m b/compiler/modecheck_call.m index 04c2461a8..b2c568471 100644 --- a/compiler/modecheck_call.m +++ b/compiler/modecheck_call.m @@ -139,12 +139,14 @@ modecheck_higher_order_call(PredOrFunc, PredVar, Args0, Types, Modes, Det, Args, Det = Det0, Modes = Modes0, + ArgOffset = 1, + % % Check that `Args0' have livenesses which match the % expected livenesses. % get_arg_lives(Modes, ModuleInfo0, ExpectedArgLives), - modecheck_var_list_is_live(Args0, ExpectedArgLives, 1, + modecheck_var_list_is_live(Args0, ExpectedArgLives, ArgOffset, ModeInfo0, ModeInfo1), % @@ -153,11 +155,11 @@ modecheck_higher_order_call(PredOrFunc, PredVar, Args0, Types, Modes, Det, Args, % extra unifications for implied modes, if necessary). % mode_list_get_initial_insts(Modes, ModuleInfo0, InitialInsts), - modecheck_var_has_inst_list(Args0, InitialInsts, 0, + modecheck_var_has_inst_list(Args0, InitialInsts, ArgOffset, ModeInfo1, ModeInfo2), mode_list_get_final_insts(Modes, ModuleInfo0, FinalInsts), modecheck_set_var_inst_list(Args0, InitialInsts, FinalInsts, - Args, ExtraGoals, ModeInfo2, ModeInfo3), + ArgOffset, Args, ExtraGoals, ModeInfo2, ModeInfo3), ( determinism_components(Det, _, at_most_zero) -> instmap__init_unreachable(Instmap), mode_info_set_instmap(Instmap, ModeInfo3, ModeInfo) @@ -200,6 +202,7 @@ modecheck_call_pred(PredId, ProcId0, ArgVars0, DeterminismKnown, map__keys(Procs, ProcIds) ), + compute_arg_offset(PredInfo, ArgOffset), pred_info_get_markers(PredInfo, Markers), % In order to give better diagnostics, we handle the @@ -223,12 +226,13 @@ modecheck_call_pred(PredId, ProcId0, ArgVars0, DeterminismKnown, -> TheProcId = ProcId, map__lookup(Procs, ProcId, ProcInfo), + % % Check that `ArgsVars0' have livenesses which match the % expected livenesses. % proc_info_arglives(ProcInfo, ModuleInfo, ProcArgLives0), - modecheck_var_list_is_live(ArgVars0, ProcArgLives0, 0, + modecheck_var_list_is_live(ArgVars0, ProcArgLives0, ArgOffset, ModeInfo0, ModeInfo1), % @@ -239,10 +243,10 @@ modecheck_call_pred(PredId, ProcId0, ArgVars0, DeterminismKnown, proc_info_argmodes(ProcInfo, ProcArgModes), mode_list_get_initial_insts(ProcArgModes, ModuleInfo, InitialInsts), - modecheck_var_has_inst_list(ArgVars0, InitialInsts, 0, + modecheck_var_has_inst_list(ArgVars0, InitialInsts, ArgOffset, ModeInfo1, ModeInfo2), - modecheck_end_of_call(ProcInfo, ArgVars0, ArgVars, + modecheck_end_of_call(ProcInfo, ArgVars0, ArgOffset, ArgVars, ExtraGoals, ModeInfo2, ModeInfo) ; % set the current error list to empty (and @@ -269,8 +273,8 @@ modecheck_call_pred(PredId, ProcId0, ArgVars0, DeterminismKnown, choose_best_match(MatchingProcIds, PredId, Procs, ArgVars0, TheProcId, ModeInfo2), map__lookup(Procs, TheProcId, ProcInfo), - modecheck_end_of_call(ProcInfo, ArgVars0, ArgVars, - ExtraGoals, ModeInfo2, ModeInfo3) + modecheck_end_of_call(ProcInfo, ArgVars0, ArgOffset, + ArgVars, ExtraGoals, ModeInfo2, ModeInfo3) ), % restore the error list, appending any new error(s) @@ -370,19 +374,19 @@ modecheck_find_matching_modes([ProcId | ProcIds], PredId, Procs, ArgVars0, MatchingProcIds1, MatchingProcIds, WaitingVars1, WaitingVars, ModeInfo3, ModeInfo). -:- pred modecheck_end_of_call(proc_info, list(prog_var), list(prog_var), - extra_goals, mode_info, mode_info). -:- mode modecheck_end_of_call(in, in, out, out, +:- pred modecheck_end_of_call(proc_info, list(prog_var), int, + list(prog_var), extra_goals, mode_info, mode_info). +:- mode modecheck_end_of_call(in, in, in, out, out, mode_info_di, mode_info_uo) is det. -modecheck_end_of_call(ProcInfo, ArgVars0, ArgVars, ExtraGoals, - ModeInfo0, ModeInfo) :- +modecheck_end_of_call(ProcInfo, ArgVars0, ArgOffset, + ArgVars, ExtraGoals, ModeInfo0, ModeInfo) :- proc_info_argmodes(ProcInfo, ProcArgModes), mode_info_get_module_info(ModeInfo0, ModuleInfo), mode_list_get_initial_insts(ProcArgModes, ModuleInfo, InitialInsts), mode_list_get_final_insts(ProcArgModes, ModuleInfo, FinalInsts), modecheck_set_var_inst_list(ArgVars0, InitialInsts, FinalInsts, - ArgVars, ExtraGoals, ModeInfo0, ModeInfo1), + ArgOffset, ArgVars, ExtraGoals, ModeInfo0, ModeInfo1), proc_info_never_succeeds(ProcInfo, NeverSucceeds), ( NeverSucceeds = yes -> instmap__init_unreachable(Instmap), @@ -437,8 +441,10 @@ get_var_insts_and_lives([Var | Vars], ModeInfo, [Inst | Insts], [IsLive | IsLives]) :- mode_info_get_module_info(ModeInfo, ModuleInfo), mode_info_get_instmap(ModeInfo, InstMap), + mode_info_get_var_types(ModeInfo, VarTypes), instmap__lookup_var(InstMap, Var, Inst0), - normalise_inst(Inst0, ModuleInfo, Inst), + map__lookup(VarTypes, Var, Type), + normalise_inst(Inst0, Type, ModuleInfo, Inst), mode_info_var_is_live(ModeInfo, Var, IsLive0), diff --git a/compiler/modecheck_unify.m b/compiler/modecheck_unify.m index 0d66f6fb5..84f8297be 100644 --- a/compiler/modecheck_unify.m +++ b/compiler/modecheck_unify.m @@ -20,8 +20,7 @@ :- module modecheck_unify. :- interface. -:- import_module hlds_goal, hlds_data, prog_data, mode_info. -:- import_module map. +:- import_module hlds_goal, prog_data, mode_info. % Modecheck a unification :- pred modecheck_unification(prog_var, unify_rhs, unification, unify_context, @@ -29,18 +28,11 @@ :- mode modecheck_unification(in, in, in, in, in, out, mode_info_di, mode_info_uo) is det. - % Work out what kind of unification a var-var unification is. -:- pred categorize_unify_var_var(mode, mode, is_live, is_live, prog_var, - prog_var, determinism, unify_context, map(prog_var, type), - mode_info, hlds_goal_expr, mode_info). -:- mode categorize_unify_var_var(in, in, in, in, in, in, in, in, in, - mode_info_di, out, mode_info_uo) is det. - % Create a unification between the two given variables. % The goal's mode and determinism information is not filled in. -:- pred modecheck_unify__create_var_var_unification(prog_var, prog_var, +:- pred modecheck_unify__create_var_var_unification(prog_var, prog_var, type, mode_info, hlds_goal). -:- mode modecheck_unify__create_var_var_unification(in, in, +:- mode modecheck_unify__create_var_var_unification(in, in, in, mode_info_ui, out) is det. %-----------------------------------------------------------------------------% @@ -49,18 +41,19 @@ :- implementation. :- import_module llds, prog_util, type_util, module_qual, instmap. -:- import_module hlds_module, hlds_goal, hlds_pred, hlds_out. +:- import_module hlds_module, hlds_goal, hlds_pred, hlds_data, hlds_out. :- import_module mode_debug, mode_util, mode_info, modes, mode_errors. :- import_module inst_match, inst_util, unify_proc, code_util, unique_modes. :- import_module typecheck, modecheck_call, (inst), quantification, make_hlds. +:- import_module polymorphism. -:- import_module bool, list, std_util, int, set, require. +:- import_module bool, list, map, std_util, int, set, require. :- import_module string, assoc_list. :- import_module term, varset. %-----------------------------------------------------------------------------% -modecheck_unification(X, var(Y), _Unification0, UnifyContext, _GoalInfo, +modecheck_unification(X, var(Y), Unification0, UnifyContext, _GoalInfo, Unify, ModeInfo0, ModeInfo) :- mode_info_get_module_info(ModeInfo0, ModuleInfo0), mode_info_get_instmap(ModeInfo0, InstMap0), @@ -86,7 +79,8 @@ modecheck_unification(X, var(Y), _Unification0, UnifyContext, _GoalInfo, ModeOfY = (InstOfY -> Inst), mode_info_get_var_types(ModeInfo3, VarTypes), categorize_unify_var_var(ModeOfX, ModeOfY, LiveX, LiveY, X, Y, - Det, UnifyContext, VarTypes, ModeInfo3, Unify, ModeInfo) + Det, UnifyContext, VarTypes, Unification0, ModeInfo3, + Unify, ModeInfo) ; set__list_to_set([X, Y], WaitingVars), mode_info_error(WaitingVars, mode_error_unify_var_var(X, Y, @@ -112,96 +106,6 @@ modecheck_unification(X0, functor(ConsId0, ArgVars0), Unification0, mode_info_get_module_info(ModeInfo0, ModuleInfo0), mode_info_get_var_types(ModeInfo0, VarTypes0), map__lookup(VarTypes0, X0, TypeOfX), - module_info_get_predicate_table(ModuleInfo0, PredTable), - list__length(ArgVars0, Arity), - mode_info_get_predid(ModeInfo0, ThisPredId), - mode_info_get_how_to_check(ModeInfo0, HowToCheckGoal), - ( - % - % is the function symbol apply/N or ''/N, - % representing a higher-order function call? - % - % (As an optimization, if HowToCheck = check_unique_modes, - % then don't bother checking, since they will have already - % been expanded.) - % - HowToCheckGoal \= check_unique_modes, - ConsId0 = cons(unqualified(ApplyName), _), - ( ApplyName = "apply" ; ApplyName = "" ), - Arity >= 1, - ArgVars0 = [FuncVar | FuncArgVars] - -> - % - % 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)') - % and then mode-check it. - % - modecheck_higher_order_func_call(FuncVar, FuncArgVars, X0, - GoalInfo0, Goal, ModeInfo0, ModeInfo) - ; - % - % is the function symbol a user-defined function, rather - % than a functor which represents a data constructor? - % - - % As an optimization, if HowToCheck = check_unique_modes, - % then don't bother checking, since they will have already - % been expanded. - HowToCheckGoal \= check_unique_modes, - - % Find the set of candidate predicates which have the - % specified name and arity (and module, if module-qualified) - ConsId0 = cons(PredName, _), - module_info_pred_info(ModuleInfo0, ThisPredId, PredInfo), - - % - % 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.) - % - - \+ code_util__compiler_generated(PredInfo), - - 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 - - pred_info_typevarset(PredInfo, 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 modecheck it - % - modecheck_goal_expr(FuncCall, GoalInfo0, Goal, ModeInfo0, ModeInfo) - - ; - % % We replace any unifications with higher-order pred constants % by lambda expressions. For example, we replace @@ -212,18 +116,13 @@ modecheck_unification(X0, functor(ConsId0, ArgVars0), Unification0, % % X = lambda [A1::in, A2::out] (list__append(Y, A1, A2)) % - % We do this because it makes two things easier. - % Firstly, we need 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. - % Secondly, the polymorphism 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. + % Normally this is done by polymorphism__process_unify_functor, + % but if we're re-modechecking goals after lambda.m has been run + % (e.g. for deforestation), then we may need to do it again here. + % Note that any changes to this code here will probably need to be + % duplicated there too. % - + ( % check if variable has a higher-order type type_is_higher_order(TypeOfX, PredOrFunc, PredArgTypes), ConsId0 = cons(PName, _), @@ -234,89 +133,23 @@ modecheck_unification(X0, functor(ConsId0, ArgVars0), Unification0, Unification0 \= deconstruct(_, code_addr_const(_, _), _, _, _) -> % - % Create the new lambda-quantified variables + % convert the pred term to a lambda expression % mode_info_get_varset(ModeInfo0, VarSet0), - make_fresh_vars(PredArgTypes, VarSet0, VarTypes0, - LambdaVars, VarSet, VarTypes), - list__append(ArgVars0, LambdaVars, Args), - mode_info_set_varset(VarSet, ModeInfo0, ModeInfo1), - mode_info_set_var_types(VarTypes, ModeInfo1, ModeInfo2), - - % - % Build up the hlds_goal_expr for the call that will form - % the lambda goal - % - + mode_info_get_context(ModeInfo0, Context), + mode_info_get_predid(ModeInfo0, ThisPredId), module_info_pred_info(ModuleInfo0, ThisPredId, ThisPredInfo), pred_info_typevarset(ThisPredInfo, TVarSet), - map__apply_to_list(Args, VarTypes, ArgTypes), - ( - % If we are redoing mode analysis, use the - % pred_id and proc_id found before, to avoid aborting - % in get_pred_id_and_proc_id if there are multiple - % matching procedures. - Unification0 = construct(_, - pred_const(PredId0, ProcId0), _, _) - -> - PredId = PredId0, - ProcId = ProcId0 - ; - 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), - + convert_pred_to_lambda_goal(PredOrFunc, X0, ConsId0, PName, + ArgVars0, PredArgTypes, TVarSet, + Unification0, UnifyContext, GoalInfo0, Context, + ModuleInfo0, VarSet0, VarTypes0, + Functor0, VarSet, VarTypes), + mode_info_set_varset(VarSet, ModeInfo0, ModeInfo1), + mode_info_set_var_types(VarTypes, ModeInfo1, ModeInfo2), % - % construct a goal_info for the lambda goal, making sure - % to set up the nonlocals field in the goal_info correctly + % modecheck this unification in its new form % - 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), - mode_info_get_context(ModeInfo2, 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 - % - proc_info_argmodes(ProcInfo, ArgModes), - ( list__drop(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 modecheck this unification in its new form - % - Functor0 = lambda_goal(PredOrFunc, ArgVars0, LambdaVars, - LambdaModes, LambdaDet, LambdaGoal), modecheck_unification( X0, Functor0, Unification0, UnifyContext, GoalInfo0, Goal, ModeInfo2, ModeInfo) ; @@ -574,14 +407,13 @@ modecheck_unify_functor(X, TypeOfX, ConsId0, ArgVars0, Unification0, % fully module qualify all cons_ids % (except for builtins such as ints and characters). % - list__length(ArgVars0, Arity), ( - ConsId0 = cons(Name, _), + ConsId0 = cons(Name, OrigArity), type_to_type_id(TypeOfX, TypeId, _), TypeId = qualified(TypeModule, _) - _ -> unqualify_name(Name, UnqualName), - ConsId = cons(qualified(TypeModule, UnqualName), Arity) + ConsId = cons(qualified(TypeModule, UnqualName), OrigArity) ; ConsId = ConsId0 ), @@ -645,6 +477,7 @@ modecheck_unify_functor(X, TypeOfX, ConsId0, ArgVars0, Unification0, ), ( inst_expand(ModuleInfo1, InstOfX, InstOfX1), + list__length(ArgVars0, Arity), get_arg_insts(InstOfX1, ConsId, Arity, InstOfXArgs), get_mode_of_args(Inst, InstOfXArgs, ModeOfXArgs0) -> @@ -810,7 +643,7 @@ split_complicated_subunifies_2([Var0 | Vars0], [UniMode0 | UniModes0], mode_info_set_var_types(VarTypes, ModeInfo1, ModeInfo2), modecheck_unify__create_var_var_unification(Var0, Var, - ModeInfo2, ExtraGoal), + VarType, ModeInfo2, ExtraGoal), % insert the new unification at % the start of the extra goals @@ -827,32 +660,68 @@ split_complicated_subunifies_2([Var0 | Vars0], [UniMode0 | UniModes0], Vars = [Var0 | Vars1] ). -modecheck_unify__create_var_var_unification(Var0, Var, ModeInfo, - ExtraGoal - GoalInfo) :- +modecheck_unify__create_var_var_unification(Var0, Var, Type, ModeInfo, + Goal - GoalInfo) :- mode_info_get_context(ModeInfo, Context), mode_info_get_mode_context(ModeInfo, ModeContext), mode_context_to_unify_context(ModeContext, ModeInfo, UnifyContext), UnifyContext = unify_context(MainContext, SubContexts), create_atomic_unification(Var0, var(Var), Context, - MainContext, SubContexts, ExtraGoal - GoalInfo0), - - % compute the goal_info nonlocal vars - % for the newly created goal + MainContext, SubContexts, Goal0 - GoalInfo0), + + % + % compute the goal_info nonlocal vars for the newly created goal + % (excluding the type_info vars -- they are added below). % N.B. This may overestimate the set of non-locals, % but that shouldn't cause any problems. + % set__list_to_set([Var0, Var], NonLocals), goal_info_set_nonlocals(GoalInfo0, NonLocals, GoalInfo1), - goal_info_set_context(GoalInfo1, Context, GoalInfo). + goal_info_set_context(GoalInfo1, Context, GoalInfo2), + % + % Look up the map(tvar, type_info_locn) in the proc_info, + % since it is needed by polymorphism__unification_typeinfos + % + mode_info_get_module_info(ModeInfo, ModuleInfo), + mode_info_get_predid(ModeInfo, PredId), + mode_info_get_procid(ModeInfo, ProcId), + module_info_pred_proc_info(ModuleInfo, PredId, ProcId, + _PredInfo, ProcInfo), + proc_info_typeinfo_varmap(ProcInfo, TypeInfoVarMap), + + % + % Call polymorphism__unification_typeinfos to add the appropriate + % type-info and type-class-info variables to the nonlocals + % and to the unification. + % + ( + Goal0 = unify(X, Y, Mode, Unification0, FinalUnifyContext) + -> + polymorphism__unification_typeinfos(Type, TypeInfoVarMap, + Unification0, GoalInfo2, Unification, GoalInfo), + Goal = unify(X, Y, Mode, Unification, FinalUnifyContext) + ; + error("modecheck_unify__create_var_var_unification") + ). + %-----------------------------------------------------------------------------% + % Work out what kind of unification a var-var unification is. +:- pred categorize_unify_var_var(mode, mode, is_live, is_live, prog_var, + prog_var, determinism, unify_context, map(prog_var, type), + unification, mode_info, hlds_goal_expr, mode_info). +:- mode categorize_unify_var_var(in, in, in, in, in, in, in, in, in, in, + mode_info_di, out, mode_info_uo) is det. + % categorize_unify_var_var works out which category a unification % between a variable and another variable expression is - whether it is % an assignment, a simple test or a complicated unify. categorize_unify_var_var(ModeOfX, ModeOfY, LiveX, LiveY, X, Y, Det, - UnifyContext, VarTypes, ModeInfo0, Unify, ModeInfo) :- + UnifyContext, VarTypes, Unification0, ModeInfo0, + Unify, ModeInfo) :- mode_info_get_module_info(ModeInfo0, ModuleInfo0), ( mode_is_output(ModuleInfo0, ModeOfX) @@ -879,6 +748,21 @@ categorize_unify_var_var(ModeOfX, ModeOfY, LiveX, LiveY, X, Y, Det, error("categorize_unify_var_var: free-free unify!") ), ModeInfo = ModeInfo0 + ; + % + % Check for unreachable unifications + % + ( mode_get_insts(ModuleInfo0, ModeOfX, not_reached, _) + ; mode_get_insts(ModuleInfo0, ModeOfY, not_reached, _) + ) + -> + % + % For these, we can generate any old junk here -- + % we just need to avoid calling modecheck_complicated_unify, + % since that might abort. + % + Unification = simple_test(X, Y), + ModeInfo = ModeInfo0 ; map__lookup(VarTypes, X, Type), ( @@ -887,49 +771,10 @@ categorize_unify_var_var(ModeOfX, ModeOfY, LiveX, LiveY, X, Y, Det, Unification = simple_test(X, Y), ModeInfo = ModeInfo0 ; - mode_get_insts(ModuleInfo0, ModeOfX, IX, FX), - mode_get_insts(ModuleInfo0, ModeOfY, IY, FY), - determinism_components(Det, CanFail, _), - UniMode = ((IX - IY) -> (FX - FY)), - Unification = complicated_unify(UniMode, CanFail), - mode_info_get_instmap(ModeInfo0, InstMap0), - ( - type_is_higher_order(Type, PredOrFunc, _) - -> - % We do not want to report this as an error - % if it occurs in a compiler-generated - % predicate - instead, we delay the error - % until runtime so that it only occurs if - % the compiler-generated predicate gets called. - % not_reached is considered bound, so the - % error message would be spurious if the - % instmap is unreachable. - mode_info_get_predid(ModeInfo0, PredId), - module_info_pred_info(ModuleInfo0, PredId, - PredInfo), - ( - ( code_util__compiler_generated(PredInfo) - ; instmap__is_unreachable(InstMap0) - ) - -> - ModeInfo = ModeInfo0 - ; - set__init(WaitingVars), - mode_info_error(WaitingVars, - mode_error_unify_pred(X, error_at_var(Y), Type, PredOrFunc), - ModeInfo0, ModeInfo) - ) - ; - type_to_type_id(Type, TypeId, _) - -> - mode_info_get_context(ModeInfo0, Context), - unify_proc__request_unify(TypeId - UniMode, - Det, Context, ModuleInfo0, ModuleInfo), - mode_info_set_module_info(ModeInfo0, ModuleInfo, - ModeInfo) - ; - ModeInfo = ModeInfo0 - ) + modecheck_complicated_unify(X, Y, + Type, ModeOfX, ModeOfY, Det, UnifyContext, + Unification0, ModeInfo0, + Unification, ModeInfo) ) ), % @@ -969,6 +814,132 @@ categorize_unify_var_var(ModeOfX, ModeOfY, LiveX, LiveY, X, Y, Det, UnifyContext) ). +% +% modecheck_complicated_unify does some extra checks that are needed +% for mode-checking complicated unifications. +% + +:- pred modecheck_complicated_unify(prog_var, prog_var, + type, mode, mode, determinism, unify_context, + unification, mode_info, unification, mode_info). +:- mode modecheck_complicated_unify(in, in, in, in, in, in, in, + in, mode_info_di, out, mode_info_uo) is det. + +modecheck_complicated_unify(X, Y, Type, ModeOfX, ModeOfY, Det, UnifyContext, + Unification0, ModeInfo0, Unification, ModeInfo) :- + % + % Build up the unification + % + mode_info_get_module_info(ModeInfo0, ModuleInfo0), + mode_get_insts(ModuleInfo0, ModeOfX, InitialInstX, FinalInstX), + mode_get_insts(ModuleInfo0, ModeOfY, InitialInstY, FinalInstY), + UniMode = ((InitialInstX - InitialInstY) -> (FinalInstX - FinalInstY)), + determinism_components(Det, CanFail, _), + ( Unification0 = complicated_unify(_, _, UnifyTypeInfoVars0) -> + UnifyTypeInfoVars = UnifyTypeInfoVars0 + ; + error("modecheck_complicated_unify") + ), + Unification = complicated_unify(UniMode, CanFail, UnifyTypeInfoVars), + + % + % check that all the type_info or type_class_info variables used + % by the polymorphic unification are ground. + % + ( UnifyTypeInfoVars = [] -> + % optimize common case + ModeInfo2 = ModeInfo0 + ; + list__length(UnifyTypeInfoVars, NumTypeInfoVars), + list__duplicate(NumTypeInfoVars, ground(shared, no), + ExpectedInsts), + mode_info_set_call_context(unify(UnifyContext), + ModeInfo0, ModeInfo1), + InitialArgNum = 0, + modecheck_var_has_inst_list(UnifyTypeInfoVars, ExpectedInsts, + InitialArgNum, ModeInfo1, ModeInfo2) + ), + + mode_info_get_module_info(ModeInfo2, ModuleInfo2), + + ( + mode_info_get_errors(ModeInfo2, Errors), + Errors \= [] + -> + ModeInfo = ModeInfo2 + ; + % + % Check that we're not trying to do a polymorphic unification + % in a mode other than (in, in). + % [Actually we also allow `any' insts, since the (in, in) + % mode of unification for types which have `any' insts must + % also be able to handle (in(any), in(any)) unifications.] + % + Type = term__variable(_), + \+ inst_is_ground_or_any(ModuleInfo2, InitialInstX) + -> + set__singleton_set(WaitingVars, X), + mode_info_error(WaitingVars, + mode_error_poly_unify(X, InitialInstX), + ModeInfo2, ModeInfo) + ; + Type = term__variable(_), + \+ inst_is_ground_or_any(ModuleInfo2, InitialInstY) + -> + set__singleton_set(WaitingVars, Y), + mode_info_error(WaitingVars, + mode_error_poly_unify(Y, InitialInstY), + ModeInfo2, ModeInfo) + ; + + % + % check that we're not trying to do a higher-order unification + % + type_is_higher_order(Type, PredOrFunc, _) + -> + % We do not want to report this as an error + % if it occurs in a compiler-generated + % predicate - instead, we delay the error + % until runtime so that it only occurs if + % the compiler-generated predicate gets called. + % not_reached is considered bound, so the + % error message would be spurious if the + % instmap is unreachable. + mode_info_get_predid(ModeInfo2, PredId), + module_info_pred_info(ModuleInfo2, PredId, + PredInfo), + mode_info_get_instmap(ModeInfo2, InstMap0), + ( + ( code_util__compiler_generated(PredInfo) + ; instmap__is_unreachable(InstMap0) + ) + -> + ModeInfo = ModeInfo2 + ; + set__init(WaitingVars), + mode_info_error(WaitingVars, + mode_error_unify_pred(X, error_at_var(Y), + Type, PredOrFunc), + ModeInfo2, ModeInfo) + ) + ; + % + % Ensure that we will generate code for the unification + % procedure that will be used to implement this complicated + % unification. + % + type_to_type_id(Type, TypeId, _) + -> + mode_info_get_context(ModeInfo2, Context), + unify_proc__request_unify(TypeId - UniMode, + Det, Context, ModuleInfo2, ModuleInfo), + mode_info_set_module_info(ModeInfo2, ModuleInfo, + ModeInfo) + ; + ModeInfo = ModeInfo2 + ). + + % categorize_unify_var_lambda works out which category a unification % between a variable and a lambda expression is - whether it is a construction % unification or a deconstruction. It also works out whether it will @@ -990,7 +961,7 @@ categorize_unify_var_lambda(ModeOfX, ArgModes0, X, ArgVars, ; Unification0 = deconstruct(_, ConsId1, _, _, _) -> ConsId = ConsId1 ; - % the real cons_id will be computed by polymorphism.m; + % the real cons_id will be computed by lambda.m; % we just put in a dummy one for now ConsId = cons(unqualified("__LambdaGoal__"), Arity) ), @@ -1218,18 +1189,5 @@ mode_set_args([Inst | Insts], FinalInst, [Mode | Modes]) :- Mode = (Inst -> FinalInst), mode_set_args(Insts, FinalInst, Modes). -%-----------------------------------------------------------------------------% - -:- 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). - %-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------% diff --git a/compiler/modes.m b/compiler/modes.m index e14a58ba0..c0336f582 100644 --- a/compiler/modes.m +++ b/compiler/modes.m @@ -202,6 +202,16 @@ a variable live if its value will be used later on in the computation. :- pred get_live_vars(list(prog_var), list(is_live), list(prog_var)). :- mode get_live_vars(in, in, out) is det. + % + % calculate the argument number offset that needs to be passed to + % modecheck_var_list_is_live, modecheck_var_has_inst_list, and + % modecheck_set_var_inst_list. This offset number is calculated + % so that real arguments get positive argument numbers and + % type_info arguments get argument numbers less than or equal to 0. + % +:- pred compute_arg_offset(pred_info, int). +:- mode compute_arg_offset(in, out) is det. + % Given a list of variables and a list of expected liveness, ensure % that the inst of each variable satisfies the corresponding expected % liveness. @@ -224,8 +234,8 @@ a variable live if its value will be used later on in the computation. :- mode modecheck_set_var_inst(in, in, mode_info_di, mode_info_uo) is det. :- pred modecheck_set_var_inst_list(list(prog_var), list(inst), list(inst), - list(prog_var), extra_goals, mode_info, mode_info). -:- mode modecheck_set_var_inst_list(in, in, in, out, out, + int, list(prog_var), extra_goals, mode_info, mode_info). +:- mode modecheck_set_var_inst_list(in, in, in, in, out, out, mode_info_di, mode_info_uo) is det. % check that the final insts of the head vars of a lambda @@ -392,6 +402,7 @@ modecheck_to_fixpoint(PredIds, MaxIterations, WhatToCheck, MayChangeCalledProc, ; [] ), + % % Mode analysis may have modified the procedure % bodies, since it does some optimizations such @@ -402,6 +413,7 @@ modecheck_to_fixpoint(PredIds, MaxIterations, WhatToCheck, MayChangeCalledProc, % they may therefore produce incorrect results. % Thus we need to restore the old procedure bodies. % + ( { WhatToCheck = check_modes } -> % restore the proc_info goals from the % clauses in the pred_info @@ -413,6 +425,7 @@ modecheck_to_fixpoint(PredIds, MaxIterations, WhatToCheck, MayChangeCalledProc, { copy_pred_bodies(OldPredTable, PredIds, ModuleInfo3, ModuleInfo4) } ), + { MaxIterations1 is MaxIterations - 1 }, modecheck_to_fixpoint(PredIds, MaxIterations1, WhatToCheck, MayChangeCalledProc, @@ -453,14 +466,25 @@ copy_pred_bodies(OldPredTable, PredIds, ModuleInfo0, ModuleInfo) :- :- mode copy_pred_body(in, in, in, out) is det. copy_pred_body(OldPredTable, PredId, PredTable0, PredTable) :- map__lookup(PredTable0, PredId, PredInfo0), - pred_info_procedures(PredInfo0, ProcTable0), - map__lookup(OldPredTable, PredId, OldPredInfo), - pred_info_procedures(OldPredInfo, OldProcTable), - map__keys(OldProcTable, OldProcIds), - list__foldl(copy_proc_body(OldProcTable), OldProcIds, - ProcTable0, ProcTable), - pred_info_set_procedures(PredInfo0, ProcTable, PredInfo), - map__set(PredTable0, PredId, PredInfo, PredTable). + ( + % don't copy type class methods, because their + % proc_infos are generated already mode-correct, + % and because copying from the clauses_info doesn't + % work for them. + pred_info_get_markers(PredInfo0, Markers), + check_marker(Markers, class_method) + -> + PredTable = PredTable0 + ; + pred_info_procedures(PredInfo0, ProcTable0), + map__lookup(OldPredTable, PredId, OldPredInfo), + pred_info_procedures(OldPredInfo, OldProcTable), + map__keys(OldProcTable, OldProcIds), + list__foldl(copy_proc_body(OldProcTable), OldProcIds, + ProcTable0, ProcTable), + pred_info_set_procedures(PredInfo0, ProcTable, PredInfo), + map__set(PredTable0, PredId, PredInfo, PredTable) + ). % copy_proc_body(OldProcTable, ProcId, ProcTable0, ProcTable): % copy the body of the specified ProcId from OldProcTable @@ -487,11 +511,24 @@ modecheck_pred_modes_2([PredId | PredIds], WhatToCheck, MayChangeCalledProc, NumErrors0, NumErrors) --> { module_info_preds(ModuleInfo0, Preds0) }, { map__lookup(Preds0, PredId, PredInfo0) }, - ( { pred_info_is_imported(PredInfo0) } -> - { ModuleInfo3 = ModuleInfo0 }, - { Changed1 = Changed0 }, - { NumErrors1 = NumErrors0 } - ; { pred_info_is_pseudo_imported(PredInfo0) } -> + ( + ( + % + % don't modecheck imported predicates + % + ( { pred_info_is_imported(PredInfo0) } + ; { pred_info_is_pseudo_imported(PredInfo0) } + ) + ; + % + % don't modecheck class methods, because they + % are generated already mode-correct and with + % correct instmap deltas. + % + { pred_info_get_markers(PredInfo0, PredMarkers) }, + { check_marker(PredMarkers, class_method) } + ) + -> { ModuleInfo3 = ModuleInfo0 }, { Changed1 = Changed0 }, { NumErrors1 = NumErrors0 } @@ -717,7 +754,7 @@ modecheck_proc_3(ProcId, PredId, WhatToCheck, MayChangeCalledProc, % we use the context of the mode declaration. module_info_pred_info(ModuleInfo0, PredId, PredInfo), pred_info_clauses_info(PredInfo, ClausesInfo), - ClausesInfo = clauses_info(_, _, _, _, ClauseList), + clauses_info_clauses(ClausesInfo, ClauseList), ( ClauseList = [FirstClause | _] -> FirstClause = clause(_, _, Context) ; @@ -800,10 +837,13 @@ modecheck_final_insts_2(HeadVars, FinalInsts0, ModeInfo0, InferModes, FinalInsts, ModeInfo) :- mode_info_get_module_info(ModeInfo0, ModuleInfo), mode_info_get_instmap(ModeInfo0, InstMap), + mode_info_get_var_types(ModeInfo0, VarTypes), instmap__lookup_vars(HeadVars, InstMap, VarFinalInsts1), + map__apply_to_list(HeadVars, VarTypes, ArgTypes), ( InferModes = yes -> - normalise_insts(VarFinalInsts1, ModuleInfo, VarFinalInsts2), + normalise_insts(VarFinalInsts1, ArgTypes, ModuleInfo, + VarFinalInsts2), % % make sure we set the final insts of any variables which % we assumed were dead to `clobbered'. @@ -995,10 +1035,19 @@ modecheck_goal_expr(if_then_else(Vs, A0, B0, C0, SM), GoalInfo0, Goal) --> mode_info_lock_vars(if_then_else, NonLocals), mode_info_add_live_vars(B_Vars), modecheck_goal(A0, A), + mode_info_dcg_get_instmap(InstMapA), mode_info_remove_live_vars(B_Vars), mode_info_unlock_vars(if_then_else, NonLocals), - modecheck_goal(B0, B), - mode_info_dcg_get_instmap(InstMapB), + ( { instmap__is_reachable(InstMapA) } -> + modecheck_goal(B0, B), + mode_info_dcg_get_instmap(InstMapB) + ; + % We should not mode-analyse the goal, since it is unreachable. + % Instead we optimize the goal away, so that later passes + % won't complain about it not having mode information. + { true_goal(B) }, + { InstMapB = InstMapA } + ), mode_info_set_instmap(InstMap0), modecheck_goal(C0, C), mode_info_dcg_get_instmap(InstMapC), @@ -1024,7 +1073,9 @@ modecheck_goal_expr(some(Vs, G0), _, some(Vs, G)) --> modecheck_goal_expr(call(PredId, ProcId0, Args0, _, Context, PredName), GoalInfo0, Goal) --> - mode_checkpoint(enter, "call"), + { prog_out__sym_name_to_string(PredName, PredNameString) }, + { string__append("call ", PredNameString, CallString) }, + mode_checkpoint(enter, CallString), mode_info_set_call_context(call(PredId)), =(ModeInfo0), { mode_info_get_instmap(ModeInfo0, InstMap0) }, @@ -1041,7 +1092,7 @@ modecheck_goal_expr(call(PredId, ProcId0, Args0, _, Context, PredName), InstMap0, Goal), mode_info_unset_call_context, - mode_checkpoint(exit, "call"). + mode_checkpoint(exit, CallString). modecheck_goal_expr(higher_order_call(PredVar, Args0, _, _, _, PredOrFunc), GoalInfo0, Goal) --> @@ -1233,7 +1284,17 @@ modecheck_conj_list_no_delay([Goal0 | Goals0], [Goal | Goals]) --> { goal_get_nonlocals(Goal0, NonLocals) }, mode_info_remove_live_vars(NonLocals), modecheck_goal(Goal0, Goal), - modecheck_conj_list_no_delay(Goals0, Goals). + mode_info_dcg_get_instmap(InstMap), + ( { instmap__is_unreachable(InstMap) } -> + % We should not mode-analyse the remaining goals, since they + % are unreachable. Instead we optimize them away, so that + % later passes won't complain about them not having mode + % information. + mode_info_remove_goals_live_vars(Goals0), + { Goals = [] } + ; + modecheck_conj_list_no_delay(Goals0, Goals) + ). %-----------------------------------------------------------------------------% @@ -1391,6 +1452,10 @@ modecheck_conj_list_2([Goal0 | Goals0], ImpurityErrors0, mode_info_set_delay_info(DelayInfo), mode_info_dcg_get_instmap(InstMap), ( { instmap__is_unreachable(InstMap) } -> + % We should not mode-analyse the remaining goals, since they + % are unreachable. Instead we optimize them away, so that + % later passes won't complain about them not having mode + % information. mode_info_remove_goals_live_vars(Goals1), { Goals2 = [] }, { ImpurityErrors = ImpurityErrors2 } @@ -1428,7 +1493,7 @@ check_for_impurity_error(Goal, ImpurityErrors0, ImpurityErrors) --> { mode_info_get_predid(ModeInfo0, PredId) }, { module_info_pred_info(ModuleInfo, PredId, PredInfo) }, { pred_info_clauses_info(PredInfo, ClausesInfo) }, - { ClausesInfo = clauses_info(_,_,_,HeadVars,_) }, + { clauses_info_headvars(ClausesInfo, HeadVars) }, ( { no_non_headvar_unification_goals(DelayedGoals, HeadVars) } -> { ImpurityErrors = ImpurityErrors0 } ; @@ -1521,10 +1586,22 @@ modecheck_case_list([Case0 | Cases0], Var, modecheck_set_var_inst(Var, bound(unique, [functor(ConsId, ArgInsts)])), - modecheck_goal(Goal0, Goal1), - mode_info_dcg_get_instmap(InstMap), + % modecheck this case (if it is reachable) + mode_info_dcg_get_instmap(InstMap1), + ( { instmap__is_reachable(InstMap1) } -> + modecheck_goal(Goal0, Goal1), + mode_info_dcg_get_instmap(InstMap) + ; + % We should not mode-analyse the goal, since it is unreachable. + % Instead we optimize the goal away, so that later passes + % won't complain about it not having mode information. + { true_goal(Goal1) }, + { InstMap = InstMap1 } + ), + % Don't lose the information added by the functor test above. { fixup_switch_var(Var, InstMap0, InstMap, Goal1, Goal) }, + mode_info_set_instmap(InstMap0), modecheck_case_list(Cases0, Var, Cases, InstMaps). @@ -1582,6 +1659,21 @@ get_all_conjunct_nonlocals([G|Gs], NonLocals0, NonLocals) :- get_all_conjunct_nonlocals(Gs, NonLocals1, NonLocals). +%-----------------------------------------------------------------------------% + + % + % calculate the argument number offset that needs to be passed to + % modecheck_var_list_is_live, modecheck_var_has_inst_list, and + % modecheck_set_var_inst_list. This offset number is calculated + % so that real arguments get positive argument numbers and + % type_info arguments get argument numbers less than or equal to 0. + % +compute_arg_offset(PredInfo, ArgOffset) :- + pred_info_arity(PredInfo, OrigArity), + pred_info_arg_types(PredInfo, ArgTypes), + list__length(ArgTypes, CurrentArity), + ArgOffset = OrigArity - CurrentArity. + %-----------------------------------------------------------------------------% % Given a list of variables and a list of expected livenesses, @@ -1655,10 +1747,11 @@ modecheck_var_has_inst(VarId, Inst, ModeInfo0, ModeInfo) :- %-----------------------------------------------------------------------------% -modecheck_set_var_inst_list(Vars0, InitialInsts, FinalInsts, Vars, Goals) --> +modecheck_set_var_inst_list(Vars0, InitialInsts, FinalInsts, ArgOffset, + Vars, Goals) --> ( modecheck_set_var_inst_list_2(Vars0, InitialInsts, FinalInsts, - no_extra_goals, 0, Vars1, Goals1) + no_extra_goals, ArgOffset, Vars1, Goals1) -> { Vars = Vars1, Goals = Goals1 } ; @@ -1915,7 +2008,7 @@ handle_implied_mode(Var0, VarInst0, InitialInst0, Var, % Construct the code to do the unification modecheck_unify__create_var_var_unification(Var0, Var, - ModeInfo, ExtraGoal), + VarType, ModeInfo, ExtraGoal), % append the goals together in the appropriate order: % ExtraGoals0, then NewUnify diff --git a/compiler/notes/compiler_design.html b/compiler/notes/compiler_design.html index 1c3496715..8aa76c6b5 100644 --- a/compiler/notes/compiler_design.html +++ b/compiler/notes/compiler_design.html @@ -258,9 +258,30 @@ so that the compiler does the right thing for options such as 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. + +
polymorphism transformation + +
+ 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.) +

+ 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. +

+ 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.

mode analysis @@ -272,10 +293,9 @@ so that the compiler does the right thing for options such as that specifies the changes in instantiatedness of each variable over that goal.
  • 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.
  • modecheck_call.m is the sub-module which analyses calls. - It also converts function calls into predicate calls.

    @@ -354,12 +374,13 @@ so that the compiler does the right thing for options such as 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), @@ -373,17 +394,11 @@ defined in mercury_builtin.m and the addition of some scaffolding structure.

    -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):

    -

    - -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?)

    @@ -927,6 +939,6 @@ Some of them are obsolete; other are work-in-progress.

    -Last update was $Date: 1999-06-15 07:10:00 $ by $Author: petdr $@cs.mu.oz.au.
    +Last update was $Date: 1999-06-30 17:13:13 $ by $Author: fjh $@cs.mu.oz.au.
    diff --git a/compiler/pd_cost.m b/compiler/pd_cost.m index c3c84b62e..4499c2f50 100644 --- a/compiler/pd_cost.m +++ b/compiler/pd_cost.m @@ -1,5 +1,5 @@ %-----------------------------------------------------------------------------% -% Copyright (C) 1998 University of Melbourne. +% Copyright (C) 1998-1999 University of Melbourne. % This file may only be copied under the terms of the GNU General % Public License - see the file COPYING in the Mercury distribution. %-----------------------------------------------------------------------------% @@ -115,7 +115,7 @@ pd_cost__goal(pragma_c_code(Attributes, _, _, Args, _, _, _) - _, Cost) :- pd_cost__unify(_, assign(_, _), 0). -pd_cost__unify(_, complicated_unify(_, _), Cost) :- +pd_cost__unify(_, complicated_unify(_, _, _), Cost) :- pd_cost__stack_flush(Cost). pd_cost__unify(_, simple_test(_, _), Cost) :- diff --git a/compiler/polymorphism.m b/compiler/polymorphism.m index 623945a91..1cb016dfc 100644 --- a/compiler/polymorphism.m +++ b/compiler/polymorphism.m @@ -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 @@ -307,13 +307,24 @@ :- module polymorphism. :- interface. -:- import_module hlds_goal, hlds_module, hlds_pred, prog_data, special_pred. -:- import_module io, list, term. +:- import_module hlds_goal, hlds_module, hlds_pred, hlds_data. +:- import_module prog_data, special_pred. + +:- 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 +334,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. @@ -384,15 +415,25 @@ module_info, sym_name, pred_id, proc_id). :- mode polymorphism__get_special_proc(in, in, in, out, out, out) is det. + % convert a higher-order pred term to a lambda goal +:- pred convert_pred_to_lambda_goal(pred_or_func, prog_var, cons_id, sym_name, + list(prog_var), list(type), tvarset, + unification, 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, in, out, out, out) is det. + %-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------% :- implementation. -:- import_module hlds_data, llds, (lambda), prog_io. +:- import_module typecheck, 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 +441,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 +457,7 @@ polymorphism__process_module(ModuleInfo0, ModuleInfo, IO0, IO) :- 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 +465,17 @@ polymorphism__process_module(ModuleInfo0, ModuleInfo, IO0, IO) :- 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 +484,8 @@ polymorphism__process_pred(PredId, ModuleInfo0, ModuleInfo, IO0, IO) :- % 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,62 +493,42 @@ polymorphism__process_pred(PredId, ModuleInfo0, ModuleInfo, IO0, IO) :- 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), +polymorphism__no_type_info_builtin(ModuleName, PredName, Arity) :- + no_type_info_builtin_2(ModuleNameType, PredName, Arity), + check_module_name(ModuleNameType, ModuleName). -% 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, +:- type builtin_mod ---> builtin ; private_builtin. - polymorphism__process_proc(ProcId, ProcInfo0, PredInfo0, - ModuleInfo0, ProcInfo, PredInfo1, ModuleInfo1), +:- pred check_module_name(builtin_mod, module_name). +:- mode check_module_name(in, in) is semidet. - 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), +check_module_name(builtin, Module) :- + mercury_public_builtin_module(Module). +check_module_name(private_builtin, Module) :- + mercury_private_builtin_module(Module). - polymorphism__process_procs(PredId, ProcIds, ModuleInfo2, ModuleInfo, - IO1, IO). +:- pred no_type_info_builtin_2(builtin_mod, string, int). +:- mode no_type_info_builtin_2(out, in, out) is semidet. -polymorphism__no_type_info_builtin(MercuryBuiltin, "unsafe_type_cast", 2) :- - mercury_private_builtin_module(MercuryBuiltin). -polymorphism__no_type_info_builtin(MercuryBuiltin, - "unsafe_promise_unique", 2) :- - mercury_public_builtin_module(MercuryBuiltin). -polymorphism__no_type_info_builtin(MercuryBuiltin, - "superclass_from_typeclass_info", 3) :- - mercury_private_builtin_module(MercuryBuiltin). -polymorphism__no_type_info_builtin(MercuryBuiltin, - "instance_constraint_from_typeclass_info", 3) :- - mercury_private_builtin_module(MercuryBuiltin). -polymorphism__no_type_info_builtin(MercuryBuiltin, - "type_info_from_typeclass_info", 3) :- - mercury_private_builtin_module(MercuryBuiltin). +no_type_info_builtin_2(private_builtin, "unsafe_type_cast", 2). +no_type_info_builtin_2(builtin, "unsafe_promise_unique", 2). +no_type_info_builtin_2(private_builtin, "superclass_from_typeclass_info", 3). +no_type_info_builtin_2(private_builtin, + "instance_constraint_from_typeclass_info", 3). +no_type_info_builtin_2(private_builtin, "type_info_from_typeclass_info", 3). +no_type_info_builtin_2(private_builtin, "table_restore_any_ans", 3). +no_type_info_builtin_2(private_builtin, "table_lookup_insert_enum", 4). %---------------------------------------------------------------------------% @@ -521,8 +538,8 @@ polymorphism__no_type_info_builtin(MercuryBuiltin, 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 +548,208 @@ polymorphism__fixup_preds([PredId | PredIds], ModuleInfo0, ModuleInfo) :- % 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_clauses_info(PredInfo0, ClausesInfo), + clauses_info_vartypes(ClausesInfo, VarTypes), + clauses_info_headvars(ClausesInfo, HeadVars), - 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_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_pred(PredId, ModuleInfo0, ModuleInfo) --> + { module_info_pred_info(ModuleInfo0, PredId, PredInfo0) }, -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, + 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, + HeadVars0, 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(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. + +polymorphism__process_clause(PredInfo0, HeadVars0, 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(PredInfo0) } -> - 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, + PredInfo0, HeadVars0, UnconstrainedTVars, ExtraTypeInfoHeadVars, ExistTypeClassInfoHeadVars, - Goal1, Goal2, Info2, Info3), + Goal1, Goal2), - pred_info_get_exist_quant_tvars(PredInfo0, ExistQVars), + { pred_info_get_exist_quant_tvars(PredInfo0, 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) ) + -> + % + % We need to set the headvars in the proc_info here, because + % some parts of the compiler (e.g. unused_args.m) depend on the + % headvars field being valid even for imported procedures. + % + clauses_info_headvars(ClausesInfo, HeadVars), + 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 +824,7 @@ polymorphism__setup_headvars(PredInfo, ProcInfo, HeadVars, ArgModes, 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 +858,18 @@ polymorphism__setup_headvars(PredInfo, ProcInfo, HeadVars, ArgModes, % 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 +963,11 @@ polymorphism__assign_var(Var1, Var2, 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). - % 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). @@ -927,8 +998,11 @@ polymorphism__process_goal_expr(call(PredId0, ProcId0, ArgVars0, % for which the type is known at compile-time. % Replace such calls with calls to the particular version % for that type. + % (Note: higher_order.m also performs the same optimization. + % Is there really much advantage in doing it here too?) ( - { Name0 = unqualified(PredName0) }, + { Name0 = qualified(ModuleName, PredName0) }, + { mercury_public_builtin_module(ModuleName) }, { list__length(ArgVars0, Arity) }, { special_pred_name_arity(SpecialPredId, PredName0, MangledPredName, Arity) }, @@ -961,177 +1035,6 @@ polymorphism__process_goal_expr(call(PredId0, ProcId0, ArgVars0, { 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, _) } -> - - % 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) } - -> - % 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 } - ; - % ordinary unifications are left unchanged, - { Goal = unify(XVar, Y, Mode, Unification, Context) - GoalInfo } - ). - - % 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, SM), GoalInfo, - par_conj(Goals, SM) - GoalInfo) --> - polymorphism__process_goal_list(Goals0, Goals). -polymorphism__process_goal_expr(disj(Goals0, SM), GoalInfo, - disj(Goals, SM) - 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, SM), GoalInfo, - switch(Var, CanFail, Cases, SM) - GoalInfo) --> - polymorphism__process_case_list(Cases0, Cases). -polymorphism__process_goal_expr(some(Vars, Goal0), GoalInfo, - some(Vars, Goal) - GoalInfo) --> - polymorphism__process_goal(Goal0, Goal). -polymorphism__process_goal_expr(if_then_else(Vars, A0, B0, C0, SM), GoalInfo, - if_then_else(Vars, A, B, C, SM) - GoalInfo) --> - polymorphism__process_goal(A0, A), - 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) }, @@ -1171,6 +1074,522 @@ polymorphism__process_goal_expr(Goal0, GoalInfo, Goal) --> { 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, + conj(Goals) - GoalInfo) --> + polymorphism__process_goal_list(Goals0, Goals). +polymorphism__process_goal_expr(par_conj(Goals0, SM), GoalInfo, + par_conj(Goals, SM) - GoalInfo) --> + polymorphism__process_goal_list(Goals0, Goals). +polymorphism__process_goal_expr(disj(Goals0, SM), GoalInfo, + disj(Goals, SM) - 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, SM), GoalInfo, + switch(Var, CanFail, Cases, SM) - GoalInfo) --> + polymorphism__process_case_list(Cases0, Cases). +polymorphism__process_goal_expr(some(Vars, Goal0), GoalInfo, + some(Vars, Goal) - GoalInfo) --> + polymorphism__process_goal(Goal0, Goal). +polymorphism__process_goal_expr(if_then_else(Vars, A0, B0, C0, SM), GoalInfo, + if_then_else(Vars, A, B, C, SM) - GoalInfo) --> + polymorphism__process_goal(A0, A), + polymorphism__process_goal(B0, B), + polymorphism__process_goal(C0, C). + +:- 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) :- + % + % 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), + list__map(type_info_locn_var, TypeInfoLocns, TypeInfoVars0), + list__remove_dups(TypeInfoVars0, TypeInfoVars), + + % + % 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), + ( + % + % 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] + -> + % + % 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), + + /******* + % + % Currently we don't support higher-order polymorphism; + % all closures are monomorphic (any type_infos needed are + % supplied when the closure is created, not when it is called). + % Therefore we don't need to bother recursively processing + % the higher-order function call. If we were to ever add + % support for higher-order polymorphism, then we would need + % to uncomment this code. + % + polymorphism__process_goal_expr(HOCall, GoalInfo0, Goal, + PolyInfo0, PolyInfo) + ********/ + Goal = HOCall - GoalInfo0, + PolyInfo = PolyInfo0 + ; + % + % 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, _), + + % + % 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.) + % + 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 turn the lambda expression back into a + % higher-order pred constant again. + % + % Note that this transformation is also done by modecheck_unify.m, + % in case we are rerunning mode analysis after lambda.m has already + % been run; any changes to the code here will also need to be + % duplicated there. + % + + % check if variable has a higher-order type + type_is_higher_order(TypeOfX, PredOrFunc, PredArgTypes), + ConsId0 = cons(PName, _) + -> + % + % convert the higher-order pred term to a lambda goal + % + poly_info_get_varset(PolyInfo0, VarSet0), + poly_info_get_typevarset(PolyInfo0, TVarSet), + goal_info_get_context(GoalInfo0, Context), + convert_pred_to_lambda_goal(PredOrFunc, X0, ConsId0, PName, + ArgVars0, PredArgTypes, TVarSet, + Unification0, UnifyContext, GoalInfo0, Context, + ModuleInfo0, VarSet0, VarTypes0, + Functor0, VarSet, VarTypes), + poly_info_set_varset_and_types(VarSet, VarTypes, + PolyInfo0, PolyInfo1), + % + % process the unification in its new form + % + polymorphism__process_unify(X0, Functor0, Mode0, + Unification0, UnifyContext, GoalInfo0, Goal, + PolyInfo1, PolyInfo) + ; + % + % is this a construction or deconstruction of an + % existentially typed data type? + % + ConsId0 = cons(_, _), + type_util__get_existq_cons_defn(ModuleInfo0, TypeOfX, ConsId0, + ConsDefn) + -> + % + % add extra arguments to the unification for the + % type_info and/or type_class_info variables + % + map__apply_to_list(ArgVars0, VarTypes0, ActualArgTypes), + goal_info_get_context(GoalInfo0, Context), + polymorphism__process_existq_unify_functor(ConsDefn, + ActualArgTypes, TypeOfX, Context, + ExtraVars, ExtraGoals, PolyInfo0, PolyInfo), + list__append(ExtraVars, ArgVars0, ArgVars), + Unify = unify(X0, functor(ConsId0, ArgVars), Mode0, + Unification0, UnifyContext) - GoalInfo0, + list__append(ExtraGoals, [Unify], GoalList), + conj_list_to_goal(GoalList, GoalInfo0, Goal) + ; + % + % ordinary construction/deconstruction unifications + % we leave alone + % + Goal = unify(X0, functor(ConsId0, ArgVars0), Mode0, + Unification0, UnifyContext) - GoalInfo0, + PolyInfo = PolyInfo0 + ). + +convert_pred_to_lambda_goal(PredOrFunc, X0, ConsId0, PName, + ArgVars0, PredArgTypes, TVarSet, + Unification0, UnifyContext, GoalInfo0, Context, + ModuleInfo0, VarSet0, VarTypes0, + Functor, VarSet, VarTypes) :- + % + % Create the new lambda-quantified variables + % + make_fresh_vars(PredArgTypes, VarSet0, VarTypes0, + LambdaVars, VarSet, VarTypes), + list__append(ArgVars0, LambdaVars, Args), + + % + % Build up the hlds_goal_expr for the call that will form + % the lambda goal + % + map__apply_to_list(Args, VarTypes, ArgTypes), + ( + % If we are redoing mode analysis, use the + % pred_id and proc_id found before, to avoid aborting + % in get_pred_id_and_proc_id if there are multiple + % matching procedures. + Unification0 = construct(_, + pred_const(PredId0, ProcId0), _, _) + -> + PredId = PredId0, + ProcId = ProcId0 + ; + 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_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 + % + proc_info_argmodes(ProcInfo, ArgModes), + list__length(ArgModes, NumArgModes), + list__length(LambdaVars, NumLambdaVars), + ( list__drop(NumArgModes - NumLambdaVars, ArgModes, LambdaModes0) -> + LambdaModes = LambdaModes0 + ; + error("convert_pred_to_lambda_goal: 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 + % + Functor = lambda_goal(PredOrFunc, 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). + +%-----------------------------------------------------------------------------% + +% +% 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, 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, + out, out, in, out) is det. + +polymorphism__process_existq_unify_functor( + CtorDefn, ActualArgTypes, ActualRetType, Context, + ExtraVars, ExtraGoals, PolyInfo0, PolyInfo) :- + + CtorDefn = ctor_defn(CtorTypeVarSet, ExistQVars0, + ExistentialConstraints0, CtorArgTypes0, CtorRetType0), + + % + % rename apart the type variables in the constructor definition + % + poly_info_get_typevarset(PolyInfo0, TypeVarSet0), + varset__merge_subst(TypeVarSet0, CtorTypeVarSet, TypeVarSet, Subst), + term__var_list_to_term_list(ExistQVars0, ExistQVarTerms0), + term__apply_substitution_to_list(ExistQVarTerms0, Subst, + ExistQVarsTerms1), + apply_subst_to_constraint_list(Subst, ExistentialConstraints0, + ExistentialConstraints1), + term__apply_substitution_to_list(CtorArgTypes0, Subst, CtorArgTypes1), + term__apply_substitution(CtorRetType0, Subst, CtorRetType1), + poly_info_set_typevarset(TypeVarSet, PolyInfo0, PolyInfo1), + + % + % 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) -> + TypeSubst = TypeSubst1 + ; + error( + "polymorphism__process_existq_unify_functor: type unification failed") + ), + + % + % Apply those type bindings to the existential type class constraints + % + apply_rec_subst_to_constraint_list(TypeSubst, ExistentialConstraints1, + ExistentialConstraints), + + % + % create type_class_info variables for the + % type class constraints + % + + % assume it's a deconstruction + polymorphism__make_typeclass_info_head_vars( + ExistentialConstraints, + ExtraTypeClassVars, + PolyInfo1, PolyInfo2), + ExtraTypeClassGoals = [], +/******* + % assume it's a construction + polymorphism__make_typeclass_info_vars( + ExistentialConstraints, [], Context, + ExtraTypeClassVars, ExtraTypeClassGoals, + PolyInfo1, PolyInfo2), +*******/ + + polymorphism__update_typeclass_infos( + ExistentialConstraints, ExtraTypeClassVars, + PolyInfo2, PolyInfo3), + + % + % Compute the set of _unconstrained_ existentially quantified type + % variables, and then apply the type bindings to those type variables + % to figure out what types they are bound to. + % + constraint_list_get_tvars(ExistentialConstraints1, + ExistConstrainedTVars), + term__var_list_to_term_list(ExistConstrainedTVars, + ExistConstrainedTVarTerms), + list__delete_elems(ExistQVarsTerms1, ExistConstrainedTVarTerms, + UnconstrainedExistQVarTerms), + term__apply_rec_substitution_to_list(UnconstrainedExistQVarTerms, + TypeSubst, ExistentialTypes), + + % + % create type_info variables for the _unconstrained_ + % existentially quantified type variables + % + polymorphism__make_type_info_vars(ExistentialTypes, [], + Context, ExtraTypeInfoVars, ExtraTypeInfoGoals, + PolyInfo3, PolyInfo), + + % + % the type_class_info variables go before the type_info variables + % + list__append(ExtraTypeClassGoals, ExtraTypeInfoGoals, ExtraGoals), + list__append(ExtraTypeClassVars, ExtraTypeInfoVars, ExtraVars). + +%-----------------------------------------------------------------------------% :- pred polymorphism__process_c_code(pred_info, int, list(type), list(type), list(maybe(pair(string, mode))), list(maybe(pair(string, mode)))). @@ -1428,6 +1847,11 @@ polymorphism__process_call(PredId, ArgVars0, GoalInfo0, apply_rec_subst_to_constraint_list(TypeSubst, UniversalConstraints1, UniversalConstraints2), + term__apply_rec_substitution_to_list(PredExistQVarTerms1, + TypeSubst, PredExistQVarTerms), + term__term_list_to_var_list(PredExistQVarTerms, + PredExistQVars), + polymorphism__make_typeclass_info_vars( UniversalConstraints2, PredExistQVars, Context, @@ -1458,10 +1882,6 @@ polymorphism__process_call(PredId, ArgVars0, GoalInfo0, term__var_list_to_term_list(PredTypeVars, PredTypes0), term__apply_rec_substitution_to_list(PredTypes0, TypeSubst, PredTypes), - term__apply_rec_substitution_to_list(PredExistQVarTerms1, - TypeSubst, PredExistQVarTerms), - term__term_list_to_var_list(PredExistQVarTerms, - PredExistQVars), polymorphism__make_type_info_vars(PredTypes, PredExistQVars, Context, ExtraTypeInfoVars, ExtraTypeInfoGoals, @@ -1478,46 +1898,7 @@ polymorphism__process_call(PredId, ArgVars0, GoalInfo0, % 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 +1949,7 @@ constraint_get_tvars(constraint(_Name, Args), TVars) :- :- 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 +2021,6 @@ polymorphism__fixup_lambda_quantification(Goal0, ArgVars, LambdaVars, %-----------------------------------------------------------------------------% -:- 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 +2100,7 @@ polymorphism__make_typeclass_info_var(Constraint, ExistQVars, Info0 = poly_info(VarSet0, VarTypes0, TypeVarSet, TypeInfoMap0, TypeClassInfoMap0, Proofs, PredName, ModuleInfo, - Markers, Owner), + unit, unit), ( map__search(TypeClassInfoMap0, Constraint, Location) @@ -1885,7 +2220,7 @@ polymorphism__make_typeclass_info_var(Constraint, ExistQVars, 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 +2299,9 @@ polymorphism__make_typeclass_info_var(Constraint, ExistQVars, % 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, @@ -2168,40 +2502,11 @@ polymorphism__make_type_info_vars([Type | Types], ExistQVars, Context, polymorphism__make_type_info_var(Type, ExistQVars, Context, Var, ExtraGoals, Info0, Info) :- + % + % First handle statically known types + % (i.e. types which are not type variables) + % ( - % - % Check for type variables which are existentially quantified - % in the callee's type declaration. - % For these type variables, we assume that the callee will - % return the type_info. So all we need to do is to make - % a variable to hold the returned type_info, and insert - % that in the TypeInfoMap. - % - % [XXX This would need to change if we allow - % `in' modes for arguments with existential types, - % because in that case the mode for the type_info - % must also be `in', so we would need to construct it. - % The condition of the if-then-else below would - % need to be changed to fail for those cases] - % - Type = term__variable(TVar), - list__member(TVar, ExistQVars) - -> - poly_info_get_type_info_map(Info0, TypeInfoMap0), - % existentially quantified tvars in the head will already - % have a type_info var allocated for them - ( map__search(TypeInfoMap0, TVar, type_info(HeadVar)) -> - Var = HeadVar, - Info = Info0 - ; - polymorphism__new_type_info_var(Type, "type_info", - Var, Info0, Info1), - map__det_insert(TypeInfoMap0, TVar, type_info(Var), - TypeInfoMap), - poly_info_set_type_info_map(TypeInfoMap, Info1, Info) - ), - ExtraGoals = [] - ; type_is_higher_order(Type, PredOrFunc, TypeArgs) -> % This occurs for code where a predicate calls a polymorphic @@ -2230,71 +2535,34 @@ polymorphism__make_type_info_var(Type, ExistQVars, Context, Var, ExtraGoals, polymorphism__construct_type_info(Type, TypeId, TypeArgs, no, ExistQVars, Context, Var, ExtraGoals, Info0, Info) ; - Type = term__variable(TypeVar), - poly_info_get_type_info_map(Info0, TypeInfoMap0), - map__search(TypeInfoMap0, TypeVar, TypeInfoLocn) - -> - % This occurs for code where a predicate calls a polymorphic - % predicate with a bound but unknown value of the type variable. - % For example, in - % - % :- pred p(T1). - % :- pred q(T2). - % - % p(X) :- q(X). - % - % we know that `T2' is bound to `T1', and we translate it into - % - % :- pred p(TypeInfo(T1), T1). - % :- pred q(TypeInfo(T2), T2). - % - % 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) - ) - ; + % + % Now handle the cases of types which are not known statically + % (i.e. type variables) + % Type = term__variable(TypeVar) -> + poly_info_get_type_info_map(Info0, TypeInfoMap0), % - % This occurs for code where a predicate calls a polymorphic - % predicate with an unbound type variable. - % Cases where there is no producer at all for the type - % variable should get caught by post_typecheck.m. - % XXX Cases where there is a producer but it occurs - % somewhere further on in the goal should be avoided by - % mode reordering, but currently mode analysis doesn't - % do that. + % 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_typevarset(Info0, TypeVarSet), - varset__lookup_name(TypeVarSet, TypeVar, TypeVarName), - term__context_file(Context, FileName), - term__context_line(Context, LineNumber), - ( FileName = "" -> - ContextMessage = "" + ( map__search(TypeInfoMap0, TypeVar, TypeInfoLocn) -> + get_type_info(TypeInfoLocn, TypeVar, ExtraGoals, Var, + Info0, Info) ; - string__format("%s:%03d: ", - [s(FileName), i(LineNumber)], ContextMessage) - ), - poly_info_get_pred_name(Info0, PredName), - string__append_list([ - "polymorphism__make_var:\n", - ContextMessage, "In predicate `", PredName, "':\n", - ContextMessage, " unbound type variable `", - TypeVarName, "'." - ], Message), - error(Message) + % + % Otherwise, we need to create a new type_info + % variable, and set the location for this type + % variable to be that type_info variable. + % + polymorphism__new_type_info_var(Type, "type_info", + Var, Info0, Info1), + map__det_insert(TypeInfoMap0, TypeVar, type_info(Var), + TypeInfoMap), + poly_info_set_type_info_map(TypeInfoMap, Info1, Info), + ExtraGoals = [] + ) ; error("polymorphism__make_var: unknown type") ). @@ -2650,31 +2918,48 @@ polymorphism__new_type_info_var(Type, Symbol, VarSet0, VarTypes0, %---------------------------------------------------------------------------% -:- pred extract_type_info(type, 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. +% Generate code to get the value of a type variable. -extract_type_info(Type, TypeVar, TypeClassInfoVar, Index, Goals, +:- 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, 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_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 +2988,8 @@ extract_type_info_2(Type, _TypeVar, TypeClassInfoVar, Index, ModuleInfo, Goals, 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 +3292,7 @@ delete_nth([X|Xs], N0, Result) :- ). %---------------------------------------------------------------------------% +%---------------------------------------------------------------------------% :- type poly_info ---> poly_info( @@ -3039,30 +3325,49 @@ delete_nth([X|Xs], N0, Result) :- % 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 +3377,8 @@ poly_info_extract(Info, PredInfo0, PredInfo, 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,11 +3417,11 @@ poly_info_get_typeclass_info_map(PolyInfo, TypeClassInfoMap) :- 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. @@ -3122,18 +3429,6 @@ poly_info_get_pred_name(PolyInfo, PredName) :- 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. diff --git a/compiler/post_typecheck.m b/compiler/post_typecheck.m index 1c37b9f68..96d978f4f 100644 --- a/compiler/post_typecheck.m +++ b/compiler/post_typecheck.m @@ -37,18 +37,23 @@ :- module post_typecheck. :- interface. -:- import_module hlds_module, hlds_pred, io. -:- import_module list, prog_data. +:- import_module hlds_module, hlds_pred, prog_data. +:- import_module list, io, bool. + % check_type_bindings(PredId, PredInfo, ModuleInfo, ReportErrors): + % + % Check that all Aditi predicates have an `aditi__state' argument. % Check that the all of the types which have been inferred % for the variables in the clause do not contain any unbound type % variables other than those that occur in the types of head % variables, and that there are no unsatisfied type class - % constraints. + % constraints, and if ReportErrors = yes, print appropriate + % warning/error messages. + % Also bind any unbound type variables to the type `void'. % -:- pred post_typecheck__check_type_bindings(pred_id, pred_info, pred_info, - module_info, int, io__state, io__state). -:- mode post_typecheck__check_type_bindings(in, in, out, in, out, di, uo) +:- pred post_typecheck__check_type_bindings(pred_id, pred_info, module_info, + bool, pred_info, int, io__state, io__state). +:- mode post_typecheck__check_type_bindings(in, in, in, in, out, out, di, uo) is det. % Handle any unresolved overloading for a predicate call. @@ -58,9 +63,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. % @@ -93,10 +98,14 @@ % variables other than those that occur in the types of head % variables, and that there are no unsatisfied type class constraints. -post_typecheck__check_type_bindings(PredId, PredInfo0, PredInfo, ModuleInfo, - NumErrors, IOState0, IOState) :- - pred_info_get_unproven_body_constraints(PredInfo0, UnprovenConstraints0), - ( UnprovenConstraints0 \= [] -> +post_typecheck__check_type_bindings(PredId, PredInfo0, ModuleInfo, ReportErrs, + PredInfo, NumErrors, IOState0, IOState) :- + ( + ReportErrs = yes, + pred_info_get_unproven_body_constraints(PredInfo0, + UnprovenConstraints0), + UnprovenConstraints0 \= [] + -> list__sort_and_remove_dups(UnprovenConstraints0, UnprovenConstraints), report_unsatisfied_constraints(UnprovenConstraints, @@ -109,7 +118,8 @@ post_typecheck__check_type_bindings(PredId, PredInfo0, PredInfo, ModuleInfo, 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, @@ -118,18 +128,23 @@ post_typecheck__check_type_bindings(PredId, PredInfo0, PredInfo, ModuleInfo, PredInfo = PredInfo0, IOState2 = IOState1 ; - % - % report the warning - % - report_unresolved_type_warning(Errs, PredId, PredInfo0, - ModuleInfo, VarSet, IOState1, IOState2), + ( ReportErrs = yes -> + % + % report the warning + % + report_unresolved_type_warning(Errs, PredId, PredInfo0, + ModuleInfo, VarSet, IOState1, IOState2) + ; + IOState2 = IOState1 + ), % % bind all the type variables in `Set' to `void' ... % 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) ), @@ -142,7 +157,7 @@ post_typecheck__check_type_bindings(PredId, PredInfo0, PredInfo, ModuleInfo, pred_info_arg_types(PredInfo, ArgTypes), ( check_marker(Markers, aditi) -> list__filter(type_is_aditi_state, ArgTypes, AditiStateTypes), - ( AditiStateTypes = [] -> + ( AditiStateTypes = [], ReportErrs = yes -> report_no_aditi_state(PredInfo, IOState2, IOState) ; AditiStateTypes = [_, _ | _] -> report_multiple_aditi_states(PredInfo, @@ -310,7 +325,7 @@ post_typecheck__resolve_pred_overloading(PredId0, Args0, CallerPredInfo, % 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 +336,14 @@ post_typecheck__resolve_pred_overloading(PredId0, Args0, CallerPredInfo, %-----------------------------------------------------------------------------% % - % 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 +351,8 @@ post_typecheck__finish_pred(ModuleInfo, PredId, PredInfo1, PredInfo) --> % 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 diff --git a/compiler/purity.m b/compiler/purity.m index 215db6766..403d080c3 100644 --- a/compiler/purity.m +++ b/compiler/purity.m @@ -216,7 +216,7 @@ goal_info_is_impure(GoalInfo) :- % operators, and that we never need `pure' indicators/declarations. write_purity_prefix(Purity) --> - ( { Purity = pure } -> + ( { Purity = pure } -> [] ; write_purity(Purity), @@ -270,18 +270,14 @@ check_preds_purity_2([PredId | PredIds], FoundTypeError, ModuleInfo0, write_pred_progress_message("% Purity-checking ", PredId, ModuleInfo0), % - % Only check the type bindings if we didn't get any - % type errors already; this avoids a lot of spurious - % diagnostics. + % Only report error messages for unbound type variables + % if we didn't get any type errors already; this avoids + % a lot of spurious diagnostics. % - ( { FoundTypeError = no } -> - post_typecheck__check_type_bindings(PredId, PredInfo0, - PredInfo1, ModuleInfo0, - UnboundTypeErrsInThisPred) - ; - { PredInfo1 = PredInfo0 }, - { UnboundTypeErrsInThisPred = 0 } - ), + { bool__not(FoundTypeError, ReportErrs) }, + post_typecheck__check_type_bindings(PredId, PredInfo0, + ModuleInfo0, ReportErrs, + PredInfo1, UnboundTypeErrsInThisPred), puritycheck_pred(PredId, PredInfo1, PredInfo2, ModuleInfo0, PurityErrsInThisPred), post_typecheck__finish_pred(ModuleInfo0, PredId, PredInfo2, @@ -322,36 +318,36 @@ check_preds_purity_2([PredId | PredIds], FoundTypeError, ModuleInfo0, :- 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 +398,17 @@ compute_expr_purity(call(PredId0,ProcId,Vars,BIState,UContext,Name0), { 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 +433,7 @@ compute_expr_purity(Unif0, Unif, GoalInfo, PredInfo, ModuleInfo, _, 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 +613,7 @@ error_inferred_impure(ModuleInfo, PredInfo, PredId, Purity) --> 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 +656,7 @@ warn_unnecessary_body_impurity_decl(ModuleInfo, _, PredId, Context, 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 +670,7 @@ warn_unnecessary_body_impurity_decl(ModuleInfo, _, PredId, Context, :- 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 +680,7 @@ error_if_closure_impure(GoalInfo, Purity, NumErrors0, NumErrors) --> 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") ; diff --git a/compiler/quantification.m b/compiler/quantification.m index 2780aa727..1d5dc1f52 100644 --- a/compiler/quantification.m +++ b/compiler/quantification.m @@ -330,10 +330,12 @@ implicitly_quantify_goal_2( unify(Var, UnifyRHS, Mode, Unification, UnifyContext)) --> quantification__get_outside(OutsideVars), quantification__get_lambda_outside(LambdaOutsideVars), + { quantification__get_unify_typeinfos(Unification0, TypeInfoVars) }, implicitly_quantify_unify_rhs(UnifyRHS0, Unification0, Context, UnifyRHS, Unification), quantification__get_nonlocals(VarsUnifyRHS), - { set__insert(VarsUnifyRHS, Var, GoalVars) }, + { set__insert(VarsUnifyRHS, Var, GoalVars0) }, + { set__insert_list(GoalVars0, TypeInfoVars, GoalVars) }, quantification__update_seen_vars(GoalVars), { set__intersect(GoalVars, OutsideVars, NonLocalVars1) }, { set__intersect(GoalVars, LambdaOutsideVars, NonLocalVars2) }, @@ -631,10 +633,15 @@ quantification__goal_vars(Goal - _GoalInfo, Set, LambdaSet) :- set(prog_var), set(prog_var), set(prog_var)). :- mode quantification__goal_vars_2(in, in, in, out, out) is det. -quantification__goal_vars_2(unify(A, B, _, _, _), Set0, LambdaSet0, +quantification__goal_vars_2(unify(A, B, _, Unification, _), Set0, LambdaSet0, Set, LambdaSet) :- set__insert(Set0, A, Set1), - quantification__unify_rhs_vars(B, Set1, LambdaSet0, Set, LambdaSet). + ( Unification = complicated_unify(_, _, TypeInfoVars) -> + set__insert_list(Set1, TypeInfoVars, Set2) + ; + Set2 = Set1 + ), + quantification__unify_rhs_vars(B, Set2, LambdaSet0, Set, LambdaSet). quantification__goal_vars_2(higher_order_call(PredVar, ArgVars, _, _, _, _), Set0, LambdaSet, Set, LambdaSet) :- @@ -713,6 +720,16 @@ quantification__unify_rhs_vars( set__delete_list(GoalVars, LambdaVars, GoalVars1), set__union(LambdaSet0, GoalVars1, LambdaSet). +:- pred quantification__get_unify_typeinfos(unification, list(prog_var)). +:- mode quantification__get_unify_typeinfos(in, out) is det. + +quantification__get_unify_typeinfos(Unification, TypeInfoVars) :- + ( Unification = complicated_unify(_, _, TypeInfoVars0) -> + TypeInfoVars = TypeInfoVars0 + ; + TypeInfoVars = [] + ). + %-----------------------------------------------------------------------------% :- pred quantification__warn_overlapping_scope(set(prog_var), prog_context, diff --git a/compiler/rl_exprn.m b/compiler/rl_exprn.m index 3254f6e8d..87a923e78 100644 --- a/compiler/rl_exprn.m +++ b/compiler/rl_exprn.m @@ -914,7 +914,7 @@ rl_exprn__unify(deconstruct(Var, ConsId, Args, UniModes, CanFail), { 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), diff --git a/compiler/rl_key.m b/compiler/rl_key.m index fa3c1f486..cc9dc6c09 100644 --- a/compiler/rl_key.m +++ b/compiler/rl_key.m @@ -1,5 +1,5 @@ %-----------------------------------------------------------------------------% -% Copyright (C) 1998 University of Melbourne. +% Copyright (C) 1998-1999 University of Melbourne. % This file may only be copied under the terms of the GNU General % Public License - see the file COPYING in the Mercury distribution. %-----------------------------------------------------------------------------% @@ -693,7 +693,7 @@ rl_key__extract_key_range_unify(construct(Var, ConsId, Args, _)) --> 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, diff --git a/compiler/simplify.m b/compiler/simplify.m index bc2a1d16e..d05448641 100644 --- a/compiler/simplify.m +++ b/compiler/simplify.m @@ -1,5 +1,5 @@ %-----------------------------------------------------------------------------% -% Copyright (C) 1996-1998 The University of Melbourne. +% Copyright (C) 1996-1999 The University of Melbourne. % This file may only be copied under the terms of the GNU General % Public License - see the file COPYING in the Mercury distribution. %-----------------------------------------------------------------------------% @@ -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. %-----------------------------------------------------------------------------% @@ -308,7 +310,6 @@ simplify__goal(Goal0, Goal - GoalInfo, Info0, Info) :- % % if --no-fully-strict, % replace goals with determinism failure with `fail'. - % XXX we should warn about this (if the goal wasn't `fail') % Detism = failure, % ensure goal is pure or semipure @@ -317,16 +318,30 @@ simplify__goal(Goal0, Goal - GoalInfo, Info0, Info) :- ; code_aux__goal_cannot_loop(ModuleInfo, Goal0) ) -> + % warn about this, unless the goal was an explicit + % `fail', or some goal containing `fail'. + + goal_info_get_context(GoalInfo0, Context), + ( + simplify_do_warn(Info0), + \+ (goal_contains_goal(Goal0, SubGoal), + SubGoal = disj([], _) - _) + -> + simplify_info_add_msg(Info0, + goal_cannot_succeed(Context), Info1) + ; + Info1 = Info0 + ), + % If the goal had any non-locals we should requantify. goal_info_get_nonlocals(GoalInfo0, NonLocals0), ( set__empty(NonLocals0) -> - Info1 = Info0 + Info2 = Info1 ; - simplify_info_set_requantify(Info0, Info1) + simplify_info_set_requantify(Info1, Info2) ), pd_cost__goal(Goal0, CostDelta), - simplify_info_incr_cost_delta(Info1, CostDelta, Info2), - goal_info_get_context(GoalInfo0, Context), + simplify_info_incr_cost_delta(Info2, CostDelta, Info3), fail_goal(Context, Goal1) ; % @@ -337,16 +352,7 @@ simplify__goal(Goal0, Goal - GoalInfo, Info0, Info) :- % since these may occur in conjunctions where there % are no producers for some variables, and the % 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), @@ -360,27 +366,63 @@ simplify__goal(Goal0, Goal - GoalInfo, Info0, Info) :- ; code_aux__goal_cannot_loop(ModuleInfo, Goal0) ) -> +/****************** +The following warning is disabled, because it often results in spurious +warnings. Sometimes predicate calls are used just to constrain the types, +to avoid type ambiguities or unbound type variables, and in such cases, +it is perfectly legitimate for a call to be det and to have no outputs. +There's no simple way of telling those cases from cases for which we +really ought to warn. + % warn about this, if the goal wasn't `true', wasn't `!', + % and wasn't a deconstruction unification. + % We don't warn about deconstruction unifications + % with no outputs that always succeed, because that + % would result in bogus warnings, since switch detection + % converts deconstruction unifications that can fail + % into ones that always succeed by moving the test into + % the switch. + % We also don't warn about conjunctions or existential + % quantifications, because it seems that warnings in those + % cases are usually spurious. + ( + simplify_do_warn(Info0), + % Goal0 \= conj([]) - _, + \+ (Goal0 = call(_, _, _, _, _, SymName) - _, + unqualify_name(SymName, "!")), + Goal0 \= conj(_) - _, + Goal0 \= some(_, _) - _, + \+ (Goal0 = unify(_, _, _, Unification, _) - _, + Unification = deconstruct(_, _, _, _, _)) + -> + simplify_info_add_msg(Info0, + det_goal_has_no_outputs(Context), Info1) + ; + Info1 = Info0 + ), +******************/ + Info0 = Info1, + % If the goal had any non-locals we should requantify. goal_info_get_nonlocals(GoalInfo0, NonLocals0), ( set__empty(NonLocals0) -> - Info1 = Info0 + Info2 = Info1 ; - simplify_info_set_requantify(Info0, Info1) + simplify_info_set_requantify(Info1, Info2) ), pd_cost__goal(Goal0, CostDelta), - simplify_info_incr_cost_delta(Info1, CostDelta, Info2), + simplify_info_incr_cost_delta(Info2, CostDelta, Info3), goal_info_get_context(GoalInfo0, Context), true_goal(Context, Goal1) ; Goal1 = Goal0, - Info2 = Info0 + Info3 = Info0 ), - simplify_info_maybe_clear_structs(before, Goal1, Info2, Info3), + simplify_info_maybe_clear_structs(before, Goal1, Info3, Info4), Goal1 = GoalExpr1 - GoalInfo1, - simplify__goal_2(GoalExpr1, GoalInfo1, Goal, GoalInfo2, Info3, Info4), + simplify__goal_2(GoalExpr1, GoalInfo1, Goal, GoalInfo2, Info4, Info5), simplify_info_maybe_clear_structs(after, Goal - GoalInfo2, - Info4, Info5), - simplify__enforce_invariant(GoalInfo2, GoalInfo, Info5, Info). + Info5, Info6), + simplify__enforce_invariant(GoalInfo2, GoalInfo, Info6, Info). :- pred simplify__enforce_invariant(hlds_goal_info, hlds_goal_info, simplify_info, simplify_info). @@ -775,6 +817,18 @@ simplify__goal_2(Goal0, GoalInfo0, Goal, GoalInfo, Info0, Info) :- simplify_info_leave_lambda(Info6, Info), 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) -> @@ -997,6 +1051,222 @@ simplify__goal_2(Goal0, GoalInfo, Goal, GoalInfo, Info0, Info) :- Goal = Goal0 ). +%-----------------------------------------------------------------------------% + +:- 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) --> + =(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. + % + + % generate code to construct the new type_info arguments + simplify__make_type_info_vars(TypeArgs, TypeInfoVars, + ExtraGoals), + + % create the new call goal + { list__append(TypeInfoVars, [XVar, YVar], ArgVars) }, + { 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) }, + + % add the extra type_info vars to the nonlocals for the call + { goal_info_get_nonlocals(GoalInfo0, NonLocals0) }, + { set__insert_list(NonLocals0, TypeInfoVars, NonLocals) }, + { goal_info_set_nonlocals(GoalInfo0, NonLocals, + CallGoalInfo0) }, + + % recursively simplify the call goal + simplify__goal_2(Call0, CallGoalInfo0, Call1, CallGoalInfo1), + { Call = Call1 - CallGoalInfo1 } + ; + { 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, @@ -1729,6 +1999,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. @@ -1801,3 +2083,35 @@ simplify_info_undo_goal_updates(Info1, Info2, Info) :- simplify_info_set_common_info(Info2, CommonInfo0, Info3), simplify_info_get_instmap(Info1, InstMap), simplify_info_set_instmap(Info3, InstMap, Info). + +%-----------------------------------------------------------------------------% + +:- pred goal_contains_goal(hlds_goal, hlds_goal). +:- mode goal_contains_goal(in, out) is multi. + +goal_contains_goal(Goal, Goal). +goal_contains_goal(Goal - _, SubGoal) :- + direct_subgoal(Goal, DirectSubGoal), + goal_contains_goal(DirectSubGoal, SubGoal). + +:- pred direct_subgoal(hlds_goal_expr, hlds_goal). +:- mode direct_subgoal(in, out) is nondet. + +direct_subgoal(some(_, Goal), Goal). +direct_subgoal(not(Goal), Goal). +direct_subgoal(if_then_else(_, If, Then, Else, _), Goal) :- + ( Goal = If + ; Goal = Then + ; Goal = Else + ). +direct_subgoal(conj(ConjList), Goal) :- + list__member(Goal, ConjList). +direct_subgoal(par_conj(ConjList, _), Goal) :- + list__member(Goal, ConjList). +direct_subgoal(disj(DisjList, _), Goal) :- + list__member(Goal, DisjList). +direct_subgoal(switch(_, _, CaseList, _), Goal) :- + list__member(Case, CaseList), + Case = case(_, Goal). + +%-----------------------------------------------------------------------------% diff --git a/compiler/table_gen.m b/compiler/table_gen.m index 3d1dce341..8a82831fe 100644 --- a/compiler/table_gen.m +++ b/compiler/table_gen.m @@ -170,11 +170,12 @@ :- implementation. :- import_module hlds_out, prog_out. -:- import_module hlds_pred, instmap. +:- import_module hlds_pred, instmap, polymorphism. :- import_module code_aux, det_analysis, follow_code, goal_util, const_prop. :- import_module hlds_module, hlds_goal, hlds_data, (inst), inst_match. :- import_module globals, options, passes_aux, prog_data, mode_util, type_util. :- import_module code_util, quantification, modes, purity, prog_util. + :- import_module term, varset. :- import_module bool, list, set, map, require, std_util, int. :- import_module assoc_list, string, llds. @@ -237,7 +238,7 @@ table_gen__process_procs(PredId, [ProcId | ProcIds], Module0, table_gen__process_procs(PredId, ProcIds, Module2, Module). -%---------------------------------------------------------------------------% +%-----------------------------------------------------------------------------% :- pred table_gen__process_proc(eval_method, pred_id, proc_id, proc_info, pred_info, module_info, module_info). @@ -245,6 +246,8 @@ table_gen__process_procs(PredId, [ProcId | ProcIds], Module0, table_gen__process_proc(EvalMethod, PredId, ProcId, ProcInfo0, PredInfo0, Module0, Module) :- + table_info_init(Module0, PredInfo0, ProcInfo0, TableInfo0), + % grab the appropriate fields from the pred_info and proc_info proc_info_interface_code_model(ProcInfo0, CodeModel), proc_info_headvars(ProcInfo0, HeadVars), @@ -256,65 +259,71 @@ table_gen__process_proc(EvalMethod, PredId, ProcId, ProcInfo0, PredInfo0, ( CodeModel = model_det, table_gen__create_new_det_goal(EvalMethod, OrigGoal, - PredId, ProcId, PredInfo0, Module0, - HeadVars, ArgModes, VarTypes0, - VarTypes, VarSet0, VarSet, Goal) + PredId, ProcId, HeadVars, ArgModes, + VarTypes0, VarTypes, VarSet0, VarSet, + TableInfo0, TableInfo, Goal) ; CodeModel = model_semi, table_gen__create_new_semi_goal(EvalMethod, OrigGoal, - PredId, ProcId, PredInfo0, Module0, - HeadVars, ArgModes, VarTypes0, - VarTypes, VarSet0, VarSet, Goal) + PredId, ProcId, HeadVars, ArgModes, + VarTypes0, VarTypes, VarSet0, VarSet, + TableInfo0, TableInfo, Goal) ; CodeModel = model_non, table_gen__create_new_non_goal(EvalMethod, OrigGoal, - PredId, ProcId, PredInfo0, Module0, - HeadVars, ArgModes, VarTypes0, - VarTypes, VarSet0, VarSet, Goal) + PredId, ProcId, HeadVars, ArgModes, + VarTypes0, VarTypes, VarSet0, VarSet, + TableInfo0, TableInfo, Goal) ), + table_info_extract(TableInfo, Module1, PredInfo1, ProcInfo1), + % set the new values of the fields in proc_info and pred_info % and save in the module info - proc_info_set_goal(ProcInfo0, Goal, ProcInfo1), - proc_info_set_varset(ProcInfo1, VarSet, ProcInfo2), - proc_info_set_vartypes(ProcInfo2, VarTypes, ProcInfo), + proc_info_set_goal(ProcInfo1, Goal, ProcInfo2), + proc_info_set_varset(ProcInfo2, VarSet, ProcInfo3), + proc_info_set_vartypes(ProcInfo3, VarTypes, ProcInfo), - pred_info_procedures(PredInfo0, ProcTable1), + pred_info_procedures(PredInfo1, ProcTable1), map__det_update(ProcTable1, ProcId, ProcInfo, ProcTable), - pred_info_set_procedures(PredInfo0, ProcTable, PredInfo), - module_info_preds(Module0, PredTable0), - map__det_update(PredTable0, PredId, PredInfo, PredTable), - module_info_set_preds(Module0, PredTable, Module). + pred_info_set_procedures(PredInfo1, ProcTable, PredInfo), + module_info_preds(Module1, PredTable1), + map__det_update(PredTable1, PredId, PredInfo, PredTable), + module_info_set_preds(Module1, PredTable, Module). -%------------------------------------------------------------------------------% +%-----------------------------------------------------------------------------% % % Transform deterministic procedures. % :- pred table_gen__create_new_det_goal(eval_method, hlds_goal, - pred_id, proc_id, pred_info, module_info, list(prog_var), list(mode), + pred_id, proc_id, list(prog_var), list(mode), map(prog_var, type), map(prog_var, type), prog_varset, prog_varset, - hlds_goal). -:- mode table_gen__create_new_det_goal(in, in, in, in, in, in, in, in, - in, out, in, out, out) is det. + table_info, table_info, hlds_goal). +:- mode table_gen__create_new_det_goal(in, in, in, in, in, in, + in, out, in, out, in, out, out) is det. table_gen__create_new_det_goal(EvalMethod, OrigGoal, PredId, ProcId, - PredInfo, Module, HeadVars, HeadVarModes, - VarTypes0, VarTypes, VarSet0, VarSet, Goal) :- + HeadVars, HeadVarModes, + VarTypes0, VarTypes, VarSet0, VarSet, TableInfo0, TableInfo, + Goal) :- + table_info_get_module_info(TableInfo0, Module), + get_input_output_vars(HeadVars, HeadVarModes, Module, InputVars, OutputVars), - generate_det_lookup_goal(InputVars, Module, PredId, ProcId, - VarTypes0, VarTypes1, VarSet0, VarSet1, TableVar, LookUpGoal), + generate_det_lookup_goal(InputVars, PredId, ProcId, + VarTypes0, VarTypes1, VarSet0, VarSet1, TableInfo0, TableInfo1, + TableVar, LookUpGoal), generate_call("table_simple_is_complete", [TableVar], semidet, semipure, [], Module, CompleteCheckGoal), generate_save_goal(OutputVars, TableVar, VarTypes1, VarTypes2, - VarSet1, VarSet2, Module, SaveAnsGoal0), + VarSet1, VarSet2, TableInfo1, TableInfo, SaveAnsGoal0), generate_restore_goal(OutputVars, TableVar, Module, VarTypes2, VarTypes3, VarSet2, VarSet3, RestoreAnsGoal), generate_call("table_simple_mark_as_inactive", [TableVar], det, impure, [], Module, MarkAsInactiveGoal), - generate_loop_error_goal(PredInfo, Module, VarTypes3, VarTypes, + generate_loop_error_goal(TableInfo, VarTypes3, VarTypes, VarSet3, VarSet, LoopErrorGoal), OrigGoal = _ - OrigGoalInfo, @@ -373,33 +382,36 @@ table_gen__create_new_det_goal(EvalMethod, OrigGoal, PredId, ProcId, Goal = GoalEx - GoalInfo. -%------------------------------------------------------------------------------% +%-----------------------------------------------------------------------------% % % Transform semi deterministic procedures % :- pred table_gen__create_new_semi_goal(eval_method, hlds_goal, - pred_id, proc_id, pred_info, module_info, list(prog_var), list(mode), + pred_id, proc_id, list(prog_var), list(mode), map(prog_var, type), map(prog_var, type), prog_varset, prog_varset, - hlds_goal). -:- mode table_gen__create_new_semi_goal(in, in, in, in, in, in, in, in, - in, out, in, out, out) is det. + table_info, table_info, hlds_goal). +:- mode table_gen__create_new_semi_goal(in, in, in, in, in, in, + in, out, in, out, in, out, out) is det. table_gen__create_new_semi_goal(EvalMethod, OrigGoal, PredId, ProcId, - PredInfo, Module, HeadVars, HeadVarModes, - VarTypes0, VarTypes, VarSet0, VarSet, Goal) :- + HeadVars, HeadVarModes, + VarTypes0, VarTypes, VarSet0, VarSet, TableInfo0, TableInfo, + Goal) :- + table_info_get_module_info(TableInfo0, Module), get_input_output_vars(HeadVars, HeadVarModes, Module, InputVars, OutputVars), - generate_det_lookup_goal(InputVars, Module, PredId, ProcId, - VarTypes0, VarTypes1, VarSet0, VarSet1, TableVar, LookUpGoal), + generate_det_lookup_goal(InputVars, PredId, ProcId, + VarTypes0, VarTypes1, VarSet0, VarSet1, TableInfo0, TableInfo1, + TableVar, LookUpGoal), generate_call("table_simple_is_complete", [TableVar], semidet, semipure, [], Module, CompleteCheckGoal), generate_save_goal(OutputVars, TableVar, VarTypes1, VarTypes2, - VarSet1, VarSet2, Module, SaveAnsGoal0), + VarSet1, VarSet2, TableInfo1, TableInfo, SaveAnsGoal0), generate_restore_goal(OutputVars, TableVar, Module, VarTypes2, VarTypes3, VarSet2, VarSet3, RestoreTrueAnsGoal), - generate_loop_error_goal(PredInfo, Module, VarTypes3, VarTypes, + generate_loop_error_goal(TableInfo, VarTypes3, VarTypes, VarSet3, VarSet, LoopErrorGoal), generate_call("table_simple_mark_as_failed", [TableVar], failure, impure, [], Module, MarkAsFailedGoal), @@ -516,37 +528,40 @@ table_gen__create_new_semi_goal(EvalMethod, OrigGoal, PredId, ProcId, Goal = GoalEx - GoalInfo. -%------------------------------------------------------------------------------% +%-----------------------------------------------------------------------------% % % Transform non deterministic procedures % :- pred table_gen__create_new_non_goal(eval_method, hlds_goal, - pred_id, proc_id, pred_info, module_info, list(prog_var), list(mode), + pred_id, proc_id, list(prog_var), list(mode), map(prog_var, type), map(prog_var, type), prog_varset, prog_varset, - hlds_goal). -:- mode table_gen__create_new_non_goal(in, in, in, in, in, in, in, in, - in, out, in, out, out) is det. + table_info, table_info, hlds_goal). +:- mode table_gen__create_new_non_goal(in, in, in, in, in, in, + in, out, in, out, in, out, out) is det. table_gen__create_new_non_goal(EvalMethod, OrigGoal, PredId, ProcId, - PredInfo, Module, HeadVars, HeadVarModes, - VarTypes0, VarTypes, VarSet0, VarSet, Goal) :- + HeadVars, HeadVarModes, + VarTypes0, VarTypes, VarSet0, VarSet, TableInfo0, TableInfo, + Goal) :- + table_info_get_module_info(TableInfo0, Module), get_input_output_vars(HeadVars, HeadVarModes, Module, InputVars, OutputVars), - generate_non_lookup_goal(InputVars, Module, PredId, ProcId, - VarTypes0, VarTypes1, VarSet0, VarSet1, TableVar, LookUpGoal), + generate_non_lookup_goal(InputVars, PredId, ProcId, + VarTypes0, VarTypes1, VarSet0, VarSet1, TableInfo0, TableInfo1, + TableVar, LookUpGoal), generate_call("table_nondet_is_complete", [TableVar], semidet, semipure, [], Module, CompleteCheckGoal), generate_non_save_goal(OutputVars, TableVar, VarTypes1, VarTypes2, - VarSet1, VarSet2, Module, SaveAnsGoal0), + VarSet1, VarSet2, TableInfo1, TableInfo, SaveAnsGoal0), generate_restore_all_goal(OutputVars, TableVar, Module, VarTypes2, VarTypes3, VarSet2, VarSet3, RestoreAllAnsGoal), generate_call("table_nondet_is_active", [TableVar], semidet, semipure, [], Module, IsActiveCheckGoal), generate_suspend_goal(OutputVars, TableVar, Module, VarTypes3, VarTypes4, VarSet3, VarSet4, SuspendGoal), - generate_loop_error_goal(PredInfo, Module, VarTypes4, VarTypes, + generate_loop_error_goal(TableInfo, VarTypes4, VarTypes, VarSet4, VarSet, LoopErrorGoal), generate_call("table_nondet_mark_as_active", [TableVar], det, impure, [], Module, MarkAsActiveGoal), @@ -620,7 +635,7 @@ table_gen__create_new_non_goal(EvalMethod, OrigGoal, PredId, ProcId, Goal = GoalEx - GoalInfo. -%------------------------------------------------------------------------------% +%-----------------------------------------------------------------------------% :- pred generate_get_table_goal(map(prog_var, type), map(prog_var, type), prog_varset, prog_varset, pred_id, proc_id, prog_var, hlds_goal). @@ -646,21 +661,23 @@ generate_get_table_goal(VarTypes0, VarTypes, VarSet0, VarSet, goal_info_add_feature(GoalInfo0, impure, GoalInfo), Goal = GoalExpr - GoalInfo. -%------------------------------------------------------------------------------% +%-----------------------------------------------------------------------------% -:- pred generate_det_lookup_goal(list(prog_var), module_info, pred_id, proc_id, - map(prog_var, type), map(prog_var, type), prog_varset, - prog_varset, prog_var, hlds_goal). -:- mode generate_det_lookup_goal(in, in, in, in, in, out, in, out, out, out) - is det. +:- pred generate_det_lookup_goal(list(prog_var), pred_id, proc_id, + map(prog_var, type), map(prog_var, type), + prog_varset, prog_varset, table_info, table_info, + prog_var, hlds_goal). +:- mode generate_det_lookup_goal(in, in, in, in, out, in, out, in, out, + out, out) is det. -generate_det_lookup_goal(Vars, Module, PredId, ProcId, VarTypes0, VarTypes, - VarSet0, VarSet, TableVar, Goal) :- +generate_det_lookup_goal(Vars, PredId, ProcId, VarTypes0, VarTypes, + VarSet0, VarSet, TableInfo0, TableInfo, TableVar, Goal) :- generate_get_table_goal(VarTypes0, VarTypes1, VarSet0, VarSet1, PredId, ProcId, PredTableVar, GetTableGoal), - generate_lookup_goals(Vars, PredTableVar, TableVar, Module, - VarTypes1, VarTypes, VarSet1, VarSet, LookupGoals), + generate_lookup_goals(Vars, PredTableVar, TableVar, + VarTypes1, VarTypes, VarSet1, VarSet, TableInfo0, TableInfo, + LookupGoals), GoalEx = conj([GetTableGoal | LookupGoals]), set__singleton_set(NonLocals0, TableVar), @@ -669,19 +686,22 @@ generate_det_lookup_goal(Vars, Module, PredId, ProcId, VarTypes0, VarTypes, goal_info_init(NonLocals, InstMapDelta, det, GoalInfo), Goal = GoalEx - GoalInfo. -:- pred generate_non_lookup_goal(list(prog_var), module_info, pred_id, proc_id, - map(prog_var, type), map(prog_var, type), prog_varset, - prog_varset, prog_var, hlds_goal). -:- mode generate_non_lookup_goal(in, in, in, in, in, out, in, out, out, out) - is det. +:- pred generate_non_lookup_goal(list(prog_var), pred_id, proc_id, + map(prog_var, type), map(prog_var, type), + prog_varset, prog_varset, table_info, table_info, + prog_var, hlds_goal). +:- mode generate_non_lookup_goal(in, in, in, in, out, in, out, in, out, + out, out) is det. -generate_non_lookup_goal(Vars, Module, PredId, ProcId, VarTypes0, VarTypes, - VarSet0, VarSet, SubgoalVar, Goal) :- +generate_non_lookup_goal(Vars, PredId, ProcId, VarTypes0, VarTypes, + VarSet0, VarSet, TableInfo0, TableInfo, SubgoalVar, Goal) :- + table_info_get_module_info(TableInfo0, Module), generate_get_table_goal(VarTypes0, VarTypes1, VarSet0, VarSet1, PredId, ProcId, PredTableVar, GetTableGoal), - generate_lookup_goals(Vars, PredTableVar, TableNodeVar, Module, - VarTypes1, VarTypes2, VarSet1, VarSet2, LookupGoals), + generate_lookup_goals(Vars, PredTableVar, TableNodeVar, + VarTypes1, VarTypes2, VarSet1, VarSet2, TableInfo0, TableInfo, + LookupGoals), generate_new_table_var("SubgoalVar", VarTypes2, VarTypes, VarSet2, VarSet, SubgoalVar), generate_call("table_nondet_setup", [TableNodeVar, SubgoalVar], @@ -697,35 +717,41 @@ generate_non_lookup_goal(Vars, Module, PredId, ProcId, VarTypes0, VarTypes, goal_info_init(NonLocals, InstMapDelta, det, GoalInfo), Goal = GoalEx - GoalInfo. -:- pred generate_lookup_goals(list(prog_var), prog_var, prog_var, module_info, - map(prog_var, type), map(prog_var, type), prog_varset, - prog_varset, list(hlds_goal)). -:- mode generate_lookup_goals(in, in, out, in, in, out, in, out, out) is det. +:- pred generate_lookup_goals(list(prog_var), prog_var, prog_var, + map(prog_var, type), map(prog_var, type), + prog_varset, prog_varset, table_info, table_info, + list(hlds_goal)). +:- mode generate_lookup_goals(in, in, out, in, out, in, out, in, out, out) + is det. -generate_lookup_goals([], TableVar, TableVar, _, VarTypes, VarTypes, VarSet, - VarSet, []). -generate_lookup_goals([Var|Rest], TableVar0, TableVar, Module, VarTypes0, - VarTypes, VarSet0, VarSet, [Goal|RestGoals]) :- +generate_lookup_goals([], TableVar, TableVar, + VarTypes, VarTypes, VarSet, VarSet, TableInfo, TableInfo, []). +generate_lookup_goals([Var|Rest], TableVar0, TableVar, + VarTypes0, VarTypes, VarSet0, VarSet, TableInfo0, TableInfo, + [Goal|RestGoals]) :- + table_info_get_module_info(TableInfo0, Module), map__lookup(VarTypes0, Var, VarType), - classify_type(VarType, Module, TypeCat), gen_lookup_call_for_type(TypeCat, VarType, TableVar0, Var, - Module, VarTypes0, VarTypes1, VarSet0, VarSet1, TableVar1, - Goal), - generate_lookup_goals(Rest, TableVar1, TableVar, Module, - VarTypes1, VarTypes, VarSet1, VarSet, RestGoals). + VarTypes0, VarTypes1, VarSet0, VarSet1, TableInfo0, TableInfo1, + TableVar1, Goal), + generate_lookup_goals(Rest, TableVar1, TableVar, + VarTypes1, VarTypes, VarSet1, VarSet, TableInfo1, TableInfo, + RestGoals). :- pred gen_lookup_call_for_type(builtin_type, type, prog_var, prog_var, - module_info, map(prog_var, type), map(prog_var, type), - prog_varset, prog_varset, prog_var, hlds_goal). -:- mode gen_lookup_call_for_type(in, in, in, in, in, in, out, in, - out, out, out) is det. + map(prog_var, type), map(prog_var, type), + prog_varset, prog_varset, table_info, table_info, + prog_var, hlds_goal). +:- mode gen_lookup_call_for_type(in, in, in, in, in, out, in, out, in, out, + out, out) is det. -gen_lookup_call_for_type(TypeCat, Type, TableVar, ArgVar, Module, VarTypes0, - VarTypes, VarSet0, VarSet, NextTableVar, Goal) :- - ( - TypeCat = enum_type - -> +gen_lookup_call_for_type(TypeCat, Type, TableVar, ArgVar, + VarTypes0, VarTypes, VarSet0, VarSet, TableInfo0, TableInfo, + NextTableVar, Goal) :- + table_info_get_module_info(TableInfo0, Module), + + ( TypeCat = enum_type -> ( type_to_type_id(Type, TypeId, _) -> @@ -757,48 +783,60 @@ gen_lookup_call_for_type(TypeCat, Type, TableVar, ArgVar, Module, VarTypes0, NonLocals), instmap_delta_from_assoc_list([], InstMapDelta), goal_info_init(NonLocals, InstMapDelta, det, GoalInfo), - Goal = conj([RangeUnifyGoal, LookupGoal]) - GoalInfo + Goal = conj([RangeUnifyGoal, LookupGoal]) - GoalInfo, + TableInfo = TableInfo0 ; error("gen_lookup: unexpected type") ) ; + generate_new_table_var("TableNodeVar", VarTypes0, + VarTypes1, VarSet0, VarSet1, NextTableVar), + InstMapAL = [NextTableVar - ground(unique, no)], ( - ( - TypeCat = pred_type - ; - TypeCat = polymorphic_type - ; - TypeCat = user_type + ( TypeCat = pred_type + ; TypeCat = polymorphic_type + ; TypeCat = user_type ) -> - ( - term__vars(Type, []) - -> + ( type_util__vars(Type, []) -> LookupPredName = "table_lookup_insert_user" ; LookupPredName = "table_lookup_insert_poly" - ) + ), + make_type_info_var(Type, TypeInfoVar, ExtraGoals, + VarTypes1, VarTypes, VarSet1, VarSet, + TableInfo0, TableInfo), + + generate_call(LookupPredName, + [TypeInfoVar, TableVar, ArgVar, NextTableVar], + det, impure, InstMapAL, Module, CallGoal), + + list__append(ExtraGoals, [CallGoal], ConjList), + CallGoal = _ - GoalInfo, + conj_list_to_goal(ConjList, GoalInfo, Goal) ; builtin_type_to_string(TypeCat, CatString), string__append("table_lookup_insert_", CatString, - LookupPredName) - ), - generate_new_table_var("TableNodeVar", VarTypes0, VarTypes, - VarSet0, VarSet, NextTableVar), - generate_call(LookupPredName, [TableVar, ArgVar, NextTableVar], - det, impure, [NextTableVar - ground(unique, no)], - Module, Goal) + LookupPredName), + generate_call(LookupPredName, + [TableVar, ArgVar, NextTableVar], + det, impure, InstMapAL, Module, Goal), + VarTypes = VarTypes1, + VarSet = VarSet1, + TableInfo = TableInfo0 + ) ). -%------------------------------------------------------------------------------% +%-----------------------------------------------------------------------------% :- pred generate_save_goal(list(prog_var), prog_var, map(prog_var, type), map(prog_var, type), prog_varset, prog_varset, - module_info, hlds_goal). -:- mode generate_save_goal(in, in, in, out, in, out, in, out) is det. + table_info, table_info, hlds_goal). +:- mode generate_save_goal(in, in, in, out, in, out, in, out, out) is det. -generate_save_goal(AnsList, TableVar, VarTypes0, VarTypes, VarSet0, - VarSet, Module, Goal) :- +generate_save_goal(AnsList, TableVar, VarTypes0, VarTypes, VarSet0, VarSet, + TableInfo0, TableInfo, Goal) :- + table_info_get_module_info(TableInfo0, Module), list__length(AnsList, NumAnsVars), ( @@ -816,8 +854,9 @@ generate_save_goal(AnsList, TableVar, VarTypes0, VarTypes, VarSet0, [AnsTableVar - ground(unique, no)], Module, CreateAnsBlockGoal), - generate_save_goals(AnsList, AnsTableVar, 0, Module, - VarTypes2, VarTypes, VarSet2, VarSet, SaveGoals), + generate_save_goals(AnsList, AnsTableVar, 0, + VarTypes2, VarTypes, VarSet2, VarSet, + TableInfo0, TableInfo, SaveGoals), GoalEx = conj([NumAnsVarsUnifyGoal, CreateAnsBlockGoal | SaveGoals]), @@ -832,24 +871,27 @@ generate_save_goal(AnsList, TableVar, VarTypes0, VarTypes, VarSet0, VarTypes = VarTypes0, VarSet = VarSet0, generate_call("table_mark_as_succeeded", [TableVar], det, - impure, [], Module, Goal) + impure, [], Module, Goal), + TableInfo = TableInfo0 ). :- pred generate_non_save_goal(list(prog_var), prog_var, map(prog_var, type), map(prog_var, type), prog_varset, prog_varset, - module_info, hlds_goal). -:- mode generate_non_save_goal(in, in, in, out, in, out, in, out) is det. + table_info, table_info, hlds_goal). +:- mode generate_non_save_goal(in, in, in, out, in, out, in, out, out) is det. generate_non_save_goal(AnsList, TableVar, VarTypes0, VarTypes, - VarSet0, VarSet, Module, Goal) :- + VarSet0, VarSet, TableInfo0, TableInfo, Goal) :- + table_info_get_module_info(TableInfo0, Module), generate_new_table_var("AnswerTableVar", VarTypes0, VarTypes1, VarSet0, VarSet1, AnsTableVar0), generate_call("table_nondet_get_ans_table", [TableVar, AnsTableVar0], det, impure, [AnsTableVar0 - ground(unique, no)], Module, GetAnsTableGoal), - generate_lookup_goals(AnsList, AnsTableVar0, AnsTableVar1, Module, - VarTypes1, VarTypes2, VarSet1, VarSet2, LookupAnsGoals), + generate_lookup_goals(AnsList, AnsTableVar0, AnsTableVar1, + VarTypes1, VarTypes2, VarSet1, VarSet2, TableInfo0, TableInfo1, + LookupAnsGoals), generate_call("table_nondet_answer_is_not_duplicate", [AnsTableVar1], semidet, impure, [], Module, DuplicateCheckGoal), @@ -869,8 +911,8 @@ generate_non_save_goal(AnsList, TableVar, VarTypes0, VarTypes, [AnsBlockVar - ground(unique, no)], Module, CreateAnsBlockGoal), - generate_save_goals(AnsList, AnsBlockVar, 0, Module, VarTypes5, - VarTypes, VarSet5, VarSet, SaveGoals), + generate_save_goals(AnsList, AnsBlockVar, 0, VarTypes5, + VarTypes, VarSet5, VarSet, TableInfo1, TableInfo, SaveGoals), list__append([GetAnsTableGoal | LookupAnsGoals], [DuplicateCheckGoal, NewAnsSlotGoal, NumAnsVarsUnifyGoal, @@ -884,49 +926,73 @@ generate_non_save_goal(AnsList, TableVar, VarTypes0, VarTypes, goal_info_init(NonLocals, InstMapDelta, semidet, GoalInfo), Goal = GoalEx - GoalInfo. -:- pred generate_save_goals(list(prog_var), prog_var, int, module_info, - map(prog_var, type), map(prog_var, type), prog_varset, - prog_varset, list(hlds_goal)). -:- mode generate_save_goals(in, in, in, in, in, out, in, out, out) is det. +:- pred generate_save_goals(list(prog_var), prog_var, int, + map(prog_var, type), map(prog_var, type), + prog_varset, prog_varset, table_info, table_info, + list(hlds_goal)). +:- mode generate_save_goals(in, in, in, in, out, in, out, in, out, out) is det. -generate_save_goals([], _TableVar, _Offset, _Module, VarTypes, VarTypes, - VarSet, VarSet, []). -generate_save_goals([Var|Rest], TableVar, Offset0, Module, VarTypes0, - VarTypes, VarSet0, VarSet, [OffsetUnifyGoal, - CallGoal|RestGoals]) :- +generate_save_goals([], _TableVar, _Offset, + VarTypes, VarTypes, VarSet, VarSet, TableInfo, TableInfo, []). +generate_save_goals([Var|Rest], TableVar, Offset0, + VarTypes0, VarTypes, VarSet0, VarSet, TableInfo0, TableInfo, + Goals) :- gen_int_construction("OffsetVar", Offset0, VarTypes0, VarTypes1, VarSet0, VarSet1, OffsetVar, OffsetUnifyGoal), + table_info_get_module_info(TableInfo0, Module), map__lookup(VarTypes1, Var, VarType), classify_type(VarType, Module, TypeCat), gen_save_call_for_type(TypeCat, VarType, TableVar, Var, OffsetVar, - Module, CallGoal), + VarTypes1, VarTypes2, VarSet1, VarSet2, TableInfo0, TableInfo1, + CallGoal), Offset is Offset0 + 1, - generate_save_goals(Rest, TableVar, Offset, Module, VarTypes1, - VarTypes, VarSet1, VarSet, RestGoals). + generate_save_goals(Rest, TableVar, Offset, + VarTypes2, VarTypes, VarSet2, VarSet, TableInfo1, TableInfo, + RestGoals), + + Goals = [OffsetUnifyGoal, CallGoal | RestGoals]. :- pred gen_save_call_for_type(builtin_type, type, prog_var, prog_var, - prog_var, module_info, hlds_goal). -:- mode gen_save_call_for_type(in, in, in, in, in, in, out) is det. + prog_var, map(prog_var, type), map(prog_var, type), + prog_varset, prog_varset, table_info, table_info, hlds_goal). +:- mode gen_save_call_for_type(in, in, in, in, in, in, out, in, out, in, out, + out) is det. -gen_save_call_for_type(TypeCat, _Type, TableVar, Var, OffsetVar, Module, +gen_save_call_for_type(TypeCat, Type, TableVar, Var, OffsetVar, + VarTypes0, VarTypes, VarSet0, VarSet, TableInfo0, TableInfo, Goal) :- + table_info_get_module_info(TableInfo0, Module), ( not_builtin_type(TypeCat) -> - LookupPredName = "table_save_any_ans" + make_type_info_var(Type, TypeInfoVar, ExtraGoals, + VarTypes0, VarTypes, VarSet0, VarSet, + TableInfo0, TableInfo), + + generate_call("table_save_any_ans", + [TypeInfoVar, TableVar, OffsetVar, Var], + det, impure, [], Module, CallGoal), + + list__append(ExtraGoals, [CallGoal], ConjList), + CallGoal = _ - GoalInfo, + conj_list_to_goal(ConjList, GoalInfo, Goal) ; builtin_type_to_string(TypeCat, CatString), string__append_list(["table_save_", CatString, "_ans"], - LookupPredName) - ), - generate_call(LookupPredName, [TableVar, OffsetVar, Var], - det, impure, [], Module, Goal). + LookupPredName), + generate_call(LookupPredName, [TableVar, OffsetVar, Var], + det, impure, [], Module, Goal), -%------------------------------------------------------------------------------% + VarTypes = VarTypes0, + VarSet = VarSet0, + TableInfo = TableInfo0 + ). + +%-----------------------------------------------------------------------------% :- pred generate_restore_goal(list(prog_var), prog_var, module_info, map(prog_var, type), map(prog_var, type), prog_varset, @@ -1017,7 +1083,7 @@ gen_restore_call_for_type(TypeCat, _Type, TableVar, Var, OffsetVar, Module, generate_call(LookupPredName, [TableVar, OffsetVar, Var], det, impure, [Var - ground(shared, no)], Module, Goal). -%------------------------------------------------------------------------------% +%-----------------------------------------------------------------------------% :- pred generate_suspend_goal(list(prog_var), prog_var, module_info, map(prog_var, type), map(prog_var, type), prog_varset, @@ -1046,14 +1112,17 @@ generate_suspend_goal(OutputVars, TableVar, Module, VarTypes0, VarTypes, GoalInfo), Goal = GoalEx - GoalInfo. -%------------------------------------------------------------------------------% +%-----------------------------------------------------------------------------% -:- pred generate_loop_error_goal(pred_info, module_info, map(prog_var, type), +:- pred generate_loop_error_goal(table_info, map(prog_var, type), map(prog_var, type), prog_varset, prog_varset, hlds_goal). -:- mode generate_loop_error_goal(in, in, in, out, in, out, out) is det. +:- mode generate_loop_error_goal(in, in, out, in, out, out) is det. -generate_loop_error_goal(PredInfo, ModuleInfo, VarTypes0, VarTypes, +generate_loop_error_goal(TableInfo, VarTypes0, VarTypes, VarSet0, VarSet, Goal) :- + table_info_get_module_info(TableInfo, ModuleInfo), + table_info_get_pred_info(TableInfo, PredInfo), + pred_info_module(PredInfo, Module), pred_info_name(PredInfo, Name), pred_info_arity(PredInfo, Arity), @@ -1078,7 +1147,7 @@ generate_loop_error_goal(PredInfo, ModuleInfo, VarTypes0, VarTypes, GoalInfo), Goal = GoalEx - GoalInfo. -%------------------------------------------------------------------------------% +%-----------------------------------------------------------------------------% :- pred generate_new_table_var(string, map(prog_var, type), map(prog_var, type), @@ -1113,6 +1182,15 @@ generate_call(PredName, Args, Detism0, Feature, InstMap, Module, Goal) :- [PredId0]) -> PredId = PredId0 + ; + % Some of the table builtins are polymorphic, + % and for them we need to subtract one from the arity + % to take into account the type_info argument. + predicate_table_search_pred_m_n_a(PredTable, + BuiltinModule, PredName, Arity - 1, + [PredId0]) + -> + PredId = PredId0 ; string__int_to_string(Arity, ArityS), string__append_list(["can't locate ", PredName, @@ -1270,3 +1348,101 @@ builtin_type_to_string(pred_type, "pred"). builtin_type_to_string(enum_type, "enum"). builtin_type_to_string(polymorphic_type, "any"). builtin_type_to_string(user_type, "any"). + +%-----------------------------------------------------------------------------% + +:- pred table_gen__make_type_info_var(type, prog_var, + list(hlds_goal), map(prog_var, type), map(prog_var, type), + prog_varset, prog_varset, table_info, table_info) is det. +:- mode table_gen__make_type_info_var(in, out, out, + in, out, in, out, in, out) is det. + +table_gen__make_type_info_var(Type, TypeInfoVar, TypeInfoGoals, + VarTypes0, VarTypes, VarSet0, VarSet, TableInfo0, TableInfo) :- + table_gen__make_type_info_vars([Type], TypeInfoVars, TypeInfoGoals, + VarTypes0, VarTypes, VarSet0, VarSet, + TableInfo0, TableInfo), + ( TypeInfoVars = [TypeInfoVar0] -> + TypeInfoVar = TypeInfoVar0 + ; + error("table_gen__make_type_info_var: list length != 1") + ). + +:- pred table_gen__make_type_info_vars(list(type), list(prog_var), + list(hlds_goal), map(prog_var, type), map(prog_var, type), + prog_varset, prog_varset, table_info, table_info) is det. +:- mode table_gen__make_type_info_vars(in, out, out, + in, out, in, out, in, out) is det. + +table_gen__make_type_info_vars(Types, TypeInfoVars, TypeInfoGoals, + VarTypes0, VarTypes, VarSet0, VarSet, TableInfo0, TableInfo) :- + % + % Extract the information from table_info + % + table_info_extract(TableInfo0, ModuleInfo0, PredInfo0, ProcInfo0), + + % + % Put the varset and vartypes from the simplify_info + % back in the proc_info + % + 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, ModuleInfo), + + % + % Get the new varset and vartypes from the proc_info + % + proc_info_vartypes(ProcInfo, VarTypes), + proc_info_varset(ProcInfo, VarSet), + + % + % Put the new module_info, pred_info, and proc_info back in the + % table_info. + % + table_info_init(ModuleInfo, PredInfo, ProcInfo, TableInfo). + +%-----------------------------------------------------------------------------% + +:- type table_info ---> table_info(module_info, pred_info, proc_info). + +:- pred table_info_init(module_info, pred_info, proc_info, table_info). +:- mode table_info_init(in, in, in, out) is det. + +:- pred table_info_extract(table_info, module_info, pred_info, proc_info). +:- mode table_info_extract(in, out, out, out) is det. + +:- pred table_info_get_module_info(table_info, module_info). +:- mode table_info_get_module_info(in, out) is det. + +:- pred table_info_get_pred_info(table_info, pred_info). +:- mode table_info_get_pred_info(in, out) is det. + +:- pred table_info_get_proc_info(table_info, proc_info). +:- mode table_info_get_proc_info(in, out) is det. + +table_info_init(ModuleInfo, PredInfo, ProcInfo, TableInfo) :- + TableInfo = table_info(ModuleInfo, PredInfo, ProcInfo). + +table_info_extract(TableInfo, ModuleInfo, PredInfo, ProcInfo) :- + TableInfo = table_info(ModuleInfo, PredInfo, ProcInfo). + +table_info_get_module_info(TableInfo, ModuleInfo) :- + TableInfo = table_info(ModuleInfo, _PredInfo, _ProcInfo). + +table_info_get_pred_info(TableInfo, PredInfo) :- + TableInfo = table_info(_ModuleInfo, PredInfo, _ProcInfo). + +table_info_get_proc_info(TableInfo, ProcInfo) :- + TableInfo = table_info(_ModuleInfo, _PredInfo, ProcInfo). + +%-----------------------------------------------------------------------------% diff --git a/compiler/term_traversal.m b/compiler/term_traversal.m index c5d0eea2b..30114c580 100644 --- a/compiler/term_traversal.m +++ b/compiler/term_traversal.m @@ -1,5 +1,5 @@ %-----------------------------------------------------------------------------% -% Copyright (C) 1997-1998 The University of Melbourne. +% Copyright (C) 1997-1999 The University of Melbourne. % This file may only be copied under the terms of the GNU General % Public License - see the file COPYING in the Mercury distribution. %-----------------------------------------------------------------------------% @@ -151,7 +151,7 @@ traverse_goal_2(unify(_Var, _RHS, _UniMode, Unification, _Context), Unification = simple_test(_InVar1, _InVar2), Info = Info0 ; - Unification = complicated_unify(_, _), + Unification = complicated_unify(_, _, _), error("Unexpected complicated_unify in termination analysis") ). diff --git a/compiler/type_util.m b/compiler/type_util.m index d9cacb651..08b515cc9 100644 --- a/compiler/type_util.m +++ b/compiler/type_util.m @@ -54,6 +54,14 @@ :- pred type_id_is_hand_defined(type_id). :- mode type_id_is_hand_defined(in) is semidet. + % A test for type_info-related types that are introduced by + % polymorphism.m. Mode inference never infers unique modes + % for these types, since it would not be useful, and since we + % want to minimize the number of different modes that we infer. + +:- pred is_introduced_type_info_type(type). +:- mode is_introduced_type_info_type(in) is semidet. + % Given a type, determine what sort of type it is. :- pred classify_type(type, module_info, builtin_type). @@ -120,6 +128,24 @@ :- pred type_util__get_cons_id_arg_types(module_info::in, (type)::in, cons_id::in, list(type)::out) is det. + % Given a type and a cons_id, look up the definition of that + % constructor; if it is existentially typed, return its definition, + % otherwise fail. +:- pred type_util__get_existq_cons_defn(module_info::in, + (type)::in, cons_id::in, ctor_defn::out) is semidet. + + % This type is used to return information about a constructor + % definition, extracted from the hlds_type_defn and hlds_cons_defn + % data types. +:- type ctor_defn + ---> ctor_defn( + tvarset, + existq_tvars, + list(class_constraint), % existential constraints + list(type), % functor argument types + (type) % functor result type + ). + % Given a list of constructors for a type, % check whether that type is a no_tag type % (i.e. one with only one constructor, and @@ -282,6 +308,16 @@ type_id_is_hand_defined(qualified(PrivateBuiltin, "typeclass_info") - 1) :- type_id_is_hand_defined(qualified(PrivateBuiltin, "base_typeclass_info") - 1) :- mercury_private_builtin_module(PrivateBuiltin). +is_introduced_type_info_type(Type) :- + sym_name_and_args(Type, TypeName, _), + TypeName = qualified(PrivateBuiltin, Name), + ( Name = "type_info" + ; Name = "type_ctor_info" + ; Name = "typeclass_info" + ; Name = "base_typeclass_info" + ), + mercury_private_builtin_module(PrivateBuiltin). + %-----------------------------------------------------------------------------% % Given a type, determine what sort of type it is. @@ -435,19 +471,43 @@ type_util__get_cons_id_arg_types(ModuleInfo, VarType, ConsId, ArgTypes) :- ConsDefn = hlds_cons_defn(_, _, _, TypeId, _) )), list__filter(CorrectCons, ConsDefns, - [hlds_cons_defn(_, _, ArgTypes0, _, _)]), + [hlds_cons_defn(_ExistQVars0, _Constraints0, ArgTypes0, + _, _)]), ArgTypes0 \= [] -> module_info_types(ModuleInfo, Types), map__lookup(Types, TypeId, TypeDefn), hlds_data__get_type_defn_tparams(TypeDefn, TypeDefnParams), term__term_list_to_var_list(TypeDefnParams, TypeDefnVars), - term__substitute_corresponding_list(TypeDefnVars, TypeArgs, - ArgTypes0, ArgTypes) + % XXX handle ExistQVars + map__from_corresponding_lists(TypeDefnVars, TypeArgs, TSubst), + term__apply_substitution_to_list(ArgTypes0, TSubst, ArgTypes) ; ArgTypes = [] ). + % Given a type and a cons_id, look up the definition of that + % constructor; if it is existentially typed, return its definition, + % otherwise fail. +type_util__get_existq_cons_defn(ModuleInfo, VarType, ConsId, CtorDefn) :- + type_to_type_id(VarType, TypeId, _TypeArgs), + module_info_ctors(ModuleInfo, Ctors), + % will fail for builtin cons_ids. + map__search(Ctors, ConsId, ConsDefns), + MatchingCons = lambda([ConsDefn::in] is semidet, ( + ConsDefn = hlds_cons_defn(_, _, _, TypeId, _) + )), + list__filter(MatchingCons, ConsDefns, + [hlds_cons_defn(ExistQVars, Constraints, ArgTypes, _, _)]), + ExistQVars \= [], + module_info_types(ModuleInfo, Types), + map__lookup(Types, TypeId, TypeDefn), + hlds_data__get_type_defn_tvarset(TypeDefn, TypeVarSet), + hlds_data__get_type_defn_tparams(TypeDefn, TypeDefnParams), + construct_type(TypeId, TypeDefnParams, RetType), + CtorDefn = ctor_defn(TypeVarSet, ExistQVars, Constraints, + ArgTypes, RetType). + %-----------------------------------------------------------------------------% % The checks for type_info and type_ctor_info diff --git a/compiler/typecheck.m b/compiler/typecheck.m index f05462bee..78cbf031e 100644 --- a/compiler/typecheck.m +++ b/compiler/typecheck.m @@ -311,14 +311,15 @@ typecheck_pred_type(PredId, PredInfo0, ModuleInfo, PredInfo, Error, Changed, % Compiler-generated predicates are created already type-correct, % there's no need to typecheck them. Same for builtins. % But, compiler-generated unify predicates are not guaranteed - % to be type-correct if they call a user-defined equality pred. + % to be type-correct if they call a user-defined equality pred + % or if it is a special pred for an existentially typed data type. ( code_util__compiler_generated(PredInfo0), - \+ pred_is_user_defined_equality_pred(PredInfo0, ModuleInfo) + \+ special_pred_needs_typecheck(PredInfo0, ModuleInfo) ; code_util__predinfo_is_builtin(PredInfo0) ) -> 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 +332,10 @@ typecheck_pred_type(PredId, PredInfo0, ModuleInfo, PredInfo, Error, Changed, 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 +349,8 @@ typecheck_pred_type(PredId, PredInfo0, ModuleInfo, PredInfo, Error, Changed, % 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 +418,9 @@ typecheck_pred_type(PredId, PredInfo0, ModuleInfo, PredInfo, Error, Changed, 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, @@ -679,20 +683,31 @@ same_structure_2([ConstraintA | ConstraintsA], [ConstraintB | ConstraintsB], list__append(ArgTypesA, TypesA0, TypesA), list__append(ArgTypesB, TypesB0, TypesB). -:- pred pred_is_user_defined_equality_pred(pred_info::in, module_info::in) +% +% A compiler-generated predicate only needs type checking if +% (a) it is a user-defined equality pred +% or (b) it is the unification or comparison predicate for an +% existially quantified type. +% +% In case (b), we need to typecheck it to fill in the head_type_params +% field in the pred_info. +% + +:- pred special_pred_needs_typecheck(pred_info::in, module_info::in) is semidet. -pred_is_user_defined_equality_pred(PredInfo, ModuleInfo) :- +special_pred_needs_typecheck(PredInfo, ModuleInfo) :- % - % check if the predicate is a compiler-generated unification predicate + % check if the predicate is a compiler-generated special + % predicate % pred_info_name(PredInfo, PredName), pred_info_arity(PredInfo, PredArity), - special_pred_name_arity(unify, _, PredName, PredArity), + special_pred_name_arity(_, _, PredName, PredArity), % - % find out which type it is a unification predicate for, + % find out which type it is a special predicate for, % and check whether that type is a type for which there is - % a user-defined equality predicate. + % a user-defined equality predicate, or which is existentially typed. % pred_info_arg_types(PredInfo, ArgTypes), special_pred_get_type(PredName, ArgTypes, Type), @@ -700,7 +715,12 @@ pred_is_user_defined_equality_pred(PredInfo, ModuleInfo) :- module_info_types(ModuleInfo, TypeTable), map__lookup(TypeTable, TypeId, TypeDefn), hlds_data__get_type_defn_body(TypeDefn, Body), - Body = du_type(_, _, _, yes(_)). + Body = du_type(Ctors, _, _, MaybeEqualityPred), + ( MaybeEqualityPred = yes(_) + ; list__member(Ctor, Ctors), + Ctor = ctor(ExistQTVars, _, _, _), + ExistQTVars \= [] + ). %-----------------------------------------------------------------------------% diff --git a/compiler/unify_gen.m b/compiler/unify_gen.m index d641b5105..95644f6bf 100644 --- a/compiler/unify_gen.m +++ b/compiler/unify_gen.m @@ -79,7 +79,7 @@ unify_gen__generate_unification(CodeModel, Uni, Code) --> ; % 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") } ). diff --git a/compiler/unify_proc.m b/compiler/unify_proc.m index 10aeaac21..309db8198 100644 --- a/compiler/unify_proc.m +++ b/compiler/unify_proc.m @@ -107,7 +107,7 @@ %-----------------------------------------------------------------------------% :- implementation. -:- import_module tree, map, queue, int, string, require. +:- import_module tree, map, queue, int, string, require, assoc_list. :- import_module code_util, code_info, type_util. :- import_module mercury_to_mercury, hlds_out. @@ -239,7 +239,13 @@ unify_proc__request_unify(UnifyId, Determinism, Context, ModuleInfo0, % 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 @@ -485,7 +491,10 @@ unify_proc__generate_clause_info(SpecialPredId, Type, TypeBody, Context, 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). @@ -635,18 +644,19 @@ unify_proc__quantify_clause_body(HeadVars, Goal, Context, Clauses) --> unify_proc__generate_du_unify_clauses([], _H1, _H2, _Context, []) --> []. unify_proc__generate_du_unify_clauses([Ctor | Ctors], H1, H2, Context, [Clause | Clauses]) --> - { Ctor = ctor(_ExistQVars, _Constraints, FunctorName, ArgTypes) }, + { Ctor = ctor(ExistQTVars, _Constraints, FunctorName, ArgTypes) }, { list__length(ArgTypes, FunctorArity) }, { FunctorConsId = cons(FunctorName, FunctorArity) }, - unify_proc__make_fresh_vars(ArgTypes, Vars1), - unify_proc__make_fresh_vars(ArgTypes, Vars2), + unify_proc__make_fresh_vars(ArgTypes, ExistQTVars, Vars1), + unify_proc__make_fresh_vars(ArgTypes, ExistQTVars, Vars2), { create_atomic_unification( H1, functor(FunctorConsId, Vars1), Context, explicit, [], UnifyH1_Goal) }, { create_atomic_unification( H2, functor(FunctorConsId, Vars2), Context, explicit, [], UnifyH2_Goal) }, - { unify_proc__unify_var_lists(Vars1, Vars2, UnifyArgs_Goal) }, + unify_proc__unify_var_lists(ArgTypes, ExistQTVars, Vars1, Vars2, + UnifyArgs_Goal), { GoalList = [UnifyH1_Goal, UnifyH2_Goal | UnifyArgs_Goal] }, { goal_info_init(GoalInfo0) }, { goal_info_set_context(GoalInfo0, Context, @@ -692,10 +702,10 @@ unify_proc__generate_du_unify_clauses([Ctor | Ctors], H1, H2, Context, unify_proc__generate_du_index_clauses([], _X, _Index, _Context, _N, []) --> []. unify_proc__generate_du_index_clauses([Ctor | Ctors], X, Index, Context, N, [Clause | Clauses]) --> - { Ctor = ctor(_ExistQVars, _Constraints, FunctorName, ArgTypes) }, + { Ctor = ctor(ExistQTVars, _Constraints, FunctorName, ArgTypes) }, { list__length(ArgTypes, FunctorArity) }, { FunctorConsId = cons(FunctorName, FunctorArity) }, - unify_proc__make_fresh_vars(ArgTypes, ArgVars), + unify_proc__make_fresh_vars(ArgTypes, ExistQTVars, ArgVars), { create_atomic_unification( X, functor(FunctorConsId, ArgVars), Context, explicit, [], UnifyX_Goal) }, @@ -883,18 +893,19 @@ unify_proc__generate_compare_cases([Ctor | Ctors], R, X, Y, Context, is det. unify_proc__generate_compare_case(Ctor, R, X, Y, Context, Case) --> - { Ctor = ctor(_ExistQVars, _Constraints, FunctorName, ArgTypes) }, + { Ctor = ctor(ExistQTVars, _Constraints, FunctorName, ArgTypes) }, { list__length(ArgTypes, FunctorArity) }, { FunctorConsId = cons(FunctorName, FunctorArity) }, - unify_proc__make_fresh_vars(ArgTypes, Vars1), - unify_proc__make_fresh_vars(ArgTypes, Vars2), + unify_proc__make_fresh_vars(ArgTypes, ExistQTVars, Vars1), + unify_proc__make_fresh_vars(ArgTypes, ExistQTVars, Vars2), { create_atomic_unification( X, functor(FunctorConsId, Vars1), Context, explicit, [], UnifyX_Goal) }, { create_atomic_unification( Y, functor(FunctorConsId, Vars2), Context, explicit, [], UnifyY_Goal) }, - unify_proc__compare_args(Vars1, Vars2, R, Context, CompareArgs_Goal), + unify_proc__compare_args(ArgTypes, ExistQTVars, Vars1, Vars2, + R, Context, CompareArgs_Goal), { GoalList = [UnifyX_Goal, UnifyY_Goal, CompareArgs_Goal] }, { goal_info_init(GoalInfo0) }, { goal_info_set_context(GoalInfo0, Context, @@ -927,20 +938,53 @@ unify_proc__generate_compare_case(Ctor, R, X, Y, Context, Case) --> */ -:- pred unify_proc__compare_args(list(prog_var), list(prog_var), prog_var, - prog_context, hlds_goal, unify_proc_info, unify_proc_info). -:- mode unify_proc__compare_args(in, in, in, in, out, in, out) is det. +:- pred unify_proc__compare_args(list(constructor_arg), existq_tvars, + list(prog_var), list(prog_var), prog_var, prog_context, + hlds_goal, unify_proc_info, unify_proc_info). +:- mode unify_proc__compare_args(in, in, in, in, in, in, out, in, out) is det. -unify_proc__compare_args([], [], R, Context, Return_Equal) --> +unify_proc__compare_args(ArgTypes, ExistQTVars, Xs, Ys, R, Context, Goal) --> + ( + unify_proc__compare_args_2(ArgTypes, ExistQTVars, Xs, Ys, R, + Context, Goal0) + -> + { Goal = Goal0 } + ; + { error("unify_proc__compare_args: length mismatch") } + ). + +:- pred unify_proc__compare_args_2(list(constructor_arg), existq_tvars, + list(prog_var), list(prog_var), prog_var, prog_context, + hlds_goal, unify_proc_info, unify_proc_info). +:- mode unify_proc__compare_args_2(in, in, in, in, in, in, out, in, out) + is semidet. + +unify_proc__compare_args_2([], _, [], [], R, Context, Return_Equal) --> { create_atomic_unification( R, functor(cons(unqualified("="), 0), []), Context, explicit, [], Return_Equal) }. -unify_proc__compare_args([X|Xs], [Y|Ys], R, Context, Goal) --> +unify_proc__compare_args_2([_Name - Type|ArgTypes], ExistQTVars, [X|Xs], [Y|Ys], + R, Context, Goal) --> { goal_info_init(GoalInfo0) }, { goal_info_set_context(GoalInfo0, Context, GoalInfo) }, + % + % When comparing existentially typed arguments, the arguments may + % have different types; in that case, rather than just comparing them, + % which would be a type error, we call `typed_compare', which is a + % builtin that first compares their types and then compares + % their values. + % + { + list__member(ExistQTVar, ExistQTVars), + term__contains_var(Type, ExistQTVar) + -> + ComparePred = "typed_compare" + ; + ComparePred = "compare" + }, ( { Xs = [], Ys = [] } -> - unify_proc__build_call("compare", [R, X, Y], Context, Goal) + unify_proc__build_call(ComparePred, [R, X, Y], Context, Goal) ; { mercury_public_builtin_module(MercuryBuiltin) }, { construct_type( @@ -948,7 +992,7 @@ unify_proc__compare_args([X|Xs], [Y|Ys], R, Context, Goal) --> [], ResType) }, unify_proc__info_new_var(ResType, R1), - unify_proc__build_call("compare", [R1, X, Y], Context, + unify_proc__build_call(ComparePred, [R1, X, Y], Context, Do_Comparison), { create_atomic_unification( @@ -964,12 +1008,9 @@ unify_proc__compare_args([X|Xs], [Y|Ys], R, Context, Goal) --> { map__init(Empty) }, { Goal = if_then_else([], Condition, Return_R1, ElseCase, Empty) - GoalInfo}, - unify_proc__compare_args(Xs, Ys, R, Context, ElseCase) + unify_proc__compare_args_2(ArgTypes, ExistQTVars, Xs, Ys, R, + Context, ElseCase) ). -unify_proc__compare_args([], [_|_], _, _, _) --> - { error("unify_proc__compare_args: length mismatch") }. -unify_proc__compare_args([_|_], [], _, _, _) --> - { error("unify_proc__compare_args: length mismatch") }. %-----------------------------------------------------------------------------% @@ -1008,7 +1049,7 @@ unify_proc__build_call(Name, ArgVars, Context, Goal) --> }, { hlds_pred__initial_proc_id(ModeId) }, { Call = call(IndexPredId, ModeId, ArgVars, not_builtin, - no, unqualified(Name)) }, + no, qualified(MercuryBuiltin, Name)) }, { goal_info_init(GoalInfo0) }, { goal_info_set_context(GoalInfo0, Context, GoalInfo) }, { Goal = Call - GoalInfo }. @@ -1016,7 +1057,7 @@ unify_proc__build_call(Name, ArgVars, Context, Goal) --> %-----------------------------------------------------------------------------% :- pred unify_proc__make_fresh_vars_from_types(list(type), list(prog_var), - unify_proc_info, unify_proc_info). + unify_proc_info, unify_proc_info). :- mode unify_proc__make_fresh_vars_from_types(in, out, in, out) is det. unify_proc__make_fresh_vars_from_types([], []) --> []. @@ -1024,29 +1065,72 @@ unify_proc__make_fresh_vars_from_types([Type | Types], [Var | Vars]) --> unify_proc__info_new_var(Type, Var), unify_proc__make_fresh_vars_from_types(Types, Vars). -:- pred unify_proc__make_fresh_vars(list(constructor_arg), list(prog_var), - unify_proc_info, unify_proc_info). -:- mode unify_proc__make_fresh_vars(in, out, in, out) is det. +:- pred unify_proc__make_fresh_vars(list(constructor_arg), existq_tvars, + list(prog_var), unify_proc_info, unify_proc_info). +:- mode unify_proc__make_fresh_vars(in, in, out, in, out) is det. -unify_proc__make_fresh_vars([], []) --> []. -unify_proc__make_fresh_vars([_Name - Type | Args], [Var | Vars]) --> - unify_proc__info_new_var(Type, Var), - unify_proc__make_fresh_vars(Args, Vars). +unify_proc__make_fresh_vars(CtorArgs, ExistQTVars, Vars) --> + ( { ExistQTVars = [] } -> + { assoc_list__values(CtorArgs, ArgTypes) }, + unify_proc__make_fresh_vars_from_types(ArgTypes, Vars) + ; + % + % If there are existential types involved, then it's too + % hard to get the types right here (it would require + % allocating new type variables) -- instead, typecheck.m + % will typecheck the clause to figure out the correct types. + % So we just allocate the variables and leave it up to + % typecheck.m to infer their types. + % + unify_proc__info_get_varset(VarSet0), + { list__length(CtorArgs, NumVars) }, + { varset__new_vars(VarSet0, NumVars, Vars, VarSet) }, + unify_proc__info_set_varset(VarSet) + ). + +:- pred unify_proc__unify_var_lists(list(constructor_arg), existq_tvars, + list(prog_var), list(prog_var), list(hlds_goal), + unify_proc_info, unify_proc_info). +:- mode unify_proc__unify_var_lists(in, in, in, in, out, in, out) is det. -:- pred unify_proc__unify_var_lists(list(prog_var), list(prog_var), - list(hlds_goal)). -:- mode unify_proc__unify_var_lists(in, in, out) is det. +unify_proc__unify_var_lists(ArgTypes, ExistQVars, Vars1, Vars2, Goal) --> + ( + unify_proc__unify_var_lists_2(ArgTypes, ExistQVars, + Vars1, Vars2, Goal0) + -> + { Goal = Goal0 } + ; + { error("unify_proc__unify_var_lists: length mismatch") } + ). -unify_proc__unify_var_lists([], [_|_], _) :- - error("unify_proc__unify_var_lists: length mismatch"). -unify_proc__unify_var_lists([_|_], [], _) :- - error("unify_proc__unify_var_lists: length mismatch"). -unify_proc__unify_var_lists([], [], []). -unify_proc__unify_var_lists([Var1 | Vars1], [Var2 | Vars2], [Goal | Goals]) :- - term__context_init(Context), - create_atomic_unification(Var1, var(Var2), Context, explicit, [], - Goal), - unify_proc__unify_var_lists(Vars1, Vars2, Goals). +:- pred unify_proc__unify_var_lists_2(list(constructor_arg), existq_tvars, + list(prog_var), list(prog_var), list(hlds_goal), + unify_proc_info, unify_proc_info). +:- mode unify_proc__unify_var_lists_2(in, in, in, in, out, in, out) is semidet. + +unify_proc__unify_var_lists_2([], _, [], [], []) --> []. +unify_proc__unify_var_lists_2([_Name - Type | ArgTypes], ExistQTVars, + [Var1 | Vars1], [Var2 | Vars2], [Goal | Goals]) --> + { term__context_init(Context) }, + % + % When unifying existentially typed arguments, the arguments may + % have different types; in that case, rather than just unifying them, + % which would be a type error, we call `typed_unify', which is a + % builtin that first checks that their types are equal and then + % unifies the values. + % + ( + { list__member(ExistQTVar, ExistQTVars) }, + { term__contains_var(Type, ExistQTVar) } + -> + unify_proc__build_call("typed_unify", [Var1, Var2], Context, + Goal) + ; + { create_atomic_unification(Var1, var(Var2), Context, explicit, + [], Goal) } + ), + unify_proc__unify_var_lists_2(ArgTypes, ExistQTVars, Vars1, Vars2, + Goals). %-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------% diff --git a/compiler/unique_modes.m b/compiler/unique_modes.m index 8ad33c1e5..0149300dd 100644 --- a/compiler/unique_modes.m +++ b/compiler/unique_modes.m @@ -62,7 +62,7 @@ :- import_module modes, prog_data, mode_errors, llds, unify_proc. :- import_module (inst), instmap, inst_match, inst_util. :- import_module term, varset. -:- import_module int, list, map, set, std_util, require, assoc_list. +:- import_module int, list, map, set, std_util, require, assoc_list, string. %-----------------------------------------------------------------------------% @@ -347,9 +347,17 @@ unique_modes__check_goal_2(if_then_else(Vs, A0, B0, C0, SM), GoalInfo0, Goal) unique_modes__check_goal(A0, A), mode_info_remove_live_vars(B_Vars), mode_info_unlock_vars(if_then_else, NonLocals), - % mode_info_dcg_get_instmap(InstMapA), - unique_modes__check_goal(B0, B), - mode_info_dcg_get_instmap(InstMapB), + mode_info_dcg_get_instmap(InstMapA), + ( { instmap__is_reachable(InstMapA) } -> + unique_modes__check_goal(B0, B), + mode_info_dcg_get_instmap(InstMapB) + ; + % We should not mode-analyse the goal, since it is unreachable. + % Instead we optimize the goal away, so that later passes + % won't complain about it not having unique mode information. + { true_goal(B) }, + { InstMapB = InstMapA } + ), mode_info_set_instmap(InstMap0), unique_modes__check_goal(C0, C), mode_info_dcg_get_instmap(InstMapC), @@ -387,7 +395,8 @@ unique_modes__check_goal_2(higher_order_call(PredVar, Args, Types, Modes, Det, NeverSucceeds = no }, { determinism_to_code_model(Det, CodeModel) }, - unique_modes__check_call_modes(Args, Modes, CodeModel, NeverSucceeds), + unique_modes__check_call_modes(Args, Modes, 0, + CodeModel, NeverSucceeds), { Goal = higher_order_call(PredVar, Args, Types, Modes, Det, PredOrFunc) }, mode_info_unset_call_context, @@ -408,14 +417,17 @@ unique_modes__check_goal_2(class_method_call(TCVar, Num, Args, Types, Modes, NeverSucceeds = no }, { determinism_to_code_model(Det, CodeModel) }, - unique_modes__check_call_modes(Args, Modes, CodeModel, NeverSucceeds), + unique_modes__check_call_modes(Args, Modes, 0, + CodeModel, NeverSucceeds), { Goal = class_method_call(TCVar, Num, Args, Types, Modes, Det) }, mode_info_unset_call_context, mode_checkpoint(exit, "class method call"). unique_modes__check_goal_2(call(PredId, ProcId0, Args, Builtin, CallContext, PredName), _GoalInfo0, Goal) --> - mode_checkpoint(enter, "call"), + { prog_out__sym_name_to_string(PredName, PredNameString) }, + { string__append("call ", PredNameString, CallString) }, + mode_checkpoint(enter, CallString), mode_info_set_call_context(call(PredId)), unique_modes__check_call(PredId, ProcId0, Args, ProcId), { Goal = call(PredId, ProcId, Args, Builtin, CallContext, PredName) }, @@ -479,12 +491,14 @@ unique_modes__check_call(PredId, ProcId0, ArgVars, ProcId, % first off, try using the existing mode % mode_info_get_module_info(ModeInfo0, ModuleInfo), - module_info_pred_proc_info(ModuleInfo, PredId, ProcId0, _, ProcInfo), + module_info_pred_proc_info(ModuleInfo, PredId, ProcId0, + PredInfo, ProcInfo), + compute_arg_offset(PredInfo, ArgOffset), proc_info_argmodes(ProcInfo, ProcArgModes0), proc_info_interface_code_model(ProcInfo, CodeModel), proc_info_never_succeeds(ProcInfo, NeverSucceeds), - unique_modes__check_call_modes(ArgVars, ProcArgModes0, CodeModel, - NeverSucceeds, ModeInfo1, ModeInfo2), + unique_modes__check_call_modes(ArgVars, ProcArgModes0, ArgOffset, + CodeModel, NeverSucceeds, ModeInfo1, ModeInfo2), % % see whether or not that worked @@ -539,21 +553,21 @@ unique_modes__check_call(PredId, ProcId0, ArgVars, ProcId, % argument if the variable is nondet-live and the required initial % inst was unique. -:- pred unique_modes__check_call_modes(list(prog_var), list(mode), code_model, - bool, mode_info, mode_info). -:- mode unique_modes__check_call_modes(in, in, in, in, +:- pred unique_modes__check_call_modes(list(prog_var), list(mode), int, + code_model, bool, mode_info, mode_info). +:- mode unique_modes__check_call_modes(in, in, in, in, in, mode_info_di, mode_info_uo) is det. -unique_modes__check_call_modes(ArgVars, ProcArgModes, CodeModel, NeverSucceeds, - ModeInfo0, ModeInfo) :- +unique_modes__check_call_modes(ArgVars, ProcArgModes, ArgOffset, + CodeModel, NeverSucceeds, ModeInfo0, ModeInfo) :- mode_info_get_module_info(ModeInfo0, ModuleInfo), mode_list_get_initial_insts(ProcArgModes, ModuleInfo, InitialInsts), - modecheck_var_has_inst_list(ArgVars, InitialInsts, 0, + modecheck_var_has_inst_list(ArgVars, InitialInsts, ArgOffset, ModeInfo0, ModeInfo1), mode_list_get_final_insts(ProcArgModes, ModuleInfo, FinalInsts), modecheck_set_var_inst_list(ArgVars, InitialInsts, FinalInsts, - NewArgVars, ExtraGoals, ModeInfo1, ModeInfo2), + ArgOffset, NewArgVars, ExtraGoals, ModeInfo1, ModeInfo2), ( NewArgVars = ArgVars, ExtraGoals = no_extra_goals -> true ; @@ -592,7 +606,17 @@ unique_modes__check_conj([Goal0 | Goals0], [Goal | Goals]) --> { unique_modes__goal_get_nonlocals(Goal0, NonLocals) }, mode_info_remove_live_vars(NonLocals), unique_modes__check_goal(Goal0, Goal), - unique_modes__check_conj(Goals0, Goals). + mode_info_dcg_get_instmap(InstMap), + ( { instmap__is_unreachable(InstMap) } -> + % We should not mode-analyse the remaining goals, since they + % are unreachable. Instead we optimize them away, so that + % later passes won't complain about them not having + % unique mode information. + mode_info_remove_goals_live_vars(Goals0), + { Goals = [] } + ; + unique_modes__check_conj(Goals0, Goals) + ). %-----------------------------------------------------------------------------% @@ -657,9 +681,19 @@ unique_modes__check_case_list([Case0 | Cases0], Var, modecheck_set_var_inst(Var, bound(unique, [functor(ConsId, ArgInsts)])), - unique_modes__check_goal(Goal0, Goal1), + mode_info_dcg_get_instmap(InstMap1), + ( { instmap__is_reachable(InstMap1) } -> + unique_modes__check_goal(Goal0, Goal1) + ; + % We should not mode-analyse the goal, since it is unreachable. + % Instead we optimize the goal away, so that later passes + % won't complain about it not having unique mode information. + { true_goal(Goal1) } + ), + mode_info_dcg_get_instmap(InstMap), { fixup_switch_var(Var, InstMap0, InstMap, Goal1, Goal) }, + mode_info_set_instmap(InstMap0), unique_modes__check_case_list(Cases0, Var, Cases, InstMaps). diff --git a/compiler/unused_args.m b/compiler/unused_args.m index cb85d1173..0a5c6b875 100644 --- a/compiler/unused_args.m +++ b/compiler/unused_args.m @@ -1,5 +1,5 @@ %-----------------------------------------------------------------------------% -% Copyright (C) 1996-1998 The University of Melbourne. +% Copyright (C) 1996-1999 The University of Melbourne. % This file may only be copied under the terms of the GNU General % Public License - see the file COPYING in the Mercury distribution. %-----------------------------------------------------------------------------% @@ -514,7 +514,7 @@ traverse_goal(_, unify(Var1, _, _, construct(_, _, Args, _), _), ). % 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 @@ fixup_unify(ModuleInfo, UnusedVars, Changed, ). % 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 diff --git a/doc/reference_manual.texi b/doc/reference_manual.texi index d74f8aa9c..9ac8cf4fd 100644 --- a/doc/reference_manual.texi +++ b/doc/reference_manual.texi @@ -88,6 +88,7 @@ into another language, under the above conditions for modified versions. with closures, lambda expressions, and currying * Modules:: Modules allow you to divide a program into smaller parts * Type classes:: Constrained polymorphism +* Existential types:: Support for data abstraction and heterogenous collections * Semantics:: Declarative and operational semantics of Mercury programs * Pragmas:: Various compiler directives, used for the C interface and to control optimization. @@ -866,8 +867,9 @@ well-moded into ones that would be ill-moded.) @node Types @chapter Types -The type system is based on many-sorted logic, with polymorphism and -type classes (@pxref{Type classes}). +The type system is based on many-sorted logic, and supports polymorphism, +type classes (@pxref{Type classes}), and existentially quantified types +(@pxref{Existential types}). Certain special types are builtin, or are defined in the Mercury library: @@ -1040,15 +1042,38 @@ The argument types of each predicate must be explicitly declared with a @samp{:- pred} declaration. The argument types and return type of each function must be explicitly declared with a @samp{:- func} declaration. -These declarations may be polymorphic. For example: +@example +:- pred is_all_uppercase(string). + +:- func strlen(string) = int. +@end example + +Predicates and functions can be polymorphic; that is, their +declarations can include type variables. For example: + @example :- pred member(T, list(T)). :- func length(list(T)) = int. @end example +Type variables in predicate and function declarations +are implicitly universally quantified by default; +that is, the predicate or function may be called with arguments +and (in the case of functions) return value +whose actual types are any instance of the types +specified in the declaration. For example, +the function @samp{length/1} declared above +could be called with the argument having +type @samp{list(int)}, or @samp{list(float)}, +or @samp{list(list(int))}, etc. + +Type variables in predicate and function declarations can +also be existentially quantified; this is discussed in +@ref{Existential types}. + There must only be one predicate with a given name and arity in each module, and only one function with a given name and arity in each module. It is an error to declare the same predicate or function twice. @@ -2039,7 +2064,7 @@ if-then-else is also in a single-solution context. @item For other compound goals, i.e. disjunctions, negations, and (explicitly) existentially quantified goals, if the compound goal -is in a single-solution context, then the immediate subgoals of that +is in a single-solution context, then the immediate sub-goals of that compound goal are also in single-solution contexts. @end itemize @@ -2065,6 +2090,8 @@ Another is for dealing with types that use non-canonical representations (@pxref{Equality preds}). And there are a variety of other applications. +@c XXX fix semantics for I/O + committed choice + mode inference + @node Equality preds @chapter User-defined equality predicates @@ -3210,6 +3237,297 @@ constraints on the corresponding non-abstract instance declaration that defines that instance. @c XXX The current implementation does not enforce that rule. +@node Existential types +@chapter Existential types + +Existentially quantified type variables (or simply "existential types" +for short) are useful tools for data abstraction. In combination with +type classes, they allow you to write code in an "object oriented" +style that is similar to the use of interfaces in Java or abstract +base classes in C++. + +Mercury supports existential type quantifiers on predicate and function +declarations. Unfortunately we do not yet support existential type +quantifiers on data type definitions. However, we do provide some +work-arounds for this. + +@menu +* Syntax for explicit type qualifiers:: +* Semantics of type qualifiers:: +* Examples of correct code using type quantifiers:: +* Examples of incorrect code using type quantifiers:: +* Existential class constraints:: +* Some idioms using existentially quantified types:: +* Known bugs in the current implementation:: +@end menu + +@node Syntax for explicit type qualifiers +@section Syntax for explicit type qualifiers + +Type variables in type declarations for polymorphic predicates or functions +are normally universally quantified. +However, it is also possible to existentially quantify such +type variables, by using an explicit existential quantifier of +the form @samp{some @var{Vars}} before the @samp{pred} or @samp{func} +declaration, where @var{Vars} is a list of variables. + +For example: + +@example +% Here the type variables `T' is existentially quantified +:- some [T] pred foo(T). + +% Here the type variabless `T1' and `T2' are existentially quantified. +:- some [T1, T2] func bar(int, list(T1), set(T2)) = pair(T1, T2). + +% Here the type variable `T2' is existentially quantified, +% but the type variables `T1' and `T3' are universally quantified. +:- some [T2] pred foo(T1, T2, T3). +@end example + +Explicit universal quantifiers, of the form @samp{all @var{Vars}}, +are also permitted on @samp{pred} and @samp{func} declarations, +although they are not necessary, since universal quantification is +the default. (If both universal and existential quantifiers +are present, the universal quantifiers must precede the existential +quantifiers.) For example: + +@example +% Here the type variable `T2' is existentially quantified, +% but the type variables `T1' and `T3' are universally quantified. +:- all [T3] some [T2] pred foo(T1, T2, T3). +@end example + +@node Semantics of type qualifiers +@section Semantics of type qualifiers + +If a type variable in the type declaration for a polymorphic predicate +or function is universally quantified, this means the caller will +determine the value of the type variable, and the callee must be defined +so that it will work for @emph{all} types which are an instance of its +declared type. + +For an existentially quantified type variable, the situation is the +converse: the @emph{callee} must determine the value of the type variable, +and all @emph{callers} must be defined so as to work for all types +which are an instance of the called procedure's declared type. + +When type checking a predicate or function, if a variable has a type +that occurs as a universally quantified type variable in the predicate +or function declaration, or a type that occurs as an existentially +quantified type variable in the declaration of one of the predicates +or functions that it calls, then its type is treated as an opaque type. +This means that there are very few things which it is legal to do with +such a variable -- basically you can only pass it to another procedure +expecting the same type, unify it with another value of the same +type, put it in a polymorphic data structure, or pass it to a +polymorphic procedure whose argument type is universally quantified. +(Note, however, that the standard library includes some quite powerful +procedures such as `io__write' which can be useful in this context.) + +A non-variable type is considered @emph{more general} than an +existentially quantified type variable. Type inference will therefore +never infer an existentially quantified type for a predicate or +function unless that predicate or function calls (directly or indirectly) +a predicate or function which was explicitly declared to have an +existentially quantified type. + +For procedures involving calls to existentially-typed predicates or functions, +the compiler's mode analysis must take account of the modes for type +variables in all polymorphic calls. +Universally quantified type variables have mode @samp{in}, +whereas existentially quantified type variables have mode @samp{out}. +As usual, the compiler's mode analysis will attempt to reorder the +elements of conjunctions in order to satisfy the modes. + +@node Examples of correct code using type quantifiers +@section Examples of correct code using type quantifiers + +Here are some examples of type-correct code using universal and +existential types. + +@example +/* simple examples */ + +:- pred foo(T). +foo(_). + % ok + +:- pred call_foo. +call_foo :- foo(42). + % ok (T = int) + +:- some [T] pred e_foo(T). +e_foo(X) :- X = 42. + % ok (T = int) + +:- pred call_e_foo. +call_e_foo :- e_foo(_). + % ok + +/* examples using higher-order functions */ + +:- func bar(T, T, func(T) = int) = int. +bar(X, Y, F) = F(X) + F(Y). + % ok + +:- func call_bar = int. +call_bar = bar(2, 3, (func(X) = X*X)). + % ok (T = int) + % returns 13 (= 2*2 + 3*3) + +:- some [T] pred e_bar(T, T, func(T) = int). +:- mode e_bar(out, out, out(func(in) = out is det)). +e_bar(2, 3, (func(X) = X * X)). + % ok (T = int) + +:- func call_e_bar = int. +call_e_bar = F(X) + F(Y) :- e_bar(X, Y, F). + % ok + % returns 13 (= 2*2 + 3*3) + +@end example + +@node Examples of incorrect code using type quantifiers +@section Examples of incorrect code using type quantifiers + +Here are some examples of code using universal and +existential types that contains type errors. + +@example +/* simple examples */ + +:- pred bad_foo(T). +bad_foo(42). + % type error + +:- some [T] pred e_foo(T). +e_foo(42). + % ok + +:- pred bad_call_e_foo. +bad_call_e_foo :- e_foo(42). + % type error + +:- some [T] pred e_bar1(T). +e_bar1(42). +e_bar1(42). +e_bar1(43). + % ok (T = int) + +:- some [T] pred bad_e_bar2(T). +bad_e_bar2(42). +bad_e_bar2("blah"). + % type error (cannot unify types `int' and `string') + +:- some [T] pred bad_e_bar3(T). +bad_e_bar3(X) :- e_foo(X). +bad_e_bar3(X) :- e_foo(X). + % type error (attempt to bind type variable `T' twice) + +@end example + +@node Existential class constraints +@section Existential class constraints + +Existentially quantified type variables are especially useful in +combination with type class constraints. + +Type class constraints can be either universal or existential. +Universal type class constraints are written using "<=", +as described in @ref{Type class constraints on predicates and functions}; +they signify a constraint that the @emph{caller} must satisfy. +Existential type class constraints are written in the same syntax +as universal constraints, but using "=>" instead of "<="; +they signify a constraint that the @emph{callee} must satisfy. +(If a declaration has both universal and existential constraints, +then the universal constraints must precede the existential constraints.) + +For example: + +@example +% Here `c1(T1)' is a universal constraint, +% and `c2(T2)' is an existential constraint. +:- all [T1] some [T2] ((pred p(T1, T2) <= c1(T1)) => (c2(T2), c3(T1, T2)). +@end example + +In general, constraints that constrain any existentially quantified +type variables should be existential constraints, and constraints that +constrain only universally quantified type variables should be +universal constraints. (The only time exceptions to this rule would +make any sense at all would be if there were instance declarations that +were visible in the definition of the caller but which due to module +visibility issues were not in the definition of the callee, or vice +versa. But even then, any exception to this rule would have to involve +a rather obscure coding style, which we do not recommend.) + +@node Some idioms using existentially quantified types +@section Some idioms using existentially quantified types + +The standard library module @samp{std_util} provides a type +named @samp{univ} which can hold values of any type. +You can form heterogenous containers (containers that can hold values of +different types at the same time) by using data structures +that contain @code{univ}s, e.g. @samp{list(univ)}. + + @example + % `univ' is a type which can hold any value. + :- type univ. + + % The function univ/1 takes a value of any type and constructs + % a `univ' containing that value (the type will be stored along + % with the value) + :- func univ(T) = univ. + + % The function univ_value/1 takes a `univ' argument and extracts + % the value contained in the `univ' (together with its type). + % This is the inverse of the function univ/1. + :- some [T] func univ_value(univ) = T. + @end example + +An existentially typed procedure is not allowed to have different +types for its existentially typed arguments in different clauses or +or in different subgoals of a single clause. For instance, both +of the following examples are illegal: + + :- some [T] pred bad_example(string, T). + bad_example("foo", 42). + bad_example("bar", "blah"). + % type error (cannot unify `int' and `string') + + :- some [T] pred bad_example2(string, T). + bad_example2(Name, Value) :- + ( Name = "bar", Value = 42 + ; Name = "bar", Value = "blah" + ). + % type error (cannot unify `int' and `string') + +However, using @samp{univ}, +it is possible for an existentially typed function to return +values of different types at each invocation. + + :- some [T] pred good_example(string, T). + good_example(Name, univ_value(Univ)) :- + ( Name = "bar", Univ = univ(42) + ; Name = "bar", Univ = univ("blah") + ). + +Unfortunately this technique doesn't work if you also want to use +type class constraints. Eventually we hope to support existentially +typed data types with type class constaints, which would address this issue. +@c (In the mean time, as a work-around, it is in fact possible to achieve +@c the same effect via some hacks using the C interface.) + +@node Known bugs in the current implementation +@section Known bugs in the current implementation + +The current implementation does not properly deal with most cases +that involve both existentially quantified constraints and +mode reordering due to the modes of type variables. +The symptom in such cases is spurious mode errors. +The solution is to write such code in the correct order manually +rather than relying on the compiler's mode reordering. + @node Semantics @chapter Semantics diff --git a/library/private_builtin.m b/library/private_builtin.m index 754f10e4d..219d79967 100644 --- a/library/private_builtin.m +++ b/library/private_builtin.m @@ -37,7 +37,8 @@ % should not be used by user programs directly. % Changes here may also require changes in compiler/polymorphism.m, - % compiler/higher_order.m and runtime/mercury_type_info.{c,h}. + % compiler/unify_proc.m, compiler/higher_order.m and + % runtime/mercury_type_info.{c,h}. :- pred builtin_unify_int(int::in, int::in) is semidet. :- pred builtin_index_int(int::in, int::out) is det. @@ -85,6 +86,18 @@ :- mode builtin_int_gt(in, in) is semidet. :- external(builtin_int_gt/2). + % A "typed" version of unify/2 -- i.e. one that can handle arguments + % of different types. It first unifies their types, and then if + % the types are equal it unifies the values. +:- pred typed_unify(T1, T2). +:- mode typed_unify(in, in) is semidet. + + % A "typed" version of compare/3 -- i.e. one that can handle arguments + % of different types. It first compares the types, and then if the + % types are equal it compares the values. +:- pred typed_compare(comparison_result, T1, T2). +:- mode typed_compare(uo, in, in) is det. + %-----------------------------------------------------------------------------% :- implementation. @@ -182,6 +195,12 @@ builtin_compare_non_canonical_type(Res, X, _Y) :- compare_error :- error("internal error in compare/3"). + % XXX These could be implemented more efficiently using + % `pragma c_code' -- the implementation below does some + % unnecessary memory allocatation. +typed_unify(X, Y) :- univ(X) = univ(Y). +typed_compare(R, X, Y) :- compare(R, univ(X), univ(Y)). + %-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------% diff --git a/tests/debugger/queens.exp b/tests/debugger/queens.exp index b1147fb3b..f152b39bf 100644 --- a/tests/debugger/queens.exp +++ b/tests/debugger/queens.exp @@ -31,8 +31,8 @@ mdb> 8: 5 4 DISJ pred queens:qdelete/3-0 (nondet) c2;d1; mdb> print * HeadVar__2 [1, 2, 3, 4, 5] - V_10 [2, 3, 4, 5] - V_11 1 + V_11 [2, 3, 4, 5] + V_12 1 mdb> level 1 1 5 4 3 pred queens:qperm/2-0 (nondet) Ancestor level set to 1. @@ -69,8 +69,8 @@ mdb> 13: 7 5 DISJ pred queens:qdelete/3-0 (nondet) c2;d1; mdb> print * HeadVar__2 [2, 3, 4, 5] - V_10 [3, 4, 5] - V_11 2 + V_11 [3, 4, 5] + V_12 2 mdb> 14: 7 5 EXIT pred queens:qdelete/3-0 (nondet) mdb> print * diff --git a/tests/hard_coded/Mmakefile b/tests/hard_coded/Mmakefile index b36ae695e..d9b8ebc1d 100644 --- a/tests/hard_coded/Mmakefile +++ b/tests/hard_coded/Mmakefile @@ -30,6 +30,7 @@ PROGS= \ dupcall_types_bug \ elim_special_pred \ existential_bound_tvar \ + existential_reordering \ eqv_type_bug \ error_func \ erroneous_liveness \ diff --git a/tests/hard_coded/existential_reordering.exp b/tests/hard_coded/existential_reordering.exp new file mode 100644 index 000000000..4724532c1 --- /dev/null +++ b/tests/hard_coded/existential_reordering.exp @@ -0,0 +1 @@ +univ([] : list:list(int)) diff --git a/tests/hard_coded/existential_reordering.m b/tests/hard_coded/existential_reordering.m new file mode 100644 index 000000000..8405abb61 --- /dev/null +++ b/tests/hard_coded/existential_reordering.m @@ -0,0 +1,30 @@ +% This module tests the use of existential types, +% including type inference, +% but not including type class constraints. + +:- module existential_reordering. +:- interface. + +:- some [T] func my_exist_t = T. + +:- import_module io. + +:- pred main(io__state::di, state::uo) is det. + +:- implementation. +:- import_module std_util, list. + +main --> + % do something which requires knowing the type of L + { L = [] }, + { Univ = univ(L) }, + write(Univ), + nl, + + % now do something which binds the type of L + { same_type(L, [my_exist_t]) }. + +:- pred same_type(T::unused, T::unused) is det. +same_type(_, _). + +my_exist_t = 42. diff --git a/tests/hard_coded/typeclasses/Mmakefile b/tests/hard_coded/typeclasses/Mmakefile index 146607dfb..5b86a2218 100644 --- a/tests/hard_coded/typeclasses/Mmakefile +++ b/tests/hard_coded/typeclasses/Mmakefile @@ -10,6 +10,7 @@ TYPECLASS_PROGS= \ constrained_lambda \ extract_typeinfo \ existential_type_classes \ + existential_data_types \ extra_typeinfo \ func_default_mode_bug \ ho_map \ diff --git a/tests/hard_coded/typeclasses/existential_data_types.exp b/tests/hard_coded/typeclasses/existential_data_types.exp new file mode 100644 index 000000000..16c7a29f3 --- /dev/null +++ b/tests/hard_coded/typeclasses/existential_data_types.exp @@ -0,0 +1,6 @@ +84 +4 +86 +86 +90 +9 diff --git a/tests/hard_coded/typeclasses/existential_data_types.m b/tests/hard_coded/typeclasses/existential_data_types.m new file mode 100644 index 000000000..e91b54142 --- /dev/null +++ b/tests/hard_coded/typeclasses/existential_data_types.m @@ -0,0 +1,81 @@ +% This test case tests the combination of existential types and +% type classes, i.e. existential type class constraints. + +:- module existential_data_types. +:- interface. +:- import_module io. + +:- pred main(io__state::di, state::uo) is det. + +:- implementation. +:- import_module std_util, int, string. + +:- typeclass fooable(T) where [ + pred foo(T::in, int::out) is det +]. +:- typeclass barable(T) where [ + pred bar(T::in, int::out) is det +]. + +:- instance fooable(int) where [ + pred(foo/2) is int_foo +]. + +:- instance fooable(string) where [ + pred(foo/2) is string_foo +]. + + % my_univ_value(Univ): + % returns the value of the object stored in Univ. + +:- type my_univ ---> some [T] make_my_univ(T) => fooable(T). + +:- some [T] func my_univ_value(my_univ) = T => fooable(T). + +:- func my_univ(T) = my_univ <= fooable(T). + +:- some [T] func call_my_univ_value(my_univ) = T => fooable(T). + +:- some [T] func my_exist_t = T => fooable(T). + +:- some [T] func call_my_exist_t = T => fooable(T). + +:- pred int_foo(int::in, int::out) is det. +int_foo(X, 2*X). + +:- pred string_foo(string::in, int::out) is det. +string_foo(S, N) :- string__length(S, N). + +main --> + do_foo(42), + do_foo("blah"), + do_foo(my_exist_t), + do_foo(call_my_exist_t), + do_foo(my_univ_value(my_univ(45))), + do_foo(call_my_univ_value(my_univ("something"))). + +:- pred do_foo(T::in, io__state::di, state::uo) is det <= fooable(T). +do_foo(X) --> + { foo(X, N) }, + write(N), nl. + +call_my_exist_t = my_exist_t. + +call_my_univ_value(Univ) = my_univ_value(Univ). + +my_exist_t = 43. + +my_univ_value(make_my_univ(X)) = X. + +/* +** Construction of existentially typed data types are not yet implemented, +** so we have to use the C interface. +*/ +% my_univ(X) = make_my_univ(X). +:- pragma c_code(my_univ(Value::in) = (Univ::out), will_not_call_mercury, " + incr_hp(Univ, 2); + field(mktag(0), Univ, 0) = (Word) + TypeClassInfo_for_existential_data_types__fooable_T; + field(mktag(0), Univ, 1) = (Word) Value; + +"). diff --git a/tests/invalid/Mmakefile b/tests/invalid/Mmakefile index e9989c72e..888902734 100644 --- a/tests/invalid/Mmakefile +++ b/tests/invalid/Mmakefile @@ -19,6 +19,7 @@ SOURCES= \ errors2.m \ external.m \ ext_type_bug.m \ + ext_data_type.m \ func_errors.m \ funcs_as_preds.m \ ho_type_mode_bug.m \ @@ -94,13 +95,6 @@ ERR_RESS= $(SOURCES:%.m=%.err_res) if $(MC) $(ALL_MCFLAGS) --errorcheck-only $* > $*.err 2>&1; \ then false; else true; fi -# We need a hard-coded rule for polymorphic_unification because we need to -# do more than error check it: the error case we are checking for only -# gets caught during polymorphism. -polymorphic_unification.err: polymorphic_unification.m - if $(MC) $(ALL_MCFLAGS) polymorphic_unification > polymorphic_unification.err 2>&1; \ - then false; else true; fi - # Some tests have more than one possible valid output, so # we allow the test to pass if it matches *either* the .err_exp # or the .err_exp2 file. diff --git a/tests/invalid/errors2.err_exp2 b/tests/invalid/errors2.err_exp2 new file mode 100644 index 000000000..4ba9ba6ae --- /dev/null +++ b/tests/invalid/errors2.err_exp2 @@ -0,0 +1,58 @@ +errors2.m: 1: Warning: interface for module `errors2' does not export anything. +errors2.m:009: Error: clause for predicate `errors2:bind_type_param/1' +errors2.m:009: without preceding `pred' declaration. +errors2.m:052: In clause for predicate `errors2:type_error_4/0': +errors2.m:052: warning: variable `X' occurs only once in this scope. +errors2.m:059: In clause for predicate `errors2:type_error_5/0': +errors2.m:059: warning: variable `X' occurs only once in this scope. +errors2.m:065: In clause for predicate `errors2:type_error_6/0': +errors2.m:065: warning: variable `X' occurs only once in this scope. +errors2.m:070: In clause for predicate `errors2:type_error_7/0': +errors2.m:070: warning: variable `Y' occurs only once in this scope. +errors2.m:071: In clause for predicate `errors2:type_error_7/0': +errors2.m:071: warning: variables `Z, A, B' occur only once in this scope. +errors2.m:007: Error: no clauses for predicate `errors2:bind_type_param/2' +errors2.m:023: Error: no clauses for predicate `errors2:produce_string/1' +errors2.m:025: Error: no clauses for predicate `errors2:expect_int/1' +errors2.m:031: In clause for predicate `errors2:type_error/0': +errors2.m:031: in argument 1 of call to pred `expect_int/1': +errors2.m:031: type error: variable `X' has type `string', +errors2.m:031: expected type was `int'. +errors2.m:037: In clause for predicate `errors2:type_error_2/0': +errors2.m:037: type error in unification of variable `X' +errors2.m:037: and variable `Y'. +errors2.m:037: `X' has type `string', +errors2.m:037: `Y' has type `int'. +errors2.m:043: In clause for predicate `errors2:type_error_3/0': +errors2.m:043: in argument 1 of call to pred `expect_int/1': +errors2.m:043: type error: variable `Y' has type `string', +errors2.m:043: expected type was `int'. +errors2.m:052: In clause for predicate `errors2:type_error_4/0': +errors2.m:052: in argument 3 of functor `foo_functor/3': +errors2.m:052: type error in unification of argument +errors2.m:052: and constant `1.00000000000000'. +errors2.m:052: argument has type `string', +errors2.m:052: constant `1.00000000000000' has type `float'. +errors2.m:059: In clause for predicate `errors2:type_error_5/0': +errors2.m:059: in argument 3 of functor `foo_functor/3': +errors2.m:059: type error in unification of argument +errors2.m:059: and constant `1.00000000000000'. +errors2.m:059: argument has type `string', +errors2.m:059: constant `1.00000000000000' has type `float'. +errors2.m:065: In clause for predicate `errors2:type_error_6/0': +errors2.m:065: in argument 3 of functor `bar_functor/3': +errors2.m:065: type error in unification of argument +errors2.m:065: and constant `1.00000000000000'. +errors2.m:065: argument has type `string', +errors2.m:065: constant `1.00000000000000' has type `float'. +errors2.m:072: In clause for predicate `errors2:type_error_7/0': +errors2.m:072: in argument 1 of call to pred `expect_int/1': +errors2.m:072: type error: variable `C' has type `string', +errors2.m:072: expected type was `int'. +errors2.m:078: In clause for predicate `errors2:type_error_8/0': +errors2.m:078: in argument 1 of call to predicate `from_char_list/2': +errors2.m:078: error: undefined symbol `[]/0'. +errors2.m:078: In clause for predicate `errors2:type_error_8/0': +errors2.m:078: error: undefined predicate `from_char_list/2'. +errors2.m:009: Inferred :- pred bind_type_param(int). +For more information, try recompiling with `-E'. diff --git a/tests/invalid/polymorphic_unification.err_exp b/tests/invalid/polymorphic_unification.err_exp index b13ffe0e2..a0a4c99f9 100644 --- a/tests/invalid/polymorphic_unification.err_exp +++ b/tests/invalid/polymorphic_unification.err_exp @@ -1,2 +1,6 @@ -Software error: polymorphic_unification.m:019: Sorry, not implemented: polymorphic unification in mode other than (in, in) -Stack dump not available in this grade. +polymorphic_unification.m:019: In clause for `p(in, ((list:list_skel) -> dead))': +polymorphic_unification.m:019: in argument 2 of clause head: +polymorphic_unification.m:019: in polymorphically-typed unification: +polymorphic_unification.m:019: mode error: variable `HeadVar__2' has instantiatedness `(list:list_skel)', +polymorphic_unification.m:019: expected instantiatedness was `ground' or `any'. +For more information, try recompiling with `-E'. diff --git a/tests/invalid/prog_io_erroneous.err_exp2 b/tests/invalid/prog_io_erroneous.err_exp2 new file mode 100644 index 000000000..026a80770 --- /dev/null +++ b/tests/invalid/prog_io_erroneous.err_exp2 @@ -0,0 +1,3 @@ +prog_io_erroneous.m: 1: Warning: interface for module `prog_io_erroneous' does not export anything. +prog_io_erroneous.m:012: Error: no clauses for predicate `prog_io_erroneous:q/2' +For more information, try recompiling with `-E'. diff --git a/tests/invalid/type_inf_loop.err_exp2 b/tests/invalid/type_inf_loop.err_exp2 new file mode 100644 index 000000000..b2d95c629 --- /dev/null +++ b/tests/invalid/type_inf_loop.err_exp2 @@ -0,0 +1,10 @@ +type_inf_loop.m: 1: Warning: interface for module `type_inf_loop' does not export anything. +type_inf_loop.m:004: Error: clause for predicate `type_inf_loop:loop/1' +type_inf_loop.m:004: without preceding `pred' declaration. +Type inference iteration limit exceeded. +This probably indicates that your program has a type error. +You should declare the types explicitly. +(The current limit is 60 iterations. You can use the +`--type-inference-iteration-limit' option to increase the limit). +type_inf_loop.m:004: Inferred :- pred loop((pred (pred (pred (pred (pred (pred (pred (pred (pred (pred (pred (pred (pred (pred (pred (pred (pred (pred (pred (pred (pred (pred (pred (pred (pred (pred (pred (pred (pred (pred (pred (pred (pred (pred (pred (pred (pred (pred (pred (pred (pred (pred (pred (pred (pred (pred (pred (pred (pred (pred (pred (pred (pred (pred (pred (pred (pred (pred (pred (pred T1))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))). +For more information, try recompiling with `-E'. diff --git a/tests/invalid/types.err_exp2 b/tests/invalid/types.err_exp2 new file mode 100644 index 000000000..319ae4a48 --- /dev/null +++ b/tests/invalid/types.err_exp2 @@ -0,0 +1,25 @@ +types.m: 1: Warning: interface for module `types' does not export anything. +types.m:003: Error: constructor `types:a/0' for type `types:t/0' multiply defined. +types.m:003: Error: constructor `types:f/1' for type `types:t/0' multiply defined. +types.m:017: Error: clause for predicate `types:r/0' +types.m:017: without preceding `pred' declaration. +types.m:020: Error: clause for predicate `types:a/1' +types.m:020: without preceding `pred' declaration. +types.m:005: Error: no clauses for predicate `types:p/1' +types.m:012: In clause for predicate `types:q/0': +types.m:012: error: undefined predicate `zzzzzzzz/0'. +types.m:013: In clause for predicate `types:q/0': +types.m:013: in argument 1 of call to pred `p/1': +types.m:013: type error: argument has type `int', +types.m:013: expected type was `(pred)'. +types.m:039: In clause for predicate `types:bar/1': +types.m:039: type error in unification of variable `X' +types.m:039: and constant `0'. +types.m:039: variable `X' has type `BarTypeParam', +types.m:039: constant `0' has type `int'. +types.m:050: Error: no clauses for predicate `types:bar2/1' +types.m:018: In clause for predicate `types:r/0': +types.m:018: error: undefined predicate `s/0'. +types.m:020: In clause for predicate `types:a/1': +types.m:020: error: undefined predicate `b/1'. +For more information, try recompiling with `-E'. diff --git a/tests/term/arit_exp.trans_opt_exp b/tests/term/arit_exp.trans_opt_exp index 09bf2ef12..7d27768f1 100644 --- a/tests/term/arit_exp.trans_opt_exp +++ b/tests/term/arit_exp.trans_opt_exp @@ -1,2 +1,3 @@ :- module arit_exp. :- pragma termination_info(arit_exp:e((builtin:in)), finite(0, [no]), cannot_loop). +:- pragma termination_info(arit_exp:f((builtin:in)), finite(0, [no]), cannot_loop). diff --git a/tests/term/associative.trans_opt_exp b/tests/term/associative.trans_opt_exp index 2d52c68de..9e0bff4ad 100644 --- a/tests/term/associative.trans_opt_exp +++ b/tests/term/associative.trans_opt_exp @@ -1,2 +1,3 @@ :- module associative. :- pragma termination_info(associative:normal_form((builtin:in), (builtin:out)), finite(0, [yes, no]), can_loop). +:- pragma termination_info(associative:rewrite((builtin:in), (builtin:out)), finite(0, [yes, no]), cannot_loop). diff --git a/tests/term/pl5_2_2.trans_opt_exp b/tests/term/pl5_2_2.trans_opt_exp index ea021b229..8a95d1938 100644 --- a/tests/term/pl5_2_2.trans_opt_exp +++ b/tests/term/pl5_2_2.trans_opt_exp @@ -1,2 +1,3 @@ :- module pl5_2_2. :- pragma termination_info(pl5_2_2:turing((builtin:in), (builtin:in), (builtin:in), (builtin:out)), infinite, can_loop). +:- pragma termination_info(pl5_2_2:member((builtin:out), (builtin:in)), finite(-1, [no, no, yes]), cannot_loop). diff --git a/tests/term/vangelder.trans_opt_exp b/tests/term/vangelder.trans_opt_exp index 861a10c5a..795dcaf5a 100644 --- a/tests/term/vangelder.trans_opt_exp +++ b/tests/term/vangelder.trans_opt_exp @@ -1,2 +1,4 @@ :- module vangelder. :- pragma termination_info(vangelder:q((builtin:in), (builtin:in)), finite(0, [no, no]), can_loop). +:- pragma termination_info(vangelder:p((builtin:in), (builtin:in)), finite(0, [no, no]), can_loop). +:- pragma termination_info(vangelder:e((builtin:in), (builtin:in)), finite(0, [no, no]), cannot_loop). diff --git a/tests/warnings/simple_code.exp b/tests/warnings/simple_code.exp index 99f33213a..9c8b6ed1f 100644 --- a/tests/warnings/simple_code.exp +++ b/tests/warnings/simple_code.exp @@ -5,9 +5,6 @@ simple_code.m:042: Warning: the condition of this if-then-else cannot fail. simple_code.m:020: Warning: the condition of this if-then-else cannot succeed. simple_code.m:025: Warning: the condition of this if-then-else cannot succeed. simple_code.m:030: Warning: the condition of this if-then-else cannot succeed. -simple_code.m:018: Warning: the negated goal cannot succeed. -simple_code.m:023: Warning: the negated goal cannot succeed. simple_code.m:033: Warning: the negated goal cannot succeed. -simple_code.m:038: Warning: the negated goal cannot succeed. simple_code.m:039: Warning: call to obsolete predicate `simple_code:obsolete/0'. simple_code.m:099: Warning: recursive call will lead to infinite recursion.