[m-rev.] for review: support currying multi-modes preds in special case

Peter Wang novalazy at gmail.com
Wed Apr 16 16:18:06 AEST 2008


Estimated hours taken: 15
Branches: main

Support currying of multi-moded predicates or functions when the mode to curry
can be determined from the insts of the higher-order arguments. e.g.

	mymap(P, L0, L) :-
	    map(wrap(P), L0, L).

	:- pred wrap(...).
	:- mode wrap(in(pred(...) is det), ...) is det.
	:- mode wrap(in(pred(...) is cc_multi, ...) is cc_multi.
	...

compiler/post_typecheck.m:
	Don't abort immediately on taking the address of a multi-moded
	predicate.  Leave the proc_id as invalid_proc_id and handle that
	in polymorphism.m.

compiler/polymorphism.m:
	Convert higher order terms to lambda goals even if the proc_id is
	invalid (as above) moded by arbitrarily using the first mode.  Then
	polymorphism can proceed as usual.  Mark the goals with feature
	`feature_lambda_undetermined_mode', which tells mode checking to
	handle it.

	Add a predicate to fix up such lambda goals once mode checking does
	figure out which mode should be called.

compiler/modecheck_unify.m:
compiler/mode_errors.m:
	Handle goals with the `feature_lambda_undetermined_mode'.  Try to
	select a unique mode for the curried predicate then fix up the lambda
	goal.

compiler/hlds_goal.m:
compiler/saved_vars.m:
	Add `feature_lambda_undetermined_mode'.

compiler/goal_util.m:
	Add a predicate to return all the pred_ids called in a goal
	with the associated argument variables.

NEWS:
doc/reference_manual.texi:
	Document and announce the change.

tests/hard_coded/Mmakefile:
tests/hard_coded/multimode_addr.exp:
tests/hard_coded/multimode_addr.m:
tests/invalid/Mmakefile:
tests/invalid/multimode_addr_problems.err_exp:
tests/invalid/multimode_addr_problems.m:
	Add tests.

Index: NEWS
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/NEWS,v
retrieving revision 1.488
diff -u -r1.488 NEWS
--- NEWS	3 Apr 2008 05:26:42 -0000	1.488
+++ NEWS	16 Apr 2008 06:15:15 -0000
@@ -24,6 +24,9 @@
 * We now support higher-order `any' insts.
 * We now support "implementation-defined literals", such as `$file', `$line',
   `$pred', which are useful for producing better run-time error messages.
+* We now support currying of multi-moded predicates or functions when the
+  mode to curry can be determined from the insts of the higher-order
+  arguments.
 
 Changes to the Mercury standard library:
 
Index: compiler/goal_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/goal_util.m,v
retrieving revision 1.157
diff -u -r1.157 goal_util.m
--- compiler/goal_util.m	27 Feb 2008 07:23:05 -0000	1.157
+++ compiler/goal_util.m	16 Apr 2008 06:15:15 -0000
@@ -191,6 +191,11 @@
     %
 :- pred predids_from_goal(hlds_goal::in, list(pred_id)::out) is det.
 
+    % Returns all the predids that are called along with the list of
+    % arguments.
+:- pred predids_with_args_from_goal(hlds_goal::in,
+    list({pred_id, prog_vars})::out) is det.
+
     % Returns all the predids that are used in a list of goals.
     %
 :- pred predids_from_goals(hlds_goals::in, list(pred_id)::out) is det.
@@ -1616,6 +1621,13 @@
     P = (pred(PredId::out) is nondet :- goal_calls_pred_id(Goal, PredId)),
     solutions.solutions(P, PredIds).
 
+predids_with_args_from_goal(Goal, List) :-
+    solutions(
+        (pred({PredId, Args}::out) is nondet :-
+            goal_contains_goal(Goal, hlds_goal(SubGoal, _)),
+            SubGoal = plain_call(PredId, _, Args, _, _, _)
+        ), List).
+
 pred_proc_ids_from_goal(Goal, PredProcIds) :-
     P = (pred(PredProcId::out) is nondet :- goal_calls(Goal, PredProcId)),
     solutions.solutions(P, PredProcIds).
Index: compiler/hlds_goal.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/hlds_goal.m,v
retrieving revision 1.189
diff -u -r1.189 hlds_goal.m
--- compiler/hlds_goal.m	27 Feb 2008 07:23:06 -0000	1.189
+++ compiler/hlds_goal.m	16 Apr 2008 06:15:16 -0000
@@ -571,6 +571,10 @@
                 rhs_lambda_goal     :: hlds_goal
             ).
 
+:- inst rhs_lambda_goal
+    --->    rhs_lambda_goal(ground, ground, ground, ground, ground, ground,
+                ground, ground, ground). 
+
     % Was the constructor originally of the form 'new ctor'(...).
     %
 :- type is_existential_construction == bool.
@@ -1308,7 +1312,7 @@
             % This goal contains a scope goal whose scope_reason is
             % trace_goal(...).
 
-    ;       feature_pretest_equality.
+    ;       feature_pretest_equality
             % This goal is an if-then-else in a compiler-generated
             % type-constructor-specific unify or compare predicate
             % whose condition is a test of whether the two input arguments
@@ -1316,6 +1320,13 @@
             % circumstances we need to strip off this pretest, and replace
             % the if-then-else with just its else branch.
 
+    ;       feature_lambda_undetermined_mode.
+            % This goal is a lambda goal converted from a higher order term
+            % for which we don't know the mode of the call to the underlying
+            % predicate. These can be produced by the polymorphism
+            % transformation but should be removed by the end of mode
+            % checking.
+
 %-----------------------------------------------------------------------------%
 %
 % The rename_var* predicates take a structure and a mapping from var -> var
Index: compiler/mode_errors.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mode_errors.m,v
retrieving revision 1.125
diff -u -r1.125 mode_errors.m
--- compiler/mode_errors.m	7 Apr 2008 02:32:51 -0000	1.125
+++ compiler/mode_errors.m	16 Apr 2008 06:15:16 -0000
@@ -124,6 +124,15 @@
             % Some sort of error in attempt to unify a variable with lambda
             % expression.
 
+    ;       mode_error_unify_var_multimode_pred(prog_var, pred_id)
+            % Some sort of error in attempt to take address of a multi-moded
+            % predicate.
+
+    ;       mode_error_unify_var_multimode_pred_undetermined(prog_var,
+                pred_id)
+            % Attempt to take address of a multi-moded predicate where we
+            % could not uniquely determine the mode to use.
+
     ;       mode_error_conj(list(delayed_goal), schedule_culprit)
             % A conjunction contains one or more unscheduleable goals;
             % schedule_culprit gives the reason why they couldn't be scheduled.
@@ -310,6 +319,15 @@
         Spec = mode_error_unify_var_lambda_to_spec(ModeInfo, VarA,
             InstA, InstB)
     ;
+        ModeError = mode_error_unify_var_multimode_pred(VarA, PredId),
+        Spec = mode_error_unify_var_multimode_pred_to_spec(ModeInfo, VarA,
+            PredId)
+    ;
+        ModeError = mode_error_unify_var_multimode_pred_undetermined(VarA,
+            PredId),
+        Spec = mode_error_unify_var_multimode_pred_undetermined_to_spec(
+            ModeInfo, VarA, PredId)
+    ;
         ModeError = mode_error_unify_var_functor(Var, Name, Args, Inst,
             ArgInsts),
         Spec = mode_error_unify_var_functor_to_spec(ModeInfo, Var, Name,
@@ -940,6 +958,68 @@
 
 %-----------------------------------------------------------------------------%
 
+:- func mode_error_unify_var_multimode_pred_to_spec(mode_info, prog_var,
+    pred_id) = error_spec.
+
+mode_error_unify_var_multimode_pred_to_spec(ModeInfo, X, PredId) = Spec :-
+    Preamble = mode_info_context_preamble(ModeInfo),
+    mode_info_get_context(ModeInfo, Context),
+    mode_info_get_varset(ModeInfo, VarSet),
+    mode_info_get_module_info(ModeInfo, ModuleInfo),
+    module_info_pred_info(ModuleInfo, PredId, PredInfo),
+    PredOrFunc = pred_info_is_pred_or_func(PredInfo),
+    PredModule = pred_info_module(PredInfo),
+    PredName = pred_info_name(PredInfo),
+    QualifiedName = qualified(PredModule, PredName),
+    Arity = pred_info_orig_arity(PredInfo),
+    (
+        PredOrFunc = pf_predicate,
+        Arity1 = Arity
+    ;
+        PredOrFunc = pf_function,
+        Arity1 = Arity - 1
+    ),
+    Pieces = [words("mode error in unification of"),
+        words(add_quotes(mercury_var_to_string(VarSet, no, X))),
+        words("and higher-order term based on multi-moded"),
+        p_or_f(PredOrFunc), sym_name_and_arity(QualifiedName / Arity1),
+        suffix("."), nl],
+    Spec = error_spec(severity_error, phase_mode_check(report_in_any_mode),
+        [simple_msg(Context, [always(Preamble ++ Pieces)])]).
+
+:- func mode_error_unify_var_multimode_pred_undetermined_to_spec(mode_info,
+    prog_var, pred_id) = error_spec.
+
+mode_error_unify_var_multimode_pred_undetermined_to_spec(ModeInfo, X, PredId)
+        = Spec :-
+    Preamble = mode_info_context_preamble(ModeInfo),
+    mode_info_get_context(ModeInfo, Context),
+    mode_info_get_varset(ModeInfo, VarSet),
+    mode_info_get_module_info(ModeInfo, ModuleInfo),
+    module_info_pred_info(ModuleInfo, PredId, PredInfo),
+    PredOrFunc = pred_info_is_pred_or_func(PredInfo),
+    PredModule = pred_info_module(PredInfo),
+    PredName = pred_info_name(PredInfo),
+    QualifiedName = qualified(PredModule, PredName),
+    Arity = pred_info_orig_arity(PredInfo),
+    (
+        PredOrFunc = pf_predicate,
+        Arity1 = Arity
+    ;
+        PredOrFunc = pf_function,
+        Arity1 = Arity - 1
+    ),
+    Pieces = [words("In unification of"),
+        words(add_quotes(mercury_var_to_string(VarSet, no, X))),
+        words("and higher-order term."),
+        words("Could not determine the mode of"),
+        p_or_f(PredOrFunc), sym_name_and_arity(QualifiedName / Arity1),
+        words("by the insts of the higher-order arguments only."), nl],
+    Spec = error_spec(severity_error, phase_mode_check(report_in_any_mode),
+        [simple_msg(Context, [always(Preamble ++ Pieces)])]).
+
+%-----------------------------------------------------------------------------%
+
 :- func mode_error_unify_var_functor_to_spec(mode_info, prog_var,
     cons_id, list(prog_var), mer_inst, list(mer_inst)) = error_spec.
 
Index: compiler/modecheck_unify.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/modecheck_unify.m,v
retrieving revision 1.125
diff -u -r1.125 modecheck_unify.m
--- compiler/modecheck_unify.m	11 Feb 2008 21:26:05 -0000	1.125
+++ compiler/modecheck_unify.m	16 Apr 2008 06:15:16 -0000
@@ -56,6 +56,7 @@
 :- import_module check_hlds.type_util.
 :- import_module check_hlds.unify_proc.
 :- import_module check_hlds.unique_modes.
+:- import_module hlds.goal_util.
 :- import_module hlds.hlds_goal.
 :- import_module hlds.hlds_module.
 :- import_module hlds.hlds_pred.
@@ -270,7 +271,23 @@
             UnifyContext, GoalInfo0, Goal, !ModeInfo, !IO)
     ).
 
-modecheck_unification_2(X, LambdaGoal, Unification0, UnifyContext, _GoalInfo,
+modecheck_unification_2(X, LambdaGoal, Unification0, UnifyContext, GoalInfo,
+        Goal, !ModeInfo, !IO) :-
+    LambdaGoal = rhs_lambda_goal(_, _, _, _, _, _, _, _, _),
+    ( goal_info_has_feature(GoalInfo, feature_lambda_undetermined_mode) ->
+        modecheck_unification_rhs_undetermined_mode_lambda(X, LambdaGoal,
+            Unification0, UnifyContext, GoalInfo, Goal, !ModeInfo, !IO)
+    ;
+        modecheck_unification_rhs_lambda(X, LambdaGoal, Unification0,
+            UnifyContext, GoalInfo, Goal, !ModeInfo, !IO)
+    ).
+
+:- pred modecheck_unification_rhs_lambda(prog_var::in,
+    unify_rhs::in(rhs_lambda_goal), unification::in, unify_context::in,
+    hlds_goal_info::in, hlds_goal_expr::out, mode_info::in, mode_info::out,
+    io::di, io::uo) is det.
+
+modecheck_unification_rhs_lambda(X, LambdaGoal, Unification0, UnifyContext, _,
         unify(X, RHS, Mode, Unification, UnifyContext), !ModeInfo, !IO) :-
     LambdaGoal = rhs_lambda_goal(Purity, Groundness, PredOrFunc, EvalMethod,
         ArgVars, Vars, Modes0, Det, Goal0),
@@ -500,6 +517,53 @@
         RHS = RHS0
     ).
 
+:- pred modecheck_unification_rhs_undetermined_mode_lambda(prog_var::in,
+    unify_rhs::in(rhs_lambda_goal), unification::in, unify_context::in,
+    hlds_goal_info::in, hlds_goal_expr::out, mode_info::in, mode_info::out,
+    io::di, io::uo) is det.
+
+modecheck_unification_rhs_undetermined_mode_lambda(X, LambdaGoal0, Unification,
+        UnifyContext, GoalInfo0, Goal, !ModeInfo, !IO) :-
+    LambdaGoal0 = rhs_lambda_goal(_, _, _, _, _, _, _, _, Goal0),
+    % Find out the predicate called in the lambda goal.
+    ( predids_with_args_from_goal(Goal0, [{PredId, ArgVars}]) ->
+        mode_info_get_module_info(!.ModeInfo, ModuleInfo),
+        mode_info_get_instmap(!.ModeInfo, InstMap),
+        mode_info_get_var_types(!.ModeInfo, VarTypes),
+        module_info_pred_info(ModuleInfo, PredId, PredInfo),
+        match_modes_by_higher_order_insts(ModuleInfo, InstMap, VarTypes,
+            ArgVars, PredInfo, MatchResult),
+        (
+            ( MatchResult = possible_modes([])
+            ; MatchResult = ho_arg_not_ground
+            ),
+            mode_info_error(set.make_singleton_set(X),
+                mode_error_unify_var_multimode_pred(X, PredId), !ModeInfo),
+            % Return any old garbage.
+            Goal = true_goal_expr
+        ;
+            MatchResult = possible_modes([ProcId]),
+            fix_undetermined_mode_lambda_goal(ProcId, LambdaGoal0, LambdaGoal,
+                ModuleInfo),
+            goal_info_remove_feature(feature_lambda_undetermined_mode,
+                GoalInfo0, GoalInfo),
+            % Modecheck this unification in its new form.
+            modecheck_unification_2(X, LambdaGoal, Unification, UnifyContext,
+                GoalInfo, Goal, !ModeInfo, !IO)
+        ;
+            MatchResult = possible_modes([_, _ | _]),
+            mode_info_error(set.make_singleton_set(X), 
+                mode_error_unify_var_multimode_pred_undetermined(X, PredId),
+                !ModeInfo),
+            % Return any old garbage.
+            Goal = true_goal_expr
+        )
+    ;
+        unexpected(this_file,
+            "modecheck_unification_rhs_undetermined_mode_lambda: " ++
+            "expecting single call")
+    ).
+
 :- pred modecheck_unify_functor(prog_var::in, mer_type::in, cons_id::in,
     is_existential_construction::in, list(prog_var)::in, unification::in,
     unify_context::in, hlds_goal_info::in, hlds_goal_expr::out,
@@ -1382,6 +1446,89 @@
 
 %-----------------------------------------------------------------------------%
 
+:- type match_modes_result
+    --->    possible_modes(list(proc_id))
+    ;       ho_arg_not_ground.
+
+:- type match_mode_result
+    --->    ho_insts_match
+    ;       ho_insts_do_not_match
+    ;       ho_arg_not_ground.
+
+:- pred match_modes_by_higher_order_insts(module_info::in, instmap::in,
+    vartypes::in, prog_vars::in, pred_info::in, match_modes_result::out) is det.
+
+match_modes_by_higher_order_insts(ModuleInfo, InstMap, VarTypes, ArgVars,
+        CalleePredInfo, Result) :-
+    CalleeProcIds = pred_info_procids(CalleePredInfo),
+    match_modes_by_higher_order_insts_2(ModuleInfo, InstMap, VarTypes,
+        ArgVars, CalleePredInfo, CalleeProcIds, [], Result).
+
+:- pred match_modes_by_higher_order_insts_2(module_info::in, instmap::in,
+    vartypes::in, prog_vars::in, pred_info::in, list(proc_id)::in,
+    list(proc_id)::in, match_modes_result::out) is det.
+
+match_modes_by_higher_order_insts_2(_, _, _, _, _,
+        [], RevMatchedProcIds, Result) :-
+    Result = possible_modes(list.reverse(RevMatchedProcIds)).
+match_modes_by_higher_order_insts_2(ModuleInfo, InstMap, VarTypes,
+        ArgVars, PredInfo, [ProcId | ProcIds], RevMatchedProcIds, Result) :-
+    pred_info_proc_info(PredInfo, ProcId, ProcInfo),
+    proc_info_get_argmodes(ProcInfo, ArgModes),
+    match_mode_by_higher_order_insts(ModuleInfo, InstMap, VarTypes, ArgVars,
+        ArgModes, ProcResult),
+    (
+        ProcResult = ho_insts_match,
+        match_modes_by_higher_order_insts_2(ModuleInfo, InstMap,
+            VarTypes, ArgVars, PredInfo, ProcIds, [ProcId | RevMatchedProcIds],
+            Result)
+    ;
+        ProcResult = ho_insts_do_not_match,
+        match_modes_by_higher_order_insts_2(ModuleInfo, InstMap, VarTypes,
+            ArgVars, PredInfo, ProcIds, RevMatchedProcIds, Result)
+    ;
+        ProcResult = ho_arg_not_ground,
+        Result = ho_arg_not_ground
+    ).
+
+:- pred match_mode_by_higher_order_insts(module_info::in, instmap::in,
+    vartypes::in, prog_vars::in, list(mer_mode)::in, match_mode_result::out)
+    is det.
+
+match_mode_by_higher_order_insts(_ModuleInfo, _InstMap, _VarTypes,
+        [], _, ho_insts_match).
+match_mode_by_higher_order_insts(ModuleInfo, InstMap, VarTypes,
+        [Arg | Args], ArgModesList, Result) :-
+    (
+        ArgModesList = [ArgMode | ArgModes]
+    ;
+        ArgModesList = [],
+        unexpected(this_file,
+            "args_match_higher_order_insts: too many arguments")
+    ),
+
+    % For arguments with higher order initial insts, check if the variable in
+    % that position has a matching inst. If the variable is free then we need
+    % to delay the goal.
+    Initial = mode_get_initial_inst(ModuleInfo, ArgMode),
+    ( Initial = ground(_, higher_order(_)) ->
+        instmap.lookup_var(InstMap, Arg, ArgInst),
+        map.lookup(VarTypes, Arg, ArgType),
+        ( inst_matches_initial(ArgInst, Initial, ArgType, ModuleInfo) ->
+            match_mode_by_higher_order_insts(ModuleInfo, InstMap, VarTypes,
+                Args, ArgModes, Result)
+        ; not inst_is_ground(ModuleInfo, ArgInst) ->
+            Result = ho_arg_not_ground
+        ;
+            Result = ho_insts_do_not_match
+        )
+    ;
+        match_mode_by_higher_order_insts(ModuleInfo, InstMap, VarTypes, Args,
+            ArgModes, Result)
+    ).
+
+%-----------------------------------------------------------------------------%
+
 :- pred bind_args(mer_inst::in, list(prog_var)::in, list(maybe(mer_inst))::in,
     mode_info::in, mode_info::out) is det.
 
Index: compiler/polymorphism.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/polymorphism.m,v
retrieving revision 1.332
diff -u -r1.332 polymorphism.m
--- compiler/polymorphism.m	7 Apr 2008 02:32:51 -0000	1.332
+++ compiler/polymorphism.m	16 Apr 2008 06:15:17 -0000
@@ -322,6 +322,16 @@
     module_info::in, unify_rhs::out, prog_varset::in, prog_varset::out,
     vartypes::in, vartypes::out) is det.
 
+    % fix_undetermined_mode_lambda_goal(ProcId, Functor0, Functor, ModuleInfo)
+    %
+    % This is called by mode checking when it figures out which mode that a
+    % lambda goal converted from a higher order pred term should call.
+    % Functor0 must have been produced by `convert_pred_to_lambda_goal'.
+    %
+:- pred fix_undetermined_mode_lambda_goal(proc_id::in,
+    unify_rhs::in(rhs_lambda_goal), unify_rhs::out(rhs_lambda_goal),
+    module_info::in) is det.
+
     % init_type_info_var(Type, ArgVars, TypeInfoVar, TypeInfoGoal,
     %   !VarSet, !VarTypes) :-
     %
@@ -1302,19 +1312,39 @@
         % Check if variable has a higher order type.
         type_is_higher_order_details(TypeOfX, Purity, _PredOrFunc, EvalMethod,
             CalleeArgTypes),
-        ConsId0 = pred_const(ShroudedPredProcId, _)
+        ConsId0 = pred_const(ShroudedPredProcId, _),
+        proc(PredId, ProcId0) = unshroud_pred_proc_id(ShroudedPredProcId)
     ->
+        % An `invalid_proc_id' means the predicate is multi-moded. We can't
+        % pick the right mode yet. Perform the rest of the transformation with
+        % any mode (the first) but mark the goal with a feature so that mode
+        % checking knows to fix it up later.
+        ( ProcId0 = invalid_proc_id ->
+            module_info_pred_info(ModuleInfo0, PredId, PredInfo),
+            ProcIds = pred_info_procids(PredInfo),
+            (
+                ProcIds = [ProcId | _],
+                goal_info_add_feature(feature_lambda_undetermined_mode,
+                    GoalInfo0, GoalInfo1)
+            ;
+                ProcIds = [],
+                unexpected(this_file,
+                    "polymorphism_process_unify_functor: no modes")
+            )
+        ;
+            ProcId = ProcId0,
+            GoalInfo1 = GoalInfo0
+        ),
         % Convert the higher order pred term to a lambda goal.
         poly_info_get_varset(!.Info, VarSet0),
         Context = goal_info_get_context(GoalInfo0),
-        proc(PredId, ProcId) = unshroud_pred_proc_id(ShroudedPredProcId),
         convert_pred_to_lambda_goal(Purity, EvalMethod, X0, PredId, ProcId,
-            ArgVars0, CalleeArgTypes, UnifyContext, GoalInfo0, Context,
+            ArgVars0, CalleeArgTypes, UnifyContext, GoalInfo1, Context,
             ModuleInfo0, Functor0, VarSet0, VarSet, VarTypes0, VarTypes),
         poly_info_set_varset_and_types(VarSet, VarTypes, !Info),
         % Process the unification in its new form.
         polymorphism_process_unify(X0, Functor0, Mode0, Unification0,
-            UnifyContext, GoalInfo0, Goal, !Info)
+            UnifyContext, GoalInfo1, Goal, !Info)
     ;
         % Is this a construction or deconstruction of an existentially
         % typed data type?
@@ -1410,13 +1440,66 @@
 
     % Work out the modes of the introduced lambda variables and the determinism
     % of the lambda goal.
+    lambda_modes_and_det(ProcInfo, LambdaVars, LambdaModes, LambdaDet),
+
+    % Construct the lambda expression.
+
+    PredOrFunc = pred_info_is_pred_or_func(PredInfo),
+    % Higher-order values created in this fashion are always ground.
+    Groundness = ho_ground,
+    Functor = rhs_lambda_goal(Purity, Groundness, PredOrFunc, EvalMethod,
+        ArgVars0, LambdaVars, LambdaModes, LambdaDet, LambdaGoal).
+
+fix_undetermined_mode_lambda_goal(ProcId, Functor0, Functor, ModuleInfo) :-
+    Functor0 = rhs_lambda_goal(Purity, Groundness, PredOrFunc, EvalMethod,
+        ArgVars0, LambdaVars, _LambdaModes0, _LambdaDet0, LambdaGoal0),
+    LambdaGoal0 = hlds_goal(_, LambdaGoalInfo),
+    goal_to_conj_list(LambdaGoal0, LambdaGoalList0),
+    (
+        list.split_last(LambdaGoalList0, LambdaGoalButLast0, LastGoal0),
+        LastGoal0 = hlds_goal(LastGoalExpr0, LastGoalInfo0),
+        LastGoalExpr0 = plain_call(PredId0, _DummyProcId, Args0, not_builtin,
+            MaybeCallUnifyContext0, QualifiedPName0)
+    ->
+        LambdaGoalButLast = LambdaGoalButLast0,
+        LastGoalInfo = LastGoalInfo0,
+        PredId = PredId0,
+        Args = Args0,
+        MaybeCallUnifyContext = MaybeCallUnifyContext0,
+        QualifiedPName = QualifiedPName0
+    ;
+        unexpected(this_file,
+            "fix_undetermined_mode_lambda_goal: unmatched lambda goal")
+    ),
+
+    module_info_pred_proc_info(ModuleInfo, PredId, ProcId, _, ProcInfo),
+
+    % Build up the lambda goal.
+    LastGoalExpr = plain_call(PredId, ProcId, Args, not_builtin,
+        MaybeCallUnifyContext, QualifiedPName),
+    LastGoal = hlds_goal(LastGoalExpr, LastGoalInfo),
+    conj_list_to_goal(LambdaGoalButLast ++ [LastGoal], LambdaGoalInfo,
+        LambdaGoal),
+
+    % Work out the modes of the introduced lambda variables and the determinism
+    % of the lambda goal.
+    lambda_modes_and_det(ProcInfo, LambdaVars, LambdaModes, LambdaDet),
+
+    % Construct the lambda expression.
+    Functor = rhs_lambda_goal(Purity, Groundness, PredOrFunc, EvalMethod,
+        ArgVars0, LambdaVars, LambdaModes, LambdaDet, LambdaGoal).
+
+:- pred lambda_modes_and_det(proc_info::in, prog_vars::in, list(mer_mode)::out,
+    determinism::out) is det.
+
+lambda_modes_and_det(ProcInfo, LambdaVars, LambdaModes, LambdaDet) :-
     proc_info_get_argmodes(ProcInfo, ArgModes),
     list.length(ArgModes, NumArgModes),
     list.length(LambdaVars, NumLambdaVars),
-    ( list.drop(NumArgModes - NumLambdaVars, ArgModes, LambdaModes0) ->
-        LambdaModes = LambdaModes0
+    ( list.drop(NumArgModes - NumLambdaVars, ArgModes, LambdaModesPrime) ->
+        LambdaModes = LambdaModesPrime
     ;
-        unexpected(this_file, "convert_pred_to_lambda_goal: list.drop failed")
+        unexpected(this_file, "lambda_modes_and_det: list.drop failed")
     ),
     proc_info_get_declared_determinism(ProcInfo, MaybeDet),
     (
@@ -1425,16 +1508,9 @@
     ;
         MaybeDet = no,
         sorry(this_file,
-            "determinism inference for higher order predicate terms.")
-    ),
-
-    % Construct the lambda expression.
-
-    PredOrFunc = pred_info_is_pred_or_func(PredInfo),
-    % Higher-order values created in this fashion are always ground.
-    Groundness = ho_ground,
-    Functor = rhs_lambda_goal(Purity, Groundness, PredOrFunc, EvalMethod,
-        ArgVars0, LambdaVars, LambdaModes, LambdaDet, LambdaGoal).
+            "lambda_modes_and_det: determinism inference for " ++
+            "higher order predicate terms.")
+    ).
 
 :- pred create_fresh_vars(list(mer_type)::in, list(prog_var)::out,
     prog_varset::in, prog_varset::out, vartypes::in, vartypes::out) is det.
Index: compiler/post_typecheck.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/post_typecheck.m,v
retrieving revision 1.125
diff -u -r1.125 post_typecheck.m
--- compiler/post_typecheck.m	27 Feb 2008 07:23:12 -0000	1.125
+++ compiler/post_typecheck.m	16 Apr 2008 06:15:17 -0000
@@ -1012,7 +1012,20 @@
         get_pred_id(calls_are_fully_qualified(Markers), Name,
             PredOrFunc, TVarSet, AllArgTypes, ModuleInfo, PredId)
     ->
-        get_proc_id(ModuleInfo, PredId, ProcId),
+        module_info_pred_info(ModuleInfo, PredId, PredInfo),
+        ProcIds = pred_info_procids(PredInfo),
+        (
+            ProcIds = [ProcId0],
+            ProcId = ProcId0
+        ;
+            ProcIds = [_, _ | _],
+            % We don't know which mode to pick. Defer it until mode checking.
+            ProcId = invalid_proc_id
+        ;
+            ProcIds = [],
+            % Abort with error message.
+            get_proc_id(ModuleInfo, PredId, ProcId)
+        ),
         ShroudedPredProcId = shroud_pred_proc_id(proc(PredId, ProcId)),
         ConsId = pred_const(ShroudedPredProcId, EvalMethod),
         GoalExpr = unify(X0, rhs_functor(ConsId, no, ArgVars0), Mode0,
Index: compiler/saved_vars.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/saved_vars.m,v
retrieving revision 1.77
diff -u -r1.77 saved_vars.m
--- compiler/saved_vars.m	27 Feb 2008 07:23:14 -0000	1.77
+++ compiler/saved_vars.m	16 Apr 2008 06:15:17 -0000
@@ -232,6 +232,7 @@
 ok_to_duplicate(feature_will_not_call_mm_tabled) = yes.
 ok_to_duplicate(feature_contains_trace) = yes.
 ok_to_duplicate(feature_pretest_equality) = yes.
+ok_to_duplicate(feature_lambda_undetermined_mode) = yes.
 
     % Divide a list of goals into an initial subsequence of goals
     % that construct constants, and all other goals.
Index: doc/reference_manual.texi
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/doc/reference_manual.texi,v
retrieving revision 1.425
diff -u -r1.425 reference_manual.texi
--- doc/reference_manual.texi	3 Apr 2008 05:26:46 -0000	1.425
+++ doc/reference_manual.texi	16 Apr 2008 06:15:20 -0000
@@ -4186,6 +4186,11 @@
 binds @samp{Double} to a higher-order function term of type
 @samp{func(list(int)) = list(int)}.
 
+The restriction on not creating higher-order terms from multi-moded
+predicates or functions is lifted if the mode of the curried predicate or
+function can be determined from the insts of its higher-order curried
+arguments.
+
 For higher-order predicate expressions that thread an accumulator
 pair, we have syntax that allows you to use DCG notation in the
 goal of the expression.  For example,
Index: tests/hard_coded/Mmakefile
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/hard_coded/Mmakefile,v
retrieving revision 1.345
diff -u -r1.345 Mmakefile
--- tests/hard_coded/Mmakefile	3 Apr 2008 05:26:47 -0000	1.345
+++ tests/hard_coded/Mmakefile	16 Apr 2008 06:15:20 -0000
@@ -148,6 +148,7 @@
 	mode_choice \
 	multi_map_test \
 	multimode \
+	multimode_addr \
 	mutable_init_order \
 	myset_test \
 	name_mangling \
Index: tests/hard_coded/multimode_addr.exp
===================================================================
RCS file: tests/hard_coded/multimode_addr.exp
diff -N tests/hard_coded/multimode_addr.exp
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/multimode_addr.exp	16 Apr 2008 06:15:20 -0000
@@ -0,0 +1,21 @@
+TEST 1
+f2p: det, not unique
+f2p: det, not unique
+f2p: det, not unique
+f2p: det, not unique
+f2p: det, not unique
+[5, 4, 3, 2, 1]
+
+TEST 2
+f2p: det, unique
+a
+f2p: det, unique
+b
+f2p: det, unique
+c
+
+TEST 3
+f2p: semidet
+f2p: semidet
+f2p: semidet
+found a multiple of three
Index: tests/hard_coded/multimode_addr.m
===================================================================
RCS file: tests/hard_coded/multimode_addr.m
diff -N tests/hard_coded/multimode_addr.m
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/multimode_addr.m	16 Apr 2008 06:15:20 -0000
@@ -0,0 +1,99 @@
+% Take addresses of multimoded predicates and functions.
+
+:- module multimode_addr.
+:- interface.
+
+:- import_module io.
+
+:- pred main(io::di, io::uo) is det.
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+:- implementation.
+
+:- import_module int.
+:- import_module list.
+
+%-----------------------------------------------------------------------------%
+
+main(!IO) :-
+    io.write_string("TEST 1\n", !IO),
+    Rev = my_foldl(cons, 1 .. 5, []),
+    io.write(Rev, !IO),
+    io.nl(!IO),
+
+    io.write_string("\nTEST 2\n", !IO),
+    !:IO = my_foldl(echo, ["a", "b", "c"], !.IO),
+
+    io.write_string("\nTEST 3\n", !IO),
+    ( RevB = my_foldl(maybe_cons, 1 .. 5, []) ->
+        io.write(RevB, !IO),
+        io.nl(!IO)
+    ;
+        io.write_string("found a multiple of three\n", !IO)
+    ).
+
+:- func my_foldl(func(L, A) = A, list(L), A) = A.
+:- mode my_foldl(in(func(in, in) = out is semidet), in, in) = out is semidet.
+:- mode my_foldl(in(func(in, di) = uo is det), in, di) = uo is det.
+:- mode my_foldl(in(func(in, in) = out is det), in, in) = out is det.
+
+my_foldl(F, L, A0) = A :-
+    list.foldl(f2p(F), L, A0, A).
+
+% Changing the type signature causes polymorphism.m to produce a lambda goal
+% which is more than just a plain_call.  It creates type_infos before the
+% actual call.
+:- func my_foldl_b(func(int, A) = A, list(int), A) = A.
+:- mode my_foldl_b(in(func(in, in) = out is semidet), in, in) = out is semidet.
+:- mode my_foldl_b(in(func(in, di) = uo is det), in, di) = uo is det.
+:- mode my_foldl_b(in(func(in, in) = out is det), in, in) = out is det.
+
+my_foldl_b(F, L, A0) = A :-
+    list.foldl(f2p(F), L, A0, A).
+
+% Some reordering.
+:- func my_foldl_silly(func(L, A) = A, list(L), A) = A.
+:- mode my_foldl_silly(in(func(in, in) = out is semidet), in, in) = out
+    is semidet.
+:- mode my_foldl_silly(in(func(in, di) = uo is det), in, di) = uo is det.
+:- mode my_foldl_silly(in(func(in, in) = out is det), in, in) = out is det.
+
+my_foldl_silly(F, L, A0) = A :-
+    list.foldl(P, L, A0, A),
+    P = f2p(F1),
+    F1 = F.
+
+:- pred f2p(func(L, A) = A, L, A, A).
+:- mode f2p(in(func(in, di) = uo is det), in, di, uo) is det.
+:- mode f2p(in(func(in, in) = out is det), in, in, out) is det.
+:- mode f2p(in(func(in, in) = out is semidet), in, in, out) is semidet.
+
+:- pragma promise_equivalent_clauses(f2p/4).
+
+f2p(F::in(func(in, di) = uo is det), L::in, A0::di, A::uo) :-
+    trace [io(!IO)] io.write_string("f2p: det, unique\n", !IO),
+    F(L, A0) = A.
+
+f2p(F::in(func(in, in) = out is det), L::in, A0::in, A::out) :-
+    trace [io(!IO)] io.write_string("f2p: det, not unique\n", !IO),
+    F(L, A0) = A.
+
+f2p(F::in(func(in, in) = out is semidet), L::in, A0::in, A::out) :-
+    trace [io(!IO)] io.write_string("f2p: semidet\n", !IO),
+    F(L, A0) = A.
+
+:- func echo(string::in, io::di) = (io::uo) is det.
+
+echo(S, IO0) = IO :-
+    io.write_string(S, IO0, IO1),
+    io.nl(IO1, IO).
+
+:- func maybe_cons(int::in, list(int)::in) = (list(int)::out) is semidet.
+
+maybe_cons(X, Xs) = [X | Xs] :-
+    mod(X, 3) \= 0.
+
+%-----------------------------------------------------------------------------%
+% vim: ft=mercury ts=8 sw=4 et wm=0 tw=0
Index: tests/invalid/Mmakefile
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/invalid/Mmakefile,v
retrieving revision 1.229
diff -u -r1.229 Mmakefile
--- tests/invalid/Mmakefile	3 Apr 2008 05:26:48 -0000	1.229
+++ tests/invalid/Mmakefile	16 Apr 2008 06:15:20 -0000
@@ -148,6 +148,7 @@
 	multimode_dcg \
 	multimode_missing_impure \
 	multimode_syntax \
+	multimode_addr_problems \
 	multisoln_func \
 	nested_impl_in_int \
 	no_exports \
Index: tests/invalid/multimode_addr_problems.err_exp
===================================================================
RCS file: tests/invalid/multimode_addr_problems.err_exp
diff -N tests/invalid/multimode_addr_problems.err_exp
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ tests/invalid/multimode_addr_problems.err_exp	16 Apr 2008 06:15:20 -0000
@@ -0,0 +1,11 @@
+multimode_addr_problems.m:023: In clause for `main(di, uo)':
+multimode_addr_problems.m:023:   In unification of `Abs' and higher-order term.
+multimode_addr_problems.m:023:   Could not determine the mode of predicate
+multimode_addr_problems.m:023:   `multimode_addr_problems.absolute'/2 by the
+multimode_addr_problems.m:023:   insts of the higher-order arguments only.
+multimode_addr_problems.m:047: In clause for `my_foldl(in((func(in, in) = out
+multimode_addr_problems.m:047:   is det)), in, in) = out':
+multimode_addr_problems.m:047:   mode error in unification of `P' and
+multimode_addr_problems.m:047:   higher-order term based on multi-moded
+multimode_addr_problems.m:047:   predicate `multimode_addr_problems.f2p'/4.
+For more information, recompile with `-E'.
Index: tests/invalid/multimode_addr_problems.m
===================================================================
RCS file: tests/invalid/multimode_addr_problems.m
diff -N tests/invalid/multimode_addr_problems.m
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ tests/invalid/multimode_addr_problems.m	16 Apr 2008 06:15:20 -0000
@@ -0,0 +1,60 @@
+% Test error messages with problems that arise trying to taking the
+% address of multi-moded predicates.
+
+:- module multimode_addr_problems.
+:- interface.
+
+:- import_module io.
+
+:- pred main(io::di, io::uo) is cc_multi.
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+:- implementation.
+
+:- import_module int.
+:- import_module list.
+
+%-----------------------------------------------------------------------------%
+
+main(!IO) :-
+    % The compiler can't choose which mode of absolute to use.
+    Abs = absolute,
+    Abs(3, X),
+    io.write_int(X, !IO),
+    io.nl(!IO).
+
+:- pred absolute(int, int).
+:- mode absolute(in, out) is det.
+:- mode absolute(out, in) is multi.
+
+:- pragma promise_equivalent_clauses(absolute/2).
+
+absolute(X::in, Y::out) :-
+    Y = ( X < 0 -> -X ; X).
+
+absolute(X::out, Y::in) :-
+    ( X = Y
+    ; X = -Y
+    ).
+
+:- func my_foldl(func(L, A) = A, list(L), A) = A.
+:- mode my_foldl(in(func(in, in) = out is det), in, in) = out is det.
+
+my_foldl(F, L, A0) = A :-
+    % None of the modes of f2p are usable.
+    % XXX the error message without this explicit unification is confusing.
+    P = f2p(F),
+    list.foldl(P, L, A0, A).
+
+:- pred f2p(func(L, A) = A, L, A, A).
+:- mode f2p(in(func(in, di) = uo is det), in, di, uo) is det.
+% :- mode f2p(in(func(in, in) = out is det), in, in, out) is det.
+:- mode f2p(in(func(in, in) = out is semidet), in, in, out) is semidet.
+
+f2p(F, L, A0, A) :-
+    F(L, A0) = A.
+
+%-----------------------------------------------------------------------------%
+% vim: ft=mercury ts=8 sw=4 et wm=0 tw=0


--------------------------------------------------------------------------
mercury-reviews mailing list
Post messages to:       mercury-reviews at csse.unimelb.edu.au
Administrative Queries: owner-mercury-reviews at csse.unimelb.edu.au
Subscriptions:          mercury-reviews-request at csse.unimelb.edu.au
--------------------------------------------------------------------------



More information about the reviews mailing list