mercury/compiler/magic_util.m

%-----------------------------------------------------------------------------%
% Copyright (C) 1998-2005 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.
%-----------------------------------------------------------------------------%
% File: magic_util.m
% Main author: stayl
%
% Predicates used by magic.m and context.m to transform Aditi procedures.
%
% Note: this module contains multiple interface sections.
%-----------------------------------------------------------------------------%
:- module aditi_backend__magic_util.

:- interface.

:- import_module hlds.hlds_goal.
:- import_module hlds.hlds_module.
:- import_module hlds.hlds_pred.
:- import_module mdbcomp.prim_data.
:- import_module parse_tree.prog_data.

:- import_module bool.
:- import_module io.
:- import_module list.
:- import_module map.
:- import_module set.
:- import_module std_util.
:- import_module term.

	% Check that the argument types and modes are legal for
	% an Aditi relation.
:- pred check_args(list(prog_var)::in, list(mer_mode)::in,
	list(mer_type)::in, prog_context::in, magic_arg_id_type::in,
	magic_info::in, magic_info::out) is det.

:- pred report_errors(list(magic_error)::in, module_info::in,
	bool::in, io::di, io::uo) is det.

	% Determine whether a given goal contains a call to an
	% Aditi procedure. Strip out any explicit quantifications
	% around Aditi calls, since they just get in the way.
	% Multiple nested explicit quantifications should have
	% been removed by simplify.m.
:- pred goal_is_aditi_call(module_info::in,
	map(pred_proc_id, pred_proc_id)::in, hlds_goal::in,
	db_call::out, list(hlds_goal)::out) is semidet.

	% Information about a database call.
:- type db_call
	--->	db_call(
			maybe(list(hlds_goal)),	% aggregate input closures
			hlds_goal,		% goal containing the call
			pred_proc_id,
			list(prog_var),		% arguments
			list(prog_var),		% input arguments
			list(prog_var),		% output arguments
			maybe(pair(list(hlds_goal), hlds_goal_info))
					% goals after the call in a negation,
					% and the goal_info for the negation.
		).

:- pred db_call_nonlocals(db_call::in, set(prog_var)::out) is det.
:- pred db_call_input_args(db_call::in,
	list(prog_var)::out) is det.
:- pred db_call_output_args(db_call::in,
	list(prog_var)::out) is det.
:- pred db_call_context(db_call::in, prog_context::out) is det.
:- pred db_call_pred_proc_id(db_call::in,
	pred_proc_id::out) is det.

:- pred rename_vars_in_db_call(db_call::in,
	map(prog_var, prog_var)::in, db_call::out) is det.

	% Do all the necessary goal fiddling to handle the input
	% to an Aditi procedure.
:- pred setup_call(list(hlds_goal)::in, db_call::in,
	set(prog_var)::in, list(hlds_goal)::out,
	magic_info::in, magic_info::out) is det.

	% Create a closure given the goal and arguments.
:- pred create_closure(int::in, prog_var::in, mer_mode::in,
	hlds_goal::in, list(prog_var)::in, list(prog_var)::in,
	hlds_goal::out, magic_info::in, magic_info::out) is det.

	% Add the goal as a disjunct of the magic predicate for the
	% pred_proc_id. The list of variables is the list of head
	% variables of the `clause'.
:- pred add_to_magic_predicate(pred_proc_id::in, hlds_goal::in,
	list(prog_var)::in, magic_info::in, magic_info::out) is det.

	% Get information to build a call to the magic
	% predicate for the current procedure.
:- pred magic_call_info(pred_id::out, proc_id::out, sym_name::out,
	list(prog_var)::out, list(prog_var)::out, list(mer_mode)::out,
	magic_info::in, magic_info::out) is det.

	% Convert all modes to output, creating test unifications
	% where the original mode was input. This will result in
	% a join on the input attributes.
:- pred create_input_test_unifications(module_info::in,
	list(prog_var)::in, list(prog_var)::in, list(mer_mode)::in,
	list(prog_var)::out, list(hlds_goal)::in, list(hlds_goal)::out,
	hlds_goal_info::in, hlds_goal_info::out,
	proc_info::in, proc_info::out) is det.

	% Convert an input mode to output.
:- pred mode_to_output_mode(module_info::in,
	mer_mode::in, mer_mode::out) is det.

	% Adjust an index to account for the removal of the `aditi:state'
	% from the argument list.
:- pred adjust_index(list(mer_type)::in, index_spec::in,
	index_spec::out) is det.

	% Remove any aditi:states from the set of vars.
:- pred restrict_nonlocals(set(prog_var)::in, set(prog_var)::out,
	magic_info::in, magic_info::out) is det.

	% Given a prefix, create a unique new name for the predicate
	% using prog_util__make_pred_name_with_context. The boolean
	% states whether a counter should be attached to the name. This
	% should be `no' for names which should be visible to other modules.
:- pred make_pred_name(pred_info::in, proc_id::in, string::in,
	bool::in, sym_name::out, magic_info::in, magic_info::out) is det.

%-----------------------------------------------------------------------------%

:- implementation.

:- import_module check_hlds.inst_match.
:- import_module check_hlds.mode_util.
:- import_module check_hlds.polymorphism.
:- import_module check_hlds.type_util.
:- import_module hlds.goal_util.
:- import_module hlds.hlds_data.
:- import_module hlds.hlds_error_util.
:- import_module hlds.hlds_out.
:- import_module hlds.instmap.
:- import_module parse_tree.error_util.
:- import_module parse_tree.prog_out.
:- import_module parse_tree.prog_util.
:- import_module parse_tree.prog_type.

:- import_module assoc_list.
:- import_module int.
:- import_module require.
:- import_module string.
:- import_module term.
:- import_module varset.

db_call_nonlocals(
		db_call(MaybeClosures, Call, _, _, _, _, MaybeNegGoals),
		NonLocals) :-
	(
		MaybeClosures = yes(Closures),
		goal_list_nonlocals(Closures, NonLocals0)
	;
		MaybeClosures = no,
		set__init(NonLocals0)
	),
	Call = _ - CallInfo,
	goal_info_get_nonlocals(CallInfo, NonLocals1),
	set__union(NonLocals0, NonLocals1, NonLocals2),
	(
		MaybeNegGoals = yes(_ - NegGoalInfo),
		goal_info_get_nonlocals(NegGoalInfo, NonLocals3),
		set__union(NonLocals2, NonLocals3, NonLocals)
	;
		MaybeNegGoals = no,
		NonLocals = NonLocals2
	).

db_call_context(db_call(_, _ - Info, _, _, _, _, _), Context) :-
	goal_info_get_context(Info, Context).
db_call_pred_proc_id(db_call(_, _, PredProcId, _, _, _, _),
		PredProcId).
db_call_input_args(db_call(_, _, _, _, Inputs, _, _), Inputs).
db_call_output_args(db_call(_, _, _, _, _, Outputs, _), Outputs).

rename_vars_in_db_call(Call0, Subn, Call) :-
	Call0 = db_call(MaybeClosures0, Goal0, PredProcId, Args0,
		Inputs0, Outputs0, MaybeNegGoals0),
	(
		MaybeClosures0 = yes(Closures0),
		goal_util__rename_vars_in_goals(no, Subn, Closures0, Closures),
		MaybeClosures = yes(Closures)
	;
		MaybeClosures0 = no,
		MaybeClosures = no
	),
	goal_util__rename_vars_in_goal(Subn, Goal0, Goal),
	goal_util__rename_var_list(no, Subn, Args0, Args),
	goal_util__rename_var_list(no, Subn, Inputs0, Inputs),
	goal_util__rename_var_list(no, Subn, Outputs0, Outputs),
	(
		MaybeNegGoals0 = yes(NegGoals0 - NegGoalInfo0),
		goal_util__rename_vars_in_goals(no, Subn, NegGoals0, NegGoals),
		goal_util__rename_vars_in_goal(Subn,
			conj([]) - NegGoalInfo0, _ - NegGoalInfo),
		MaybeNegGoals = yes(NegGoals - NegGoalInfo)
	;
		MaybeNegGoals0 = no,
		MaybeNegGoals = no
	),
	Call = db_call(MaybeClosures, Goal, PredProcId, Args,
		Inputs, Outputs, MaybeNegGoals).

%-----------------------------------------------------------------------------%

goal_is_aditi_call(ModuleInfo, PredMap,
		Goal0, Call, AfterGoals) :-
	%
	% Strip off any explicit quantification. There should only
	% be one, since simplification removes nested quantifications
	% and multiple nested quantifications are not considered
	% atomic by dnf.m.
	%
	( Goal0 = scope(_, Goal1) - _ ->
		Goal2 = Goal1
	;
		Goal2 = Goal0
	),
	goal_to_conj_list(Goal2, Goals2),
	Goals2 = [PossibleCallGoal | AfterGoals0],
	( PossibleCallGoal = not(NegGoal0) - NegGoalInfo ->
		neg_goal_is_aditi_call(ModuleInfo, PredMap,
			NegGoal0, NegGoalInfo, Call),
		AfterGoals = AfterGoals0
	;
		goal_is_aditi_call_2(ModuleInfo, PredMap,
			Goals2, Call, AfterGoals)
	).

:- pred goal_is_aditi_call_2(module_info::in, pred_map::in,
	list(hlds_goal)::in, db_call::out, list(hlds_goal)::out) is semidet.

goal_is_aditi_call_2(ModuleInfo, PredMap,
		Goals, Call, AfterGoals) :-
	(
		% Is the goal an aggregate? If so, magic__preprocess_goal
		% should have placed the closures next to the aggregate call.
		Goals = [Closure1a, Closure2a, Closure3a,
				CallGoal | AfterGoals0],
		CallGoal = call(PredId, ProcId, Args, _,_,_) - _,
		hlds_pred__is_aditi_aggregate(ModuleInfo, PredId),
		check_aggregate_closure(Closure1a, Closure1),
		check_aggregate_closure(Closure2a, Closure2),
		check_aggregate_closure(Closure3a, Closure3)
	->
		AfterGoals = AfterGoals0,
		Call = db_call(yes([Closure1, Closure2, Closure3]),
			CallGoal, proc(PredId, ProcId), Args, [], Args, no)
	;
		% Is the goal an ordinary database call.
		Goals = [Goal0 | AfterGoals],
		Goal0 = call(PredId, ProcId, Args, _, _, _) - _,
		(
			% The original predicate may have been stripped of its
			% aditi marker by magic__interface_to_c, so check
			% if the procedure was renamed by the preprocessing
			% pass, if so it is an Aditi procedure.
			map__contains(PredMap, proc(PredId, ProcId))
		;
			hlds_pred__is_aditi_relation(ModuleInfo, PredId)
		),
		construct_db_call(ModuleInfo, PredId, ProcId,
			Args, Goal0, Call)
	).

:- pred neg_goal_is_aditi_call(module_info::in, pred_map::in,
	hlds_goal::in, hlds_goal_info::in, db_call::out) is semidet.

neg_goal_is_aditi_call(ModuleInfo, PredMap,
		NegGoal0, NegGoalInfo, Call) :-
	% This is safe because nested negations should be
	% transformed into calls by dnf.m.
	goal_is_aditi_call(ModuleInfo, PredMap,
		NegGoal0, NegCall, AfterGoals),
	NegCall = db_call(A, B, C, D, E, F, _),
	Call = db_call(A, B, C, D, E, F, yes(AfterGoals - NegGoalInfo)).

:- pred check_aggregate_closure(hlds_goal::in,
		hlds_goal::out) is semidet.

check_aggregate_closure(Goal, Goal) :-
	Goal = unify(_, _, _, Uni, _) - _,
	Uni = construct(_, pred_const(_, _), _, _, _, _, _).

:- pred construct_db_call(module_info::in, pred_id::in,
	proc_id::in, list(prog_var)::in, hlds_goal::in, db_call::out) is det.

construct_db_call(ModuleInfo, PredId, ProcId,
		Args0, Goal0, Call) :-
	module_info_pred_proc_info(ModuleInfo, PredId, ProcId,
		PredInfo, ProcInfo),
	pred_info_arg_types(PredInfo, ArgTypes),
	proc_info_argmodes(ProcInfo, ArgModes0),
	remove_aditi_state(ArgTypes, ArgModes0, ArgModes),
	remove_aditi_state(ArgTypes, Args0, Args),
	partition_args(ModuleInfo, ArgModes, Args, InputArgs, OutputArgs),
	Call = db_call(no, Goal0, proc(PredId, ProcId), Args,
		InputArgs, OutputArgs, no).

%-----------------------------------------------------------------------------%

adjust_index(ArgTypes, index_spec(IndexType, Attrs0),
		index_spec(IndexType, Attrs)) :-
	construct_type(qualified(unqualified("aditi"), "state") - 0,
		[], StateType),
	( list__nth_member_search(ArgTypes, StateType, StateIndex) ->
		AdjustAttr = (pred(Attr0::in, Attr::out) is det :-
			( Attr0 < StateIndex ->
				Attr = Attr0
			; Attr0 > StateIndex ->
				Attr = Attr0 - 1
			;
	 			error("base relation indexed on " ++
					"aditi__state attribute")
			)),
		list__map(AdjustAttr, Attrs0, Attrs)
	;
		error("adjust_index: " ++
			"no aditi__state in base relation argument types")
	).

restrict_nonlocals(NonLocals0, NonLocals) -->
	magic_info_get_proc_info(ProcInfo),
	{ proc_info_vartypes(ProcInfo, VarTypes) },
	{ set__to_sorted_list(NonLocals0, NonLocals1) },
	{ map__apply_to_list(NonLocals1, VarTypes, NonLocalTypes) },
	{ remove_aditi_state(NonLocalTypes, NonLocals1, NonLocals2) },
	{ set__sorted_list_to_set(NonLocals2, NonLocals) }.

make_pred_name(PredInfo, ProcId, Prefix0, AddCount, Name) -->
	{ PredOrFunc = pred_info_is_pred_or_func(PredInfo) },
	{ Module = pred_info_module(PredInfo) },
	{ Name0 = pred_info_name(PredInfo) },
	{ proc_id_to_int(ProcId, ProcInt) },
	{ string__int_to_string(ProcInt, ProcStr) },
	{ string__append_list([Prefix0, "_Mode_", ProcStr, "_Of"], Prefix) },

	( { AddCount = yes } ->
		magic_info_get_next_supp_id(Count)
	;
		% Note that we can't use a counter here because the names
		% can be exported to other modules.
		{ Count = 0 }
	),

	{ Line = 0 },
	{ make_pred_name_with_context(Module, Prefix, PredOrFunc, Name0,
		Line, Count, Name) }.

%-----------------------------------------------------------------------------%

setup_call(PrevGoals, DBCall1, NonLocals, Goals) -->

	{ DBCall1 = db_call(MaybeAggInputs, CallGoal0,
			PredProcId0, Args, InputArgs, _, MaybeNegGoals) },

	%
	% Check whether this procedure was renamed
	% during the preprocessing pass.
	%
	magic_info_get_pred_map(PredMap),
	{ map__search(PredMap, PredProcId0, PredProcId1) ->
		PredProcId = PredProcId1
	;
		PredProcId = PredProcId0
	},

	( { MaybeAggInputs = yes(AggInputs0) } ->
		% The preprocessing pass ensures that the closures
		% for the aggregate are right next to the call.
		% There should be three - one for the query, one to
		% compute the initial accumulator and one to update
		% the accumulator.
		list__map_foldl(setup_aggregate_input,
			AggInputs0, AggInputs1),
		{ list__condense(AggInputs1, AggInputs) },

		{ CallGoal0 = _ - CallGoalInfo },
		{ goal_info_get_context(CallGoalInfo, Context) },
		maybe_create_supp_call(PrevGoals, NonLocals, [],
			Context, SuppCall),

		{ BeforeGoals = [SuppCall | AggInputs] },
		{ Tests = [] },
		{ CallGoal = CallGoal0 }
	;
		{ PredProcId = proc(PredId, ProcId) },
		magic_info_get_module_info(ModuleInfo0),
		( { hlds_pred__is_base_relation(ModuleInfo0, PredId) } ->
			{ CallGoal0 = _ - CallGoalInfo0 },
			{ goal_info_get_context(CallGoalInfo0, Context) },
			maybe_create_supp_call(PrevGoals,
				NonLocals, [], Context, SuppCall),
			{ BeforeGoals = [SuppCall] },

			% Convert input args to outputs, and test that
			% the input matches the output.
			magic_info_get_module_info(ModuleInfo),
			{ module_info_pred_proc_info(ModuleInfo, PredProcId,
				CalledPredInfo, CalledProcInfo) },
			{ PredModule = pred_info_module(CalledPredInfo) },
			{ PredName = pred_info_name(CalledPredInfo) },
			{ Name = qualified(PredModule, PredName) },
			{ proc_info_argmodes(CalledProcInfo, ArgModes) },
			magic_info_get_proc_info(ProcInfo0),
			{ create_input_test_unifications(
				ModuleInfo, Args, InputArgs, ArgModes,
				NewArgs, [], Tests, CallGoalInfo0,
				CallGoalInfo1, ProcInfo0, ProcInfo) },
			magic_info_set_proc_info(ProcInfo),
			{ goal_info_get_nonlocals(CallGoalInfo1,
				CallNonLocals1) },
			restrict_nonlocals(CallNonLocals1,
				CallNonLocals),
			{ goal_info_set_nonlocals(CallNonLocals,
				CallGoalInfo1, CallGoalInfo) },
			{ CallGoal = call(PredId, ProcId, NewArgs,
				not_builtin, no, Name) - CallGoalInfo }
		;
			% Transform away the input arguments.
			handle_input_args(PredProcId0, PredProcId,
				PrevGoals, NonLocals, Args, InputArgs,
				BeforeGoals, CallGoal0, CallGoal, Tests)
		)
	),

	( { MaybeNegGoals = yes(NegAfterGoals - NegGoalInfo) } ->
		{ list__append([CallGoal | Tests], NegAfterGoals, NegGoals) },

		%
		% Compute a goal info for the conjunction
		% inside the negation.
		%
		{ goal_info_get_nonlocals(NegGoalInfo, NegNonLocals0) },
		{ goal_list_nonlocals(NegGoals, InnerNonLocals0) },
		{ set__intersect(NegNonLocals0, InnerNonLocals0,
			InnerNonLocals1) },
		restrict_nonlocals(InnerNonLocals1,
			InnerNonLocals),
		{ goal_list_instmap_delta(NegGoals, InnerDelta0) },
		{ instmap_delta_restrict(InnerNonLocals,
			InnerDelta0, InnerDelta) },
		{ goal_list_determinism(NegGoals, InnerDet) },
		{ goal_info_init(InnerNonLocals, InnerDelta,
			InnerDet, purity_pure, InnerInfo) },

		{ conj_list_to_goal(NegGoals, InnerInfo, InnerConj) },
		{ list__append(BeforeGoals, [not(InnerConj) - NegGoalInfo],
			Goals) }
	;
		{ list__append(BeforeGoals, [CallGoal | Tests], Goals) }
	).

	% Construct the input for the query for an aggregate.
	% XXX we should check that the input query of an aggregate
	% is an Aditi relation, not a top-down Mercury predicate.
:- pred setup_aggregate_input(hlds_goal::in, list(hlds_goal)::out,
	magic_info::in, magic_info::out) is det.

setup_aggregate_input(Closure, InputAndClosure) -->

	magic_info_get_module_info(ModuleInfo0),
	magic_info_get_pred_map(PredMap),
	(
		{ Closure = unify(_, _, UniMode, Uni0, Context) - Info },
		{ Uni0 = construct(Var, ConsId0, _, Modes, _, _, _) },
		{ ConsId0 = pred_const(ShroudedPredProcId0, Method) }
	->
		%
		% Replace the pred_proc_id of the procedure being aggregated
		% over with its Aditi version.
		%
		{ PredProcId0 = unshroud_pred_proc_id(ShroudedPredProcId0) },
		{ map__search(PredMap, PredProcId0, PredProcIdPrime) ->
			PredProcId = PredProcIdPrime,
			ShroudedPredProcId = shroud_pred_proc_id(PredProcId),
			ConsId = pred_const(ShroudedPredProcId, Method)
		;
			PredProcId = PredProcId0,
			ConsId = ConsId0
		},
		{ PredProcId = proc(PredId, _ProcId) },
		( { hlds_pred__is_derived_relation(ModuleInfo0, PredId) } ->

			%
			% Create the input relation for the aggregate query.
			% This is just `true', since we don't allow curried
			% arguments (except for aditi:states).
			%
			magic_info_get_magic_proc_info(MagicProcInfo),
			{ map__lookup(MagicProcInfo, PredProcId,
				CallProcInfo) },
			{ CallProcInfo = magic_proc_info(_, MagicInputs,
						_, _, _) },

			{ true_goal(InputGoal) },
			create_input_closures(MagicInputs, [], [],
				InputGoal, CallProcInfo, 1,
				InputGoals, InputVars)
		;
			% Base relation. It could actually be another
			% aggregate, but if aggregate becomes a new goal
			% type we won't be able to handle that, in the
			% same way that call(call(X)) doesn't work.
			{ InputGoals = [] },
			{ InputVars = [] }
		),

		% Update the unify_rhs.
		magic_info_get_module_info(ModuleInfo),
		{ module_info_pred_info(ModuleInfo, PredId, CallPredInfo) },
		{ PredModule = pred_info_module(CallPredInfo) },
		{ PredName = pred_info_name(CallPredInfo) },
		{ list__length(InputVars, Arity) },
		{ Rhs = functor(cons(qualified(PredModule, PredName), Arity),
			no, InputVars) },

		{ Uni = construct(Var, ConsId, InputVars, Modes,
			construct_dynamically, cell_is_unique,
			no_construct_sub_info) },
		{ Goal1 = unify(Var, Rhs, UniMode, Uni, Context) - Info },

		{ list__append(InputGoals, [Goal1], InputAndClosure) }
	;
		{ error("setup_aggregate_input: " ++
			"non-closure input to aggregate") }
	).

%-----------------------------------------------------------------------------%

	% Transform away the input arguments to a derived relation.
:- pred handle_input_args(pred_proc_id::in, pred_proc_id::in,
	list(hlds_goal)::in, set(prog_var)::in, list(prog_var)::in,
	list(prog_var)::in, list(hlds_goal)::out, hlds_goal::in,
	hlds_goal::out, list(hlds_goal)::out,
	magic_info::in, magic_info::out) is det.

handle_input_args(PredProcId0, PredProcId, PrevGoals, NonLocals,
		Args, InputArgs, InputGoals, _ - GoalInfo0,
		CallGoal, Tests) -->

	magic_info_get_magic_proc_info(MagicProcInfo),
	{ map__lookup(MagicProcInfo, PredProcId, CallProcInfo) },
	{ CallProcInfo = magic_proc_info(OldArgModes, MagicInputs, _, _, _) },

	magic_info_get_module_info(ModuleInfo0),
	{ partition_args(ModuleInfo0, OldArgModes,
		OldArgModes, InputArgModes, _) },

	{ goal_info_get_context(GoalInfo0, Context) },
	maybe_create_supp_call(PrevGoals, NonLocals, InputArgs,
		Context, SuppCall),

	% Convert input args to outputs, and test that
	% the input matches the output.
	magic_info_get_module_info(ModuleInfo1),
	magic_info_get_proc_info(ProcInfo0),
	{ create_input_test_unifications(ModuleInfo1,
		Args, InputArgs, OldArgModes, NewOutputArgs, [], Tests,
		GoalInfo0, GoalInfo1, ProcInfo0, ProcInfo) },
	magic_info_set_proc_info(ProcInfo),

	% All database predicates are considered nondet after this.
	{ goal_info_set_determinism(nondet, GoalInfo1, GoalInfo) },

	magic_info_get_scc(SCC),
	( { list__member(PredProcId0, SCC) } ->
		magic_info_get_magic_vars(MagicVars),
		{ list__append(MagicVars, InputArgs, AllMagicVars) },
		add_to_magic_predicate(PredProcId,
			SuppCall, AllMagicVars),
		magic_info_get_magic_vars(MagicInputArgs),
		{ list__append(MagicInputArgs, NewOutputArgs, AllArgs) },
		{ InputGoals0 = [] }
	;
		create_input_closures(MagicInputs,
			InputArgs, InputArgModes, SuppCall,
			CallProcInfo, 1, InputGoals0, InputVars),
		{ list__append(InputVars, NewOutputArgs, AllArgs) }
	),

	{ InputGoals = [SuppCall | InputGoals0] },

	magic_info_get_module_info(ModuleInfo),
	{ PredProcId = proc(PredId, ProcId) },
	{ module_info_pred_info(ModuleInfo, PredId, PredInfo) },
	{ PredModule = pred_info_module(PredInfo) },
	{ PredName = pred_info_name(PredInfo) },
	{ CallGoal = call(PredId, ProcId, AllArgs, not_builtin, no,
		qualified(PredModule, PredName)) - GoalInfo }.

create_input_test_unifications(_, [], _, [_|_],
		_, _, _, _, _, _, _) :-
	error("create_input_test_unifications").
create_input_test_unifications(_, [_|_], _, [],
		_, _, _, _, _, _, _) :-
	error("create_input_test_unifications").
create_input_test_unifications(_, [], _, [], [], Tests, Tests,
		CallInfo, CallInfo, ProcInfo, ProcInfo).
create_input_test_unifications(ModuleInfo, [Var | Vars], InputArgs,
		[Mode | Modes], [OutputVar | OutputVars], Tests0, Tests,
		CallInfo0, CallInfo, ProcInfo0, ProcInfo) :-
	( list__member(Var, InputArgs) ->
		create_input_test_unification(ModuleInfo,
			Var, Mode, OutputVar, Test, CallInfo0, CallInfo1,
			ProcInfo0, ProcInfo1),
		Tests1 = [Test | Tests0]
	;
		ProcInfo1 = ProcInfo0,
		OutputVar = Var,
		CallInfo1 = CallInfo0,
		Tests1 = Tests0
	),
	create_input_test_unifications(ModuleInfo, Vars, InputArgs,
		Modes, OutputVars, Tests1, Tests, CallInfo1, CallInfo,
		ProcInfo1, ProcInfo).

:- pred create_input_test_unification(module_info::in,
	prog_var::in, mer_mode::in, prog_var::out,
	hlds_goal::out, hlds_goal_info::in,
	hlds_goal_info::out, proc_info::in, proc_info::out) is det.

create_input_test_unification(ModuleInfo, Var, Mode, OutputVar,
		Test, CallInfo0, CallInfo, !ProcInfo) :-
	mode_get_insts(ModuleInfo, Mode, _, FinalInst),
	proc_info_varset(!.ProcInfo, VarSet0),
	varset__new_var(VarSet0, OutputVar, VarSet),
	proc_info_vartypes(!.ProcInfo, VarTypes0),
	map__lookup(VarTypes0, Var, VarType),
	map__det_insert(VarTypes0, OutputVar, VarType, VarTypes),
	proc_info_set_varset(VarSet, !ProcInfo),
	proc_info_set_vartypes(VarTypes, !ProcInfo),

	set__list_to_set([Var, OutputVar], NonLocals),
	instmap_delta_init_reachable(InstMapDelta),
	goal_info_init(NonLocals, InstMapDelta, semidet, purity_pure,
		GoalInfo),
	( type_is_atomic(VarType, ModuleInfo) ->
		%
		% The type is a builtin, so create a simple_test unification.
		%
		Unification = simple_test(Var, OutputVar),
		UnifyMode = ((FinalInst -> FinalInst)
			- (FinalInst -> FinalInst)),
		Test = unify(Var, var(OutputVar), UnifyMode,
			Unification, unify_context(explicit, [])) - GoalInfo
	; type_to_ctor_and_args(VarType, _TypeCtor, _ArgTypes) ->
		% XXX for now we pretend that the unification is
		% a simple test, since otherwise we would have to
		% go through the rigmarole of creating type_info variables
		% (and then ignoring them in code generation).
		Unification = simple_test(Var, OutputVar),
		UnifyMode = ((FinalInst -> FinalInst)
			- (FinalInst -> FinalInst)),
		Test = unify(Var, var(OutputVar), UnifyMode,
			Unification, unify_context(explicit, [])) - GoalInfo

		/*
		%
		% The type is non-builtin, so look up the unification
		% procedure for the type.
		%
		module_info_get_special_pred_map(ModuleInfo,
			SpecialPredMap),
		map__lookup(SpecialPredMap, unify - TypeCtor, UniPredId),

		% It had better be an in-in unification, since Aditi
		% relations cannot have non-ground arguments. This is
		% checked elsewhere.
		% XXX unification predicates need to be special cased
		% in rl_exprn.m because we don't add the type_info arguments.

		hlds_pred__in_in_unification_proc_id(UniProcId),
		XXX SymName = unqualified("__Unify__"),
		ArgVars = [Var, OutputVar],
		Test = call(UniPredId, UniProcId, ArgVars, not_builtin,
			no, SymName) - GoalInfo
		*/
	;
		error("create_input_test_unifications: \
			type_to_ctor_and_args failed")
	),
	goal_info_get_nonlocals(CallInfo0, CallNonLocals0),
	set__delete(CallNonLocals0, Var, CallNonLocals1),
	set__insert(CallNonLocals1, OutputVar, CallNonLocals),
	goal_info_get_instmap_delta(CallInfo0, CallDelta0),
	instmap_delta_insert(OutputVar, FinalInst, CallDelta0, CallDelta),
	goal_info_set_nonlocals(CallNonLocals, CallInfo0, CallInfo1),
	goal_info_set_instmap_delta(CallDelta, CallInfo1, CallInfo).

%-----------------------------------------------------------------------------%

	% Create the magic input closures for a call to a lower sub-module.
:- pred create_input_closures(list(prog_var)::in,
	list(prog_var)::in, list(mer_mode)::in, hlds_goal::in,
	magic_proc_info::in, int::in, list(hlds_goal)::out,
	list(prog_var)::out, magic_info::in, magic_info::out) is det.

create_input_closures([], _, _, _, _, _, [], []) --> [].
create_input_closures([_ | MagicVars], InputArgs,
		InputArgModes, SuppCall, ThisProcInfo, CurrVar,
		[InputGoal | InputGoals], [ClosureVar | ClosureVars]) -->
	{ ThisProcInfo = magic_proc_info(_OldArgModes, _MagicInputs,
		MagicTypes, MagicModes, MaybeIndex) },
	magic_info_get_proc_info(ProcInfo0),

	%
	% Create a new variable to hold the input.
	%
	{ get_input_var(MagicTypes, CurrVar, ClosureVar, ArgTypes,
		ProcInfo0, ProcInfo1) },

	( { MaybeIndex = yes(CurrVar) } ->
		%
		% This argument is the magic input for the call we are
		% processing now. Create the input closure by projecting
		% the previous database call onto the input arguments.
		%
		( { SuppCall = conj([]) - _ } ->
			{ LambdaGoal = SuppCall },
			{ LambdaVars = [] },
			{ LambdaInputs = [] },
			{ ProcInfo = ProcInfo1 }
		;
			project_supp_call(SuppCall, InputArgs,
				ProcInfo1, ProcInfo, LambdaInputs,
				LambdaVars, LambdaGoal)
		)
	;
		%
		% There is no input for this member of the lower sub-module
		% since it is not being directly called, so create an empty
		% input relation.
		%
		{ proc_info_create_vars_from_types(ArgTypes, LambdaVars,
			ProcInfo1, ProcInfo) },
		{ fail_goal(LambdaGoal) },
		{ LambdaInputs = [] }
	),

	magic_info_set_proc_info(ProcInfo),

	{ list__index1_det(MagicModes, CurrVar, ClosureVarMode) },
	create_closure(CurrVar, ClosureVar, ClosureVarMode,
		LambdaGoal, LambdaInputs, LambdaVars, InputGoal),

	{ NextIndex = CurrVar + 1 },
	create_input_closures(MagicVars, InputArgs,
		InputArgModes, SuppCall, ThisProcInfo, NextIndex,
		InputGoals, ClosureVars).

%-----------------------------------------------------------------------------%

	% Create a variable to hold an input closure for a lower sub-module
	% call, returning the argument types of the closure.
:- pred get_input_var(list(mer_type)::in, int::in, prog_var::out,
	list(mer_type)::out, proc_info::in, proc_info::out) is det.

get_input_var(MagicTypes, CurrVar, InputVar, ArgTypes,
		!ProcInfo) :-
	list__index1_det(MagicTypes, CurrVar, MagicType),
	(
		type_is_higher_order(MagicType, purity_pure, predicate,
			lambda_aditi_bottom_up, ArgTypes1)
	->
		ArgTypes = ArgTypes1,
		construct_higher_order_type(purity_pure, predicate,
			lambda_aditi_bottom_up, ArgTypes, ClosureType),
		proc_info_create_var_from_type(ClosureType, no, InputVar,
			!ProcInfo)
	;
		error("get_input_var")
	).

create_closure(_CurrVar, InputVar, InputMode, LambdaGoal,
		LambdaInputs, LambdaVars, InputGoal) -->

	%
	% Create a new predicate to hold the projecting goal,
	% unless the arguments match so no projection is needed.
	%
	(
		{ LambdaGoal = call(_, _, CallArgs, _, _, _) - _ },
		{ list__append(LambdaInputs, LambdaVars, CallArgs) }
	->
		% No projection is needed.
		{ SuppCall = LambdaGoal }
	;
		{ term__context_init(Context) },
		{ goal_to_conj_list(LambdaGoal, LambdaGoalList) },

		%
		% The projecting goal must be generated inline.
		% Otherwise there could be problems with transformed
		% code such as:
		%
		% q(InP, X, Y, Z) :-
		% 	magic_p(InP, X, Y),
		% 	InR = q_supp1(InP),
		%	r(InR, A, Z),
		% 	Y == A.
		% q_supp1(InP, Y) :-
		% 	magic_p(InP, _X, Y).
		%
		% 'r/3' is defined in a lower SCC.
		%
		% rl_gen could produce the recursive part of this SCC as:
		%
		% toplabel:
		% if (diffs empty) goto bottomlabel:
		% 	evaluate magic_p;
		%	evaluate q;
		%	evaluate q_supp1;
		% goto toplabel;
		% bottomlabel:
		%
		% In this case, if `q_supp1/2' was not generated inline,
		% the input relation for the call to `r/3' in `q/4'
		% would use the value of `magic_p/3' from the previous
		% iteration, but the join of `magic_p/3' and the result
		% of `r/3' uses the value of `magic_p/3' from the
		% current iteration.
		%
		% The generate_inline marker forces rl_gen.m evaluate
		% `q_supp1/2' in the correct location so that it uses
		% the correct version of `magic_p/3' as input to `r/3'.
		%
		create_supp_call(LambdaGoalList, LambdaInputs,
			LambdaVars, Context,
			[aditi_no_memo, naive, generate_inline], SuppCall)
	),

	magic_info_get_module_info(ModuleInfo),
	(
		{ SuppCall = call(SuppPredId, SuppProcId, _, _, _, _) - _ },
		{ mode_get_insts(ModuleInfo, InputMode, Inst, _) },
		{ Inst = ground(_, higher_order(PredInstInfo)) }
	->
		% Find the mode of the unification.
		{ PredInstInfo = pred_inst_info(_, LambdaModes, _) },
		{ LambdaInst = ground(shared,
			higher_order(pred_inst_info(predicate, LambdaModes,
				nondet))) },
		{ UnifyMode = (free -> LambdaInst) -
				(LambdaInst -> LambdaInst) },
		{ mode_util__modes_to_uni_modes(ModuleInfo, LambdaModes,
			LambdaModes, UniModes) },

		% Construct the unify_rhs.
		{ module_info_pred_info(ModuleInfo, SuppPredId, PredInfo) },
		{ SuppModule = pred_info_module(PredInfo) },
		{ SuppName = pred_info_name(PredInfo) },
		{ list__length(LambdaInputs, SuppArity) },
		{ Rhs = functor(cons(qualified(SuppModule, SuppName),
				SuppArity), no, LambdaInputs) },

		{ SuppPredProcId = proc(SuppPredId, SuppProcId) },
		{ ShroudedSuppPredProcId =
			shroud_pred_proc_id(SuppPredProcId) },
		{ Unify = construct(InputVar,
			pred_const(ShroudedSuppPredProcId,
				lambda_aditi_bottom_up),
			LambdaInputs, UniModes, construct_dynamically,
			cell_is_unique, no_construct_sub_info) },
		{ UnifyContext = unify_context(explicit, []) },

		% Construct a goal_info.
		{ set__list_to_set([InputVar | LambdaInputs], NonLocals) },
		{ instmap_delta_init_reachable(InstMapDelta0) },
		{ instmap_delta_insert(InputVar, LambdaInst,
			InstMapDelta0, InstMapDelta) },
		{ goal_info_init(NonLocals, InstMapDelta,
			det, purity_pure, GoalInfo) },

		{ InputGoal = unify(InputVar, Rhs, UnifyMode,
				Unify, UnifyContext) - GoalInfo }
	;
		{ error("create_closure") }
	).

%-----------------------------------------------------------------------------%

	% Project the supplementary predicate call onto the input
	% arguments of the following call.
:- pred project_supp_call(hlds_goal::in, list(prog_var)::in,
	proc_info::in, proc_info::out, list(prog_var)::out,
	list(prog_var)::out, hlds_goal::out,
	magic_info::in, magic_info::out) is det.

project_supp_call(SuppCall, UnrenamedInputVars,
		!ProcInfo, SuppInputArgs, LambdaVars, LambdaGoal) -->
	(
		{ SuppCall = call(SuppPredId1, SuppProcId1,
			SuppArgs1, _, _, _) - _ }
	->
		{ SuppArgs = SuppArgs1 },
		magic_info_get_module_info(ModuleInfo),
		{ module_info_pred_proc_info(ModuleInfo, SuppPredId1,
			SuppProcId1, _, SuppProcInfo) },
		{ proc_info_argmodes(SuppProcInfo, SuppArgModes) },
		{ partition_args(ModuleInfo, SuppArgModes,
			SuppArgs, SuppInputArgs, SuppOutputArgs) }
	;
		{ error("project_supp_call: not a call") }
	),

		% Rename the outputs of the supp call,
		% but not the magic input relations.
	{ proc_info_vartypes(!.ProcInfo, VarTypes0) },
	{ map__apply_to_list(SuppOutputArgs, VarTypes0, SuppOutputArgTypes) },
	{ proc_info_create_vars_from_types(SuppOutputArgTypes,
		NewArgs, !ProcInfo) },
	{ map__from_corresponding_lists(SuppOutputArgs, NewArgs, Subn) },
	{ map__apply_to_list(UnrenamedInputVars, Subn, LambdaVars) },
	{ goal_util__rename_vars_in_goal(Subn, SuppCall, LambdaGoal0) },
	{ LambdaGoal0 = LambdaExpr - LambdaInfo0 },

	{ list__append(SuppInputArgs, LambdaVars, LambdaNonLocals0) },
	{ set__list_to_set(LambdaNonLocals0, LambdaNonLocals) },
	{ goal_info_set_nonlocals(LambdaNonLocals, LambdaInfo0, LambdaInfo) },
	{ LambdaGoal = LambdaExpr - LambdaInfo }.

%-----------------------------------------------------------------------------%

add_to_magic_predicate(PredProcId, Rule, RuleArgs) -->
	magic_info_get_magic_map(MagicMap),
	{ map__lookup(MagicMap, PredProcId, MagicPred) },
	magic_info_get_module_info(ModuleInfo0),
	{ MagicPred = proc(MagicPredId, MagicProcId) },
	{ module_info_preds(ModuleInfo0, Preds0) },
	{ map__lookup(Preds0, MagicPredId, MagicPredInfo0) },
	{ pred_info_procedures(MagicPredInfo0, MagicProcs0) },
	{ map__lookup(MagicProcs0, MagicProcId, MagicProcInfo0) },
	{ proc_info_goal(MagicProcInfo0, MagicGoal0) },

	{ proc_info_varset(MagicProcInfo0, MagicVarSet0) },
	{ proc_info_vartypes(MagicProcInfo0, MagicVarTypes0) },
	{ proc_info_headvars(MagicProcInfo0, MagicProcHeadVars) },

	magic_info_get_proc_info(ProcInfo),
	{ proc_info_vartypes(ProcInfo, VarTypes) },
	{ proc_info_varset(ProcInfo, VarSet) },

	%
	% Rename the variables in the supp predicate call.
	%
	{ map__from_corresponding_lists(RuleArgs, MagicProcHeadVars, Subn0) },
	{ goal_util__goal_vars(Rule, RuleVars0) },
	{ set__to_sorted_list(RuleVars0, RuleVars) },
	{ goal_util__create_variables(RuleVars, VarSet, VarTypes,
		MagicVarSet0, MagicVarSet, MagicVarTypes0, MagicVarTypes,
		Subn0, Subn) },
	{ Rule = RuleExpr - RuleInfo0 },
	{ set__list_to_set(RuleArgs, RuleArgSet) },
	{ goal_info_set_nonlocals(RuleArgSet, RuleInfo0, RuleInfo) },
	{ goal_util__must_rename_vars_in_goal(Subn, RuleExpr - RuleInfo,
		ExtraDisjunct) },

	%
	% Add in the new disjunct.
	%
	{ goal_to_disj_list(MagicGoal0, MagicDisjList0) },
	{ MagicGoal0 = _ - GoalInfo },	% near enough.
	{ disj_list_to_goal([ExtraDisjunct | MagicDisjList0],
		GoalInfo, MagicGoal) },
	{ proc_info_set_vartypes(MagicVarTypes,
		MagicProcInfo0, MagicProcInfo1) },
	{ proc_info_set_varset(MagicVarSet, MagicProcInfo1, MagicProcInfo2) },
	{ proc_info_set_goal(MagicGoal, MagicProcInfo2, MagicProcInfo) },
	{ map__det_update(MagicProcs0, MagicProcId, MagicProcInfo,
		MagicProcs) },
	{ pred_info_set_procedures(MagicProcs,
		MagicPredInfo0, MagicPredInfo) },
	{ map__det_update(Preds0, MagicPredId, MagicPredInfo, Preds) },
	{ module_info_set_preds(Preds, ModuleInfo0, ModuleInfo) },
	magic_info_set_module_info(ModuleInfo).

%-----------------------------------------------------------------------------%

magic_call_info(MagicPredId, MagicProcId,
		qualified(PredModule, PredName), InputRels,
		InputArgs, MagicOutputModes) -->
	magic_info_get_curr_pred_proc_id(PredProcId),
	magic_info_get_magic_proc_info(MagicProcInfo),
	{ map__lookup(MagicProcInfo, PredProcId, ThisProcInfo) },
	{ ThisProcInfo = magic_proc_info(OldArgModes, _, _, _, _) },
	magic_info_get_module_info(ModuleInfo),

	%
	% Get the arguments of the magic call.
	%
	magic_info_get_proc_info(ProcInfo0),
	{ proc_info_headvars(ProcInfo0, HeadVars) },
	{ proc_info_argmodes(ProcInfo0, ArgModes) },
	{ partition_args(ModuleInfo, ArgModes, HeadVars, _, OldHeadVars) },
	{ partition_args(ModuleInfo, OldArgModes, OldHeadVars, InputArgs, _) },
	{ partition_args(ModuleInfo, OldArgModes,
		OldArgModes, InputArgModes, _) },
	{ list__map(mode_to_output_mode(ModuleInfo),
		InputArgModes, MagicOutputModes) },

	magic_info_get_magic_vars(InputRels),

	magic_info_get_magic_map(MagicMap),
	{ map__lookup(MagicMap, PredProcId, proc(MagicPredId, MagicProcId)) },
	{ module_info_pred_info(ModuleInfo, MagicPredId, MagicPredInfo) },
	{ PredName = pred_info_name(MagicPredInfo) },
	{ PredModule = pred_info_module(MagicPredInfo) }.

%-----------------------------------------------------------------------------%

	% Create the supplementary predicate for a part of a goal that
	% has been transformed. If the goal is already a single call
	% this is unnecessary.
:- pred maybe_create_supp_call(list(hlds_goal)::in,
	set(prog_var)::in, list(prog_var)::in, term__context::in,
	hlds_goal::out, magic_info::in, magic_info::out) is det.

maybe_create_supp_call(PrevGoals, NonLocals, InputArgs,
		Context, SuppCall) -->
	(
		{ PrevGoals = [PrevGoal] },
		{ PrevGoal = call(_, _, _, _, _, _) - _ }
	->
		{ SuppCall = PrevGoal }
	;
		magic_info_get_magic_vars(MagicVars),
		{ order_supp_call_outputs(PrevGoals, MagicVars,
			NonLocals, InputArgs, SuppOutputArgs) },
		create_supp_call(PrevGoals, MagicVars,
			SuppOutputArgs, Context, [], SuppCall)
	).

	% If the supplementary call is to be used as input to
	% another call, attempt to get the arguments in the right order
	% to avoid an unnecessary projection. If this is not
	% possible, choose any order. If there are duplicates in the
	% call input list, a projection is unavoidable.
:- pred order_supp_call_outputs(list(hlds_goal)::in,
	list(prog_var)::in, set(prog_var)::in,
	list(prog_var)::in, list(prog_var)::out) is det.

order_supp_call_outputs(Goals, MagicVars, NonLocals,
		ArgsInOrder, Args) :-
	goal_list_nonlocals(Goals, SuppNonLocals),
	set__intersect(SuppNonLocals, NonLocals, SuppArgSet0),
	set__delete_list(SuppArgSet0, MagicVars, SuppArgSet1),
	(
		\+ (
			set__member(Arg, SuppArgSet1),
			\+ list__member(Arg, ArgsInOrder)
		)
	->
		Args = ArgsInOrder
	;
		set__to_sorted_list(SuppArgSet1, Args)
	).

:- pred create_supp_call(list(hlds_goal)::in, list(prog_var)::in,
	list(prog_var)::in, prog_context::in, list(marker)::in,
	hlds_goal::out, magic_info::in, magic_info::out) is det.

create_supp_call(Goals, MagicVars, SuppOutputArgs, Context,
		ExtraMarkers, SuppCall) -->

	{ list__append(MagicVars, SuppOutputArgs, SuppArgs) },

	%
	% Compute a goal_info for the call.
	%
	{ goal_list_instmap_delta(Goals, Delta0) },
	{ set__list_to_set(SuppArgs, SuppArgSet) },
	{ instmap_delta_restrict(SuppArgSet, Delta0, Delta) },
	{ goal_info_init(SuppArgSet, Delta, nondet, purity_pure, GoalInfo) },

	%
	% Verify that the supplementary predicate does not have any partially
	% instantiated or higher-order arguments other than the input closures.
	%
	magic_info_get_proc_info(ProcInfo),
	{ proc_info_vartypes(ProcInfo, VarTypes) },
	{ map__apply_to_list(SuppOutputArgs, VarTypes, SuppOutputTypes) },

	{ GetSuppMode = (pred(Var::in, Mode::out) is det :-
		( instmap_delta_search_var(Delta, Var, NewInst) ->
			Mode = (free -> NewInst)
		;
			% This is a lie, but we're only using this to check
			% that the output arguments aren't partially
			% instantiated. Any arguments that are partially
			% instantiated in the initial instmap for the
			% procedure will be reported there.
			Mode = (ground(shared, none) -> ground(shared, none))
		)
	) },
	{ list__map(GetSuppMode, SuppOutputArgs, SuppOutputModes) },
	check_args(SuppOutputArgs, SuppOutputModes,
		SuppOutputTypes, Context, var_name),

	%
	% Fill in the fields of the new predicate.
	%
	magic_info_get_pred_info(PredInfo),
	magic_info_get_curr_pred_proc_id(proc(_, ProcId)),
	make_pred_name(PredInfo, ProcId, "Supp_Proc_For",
		yes, NewName),

	magic_info_get_module_info(ModuleInfo0),
	{ proc_info_get_initial_instmap(ProcInfo, ModuleInfo0, InstMap) },
	{ proc_info_inst_varset(ProcInfo, InstVarSet) },
	{ pred_info_get_aditi_owner(PredInfo, Owner) },
	{ pred_info_get_markers(PredInfo, Markers0) },
	{ list__foldl(add_marker, ExtraMarkers, Markers0, Markers) },

	% Add the predicate to the predicate table.
	{ conj_list_to_goal(Goals, GoalInfo, SuppGoal) },
	{ varset__init(TVarSet) },
	{ ClassConstraints = constraints([], []) },
	{ rtti_varmaps_init(RttiVarMaps) },
	{ proc_info_varset(ProcInfo, VarSet) },
	{ unqualify_name(NewName, NewPredName) },
	{ hlds_pred__define_new_pred(created(aditi_magic_supp), SuppGoal,
		SuppCall, SuppArgs, ExtraArgs, InstMap, NewPredName, TVarSet,
		VarTypes, ClassConstraints, RttiVarMaps, VarSet, InstVarSet,
		Markers, Owner, address_is_not_taken, ModuleInfo0, ModuleInfo,
		_) },
	{ ExtraArgs = [] ->
		true
	;
		error("create_supp_call: typeinfo arguments")
	},
	magic_info_set_module_info(ModuleInfo).

%-----------------------------------------------------------------------------%

mode_to_output_mode(ModuleInfo, Mode, OutputMode) :-
	mode_get_insts(ModuleInfo, Mode, _, FinalInst),
	OutputMode = (free -> FinalInst).

%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%

check_args(Vars, Modes, Types, Context, IdType) -->
	(
		check_args_2(Vars, Modes, Types, Context,
			1, IdType, no_rtti, MaybeRtti)
	->
		(
			{ MaybeRtti = no_rtti }
		;
			{ MaybeRtti = found_rtti(RttiArg) },
			magic_info_get_error_pred_proc_id(PredProcId),
			magic_info_get_errors(Errors0),
			{ Error = nonspecific_polymorphism(PredProcId, RttiArg)
					- Context },
			{ set__insert(Errors0, Error, Errors) },
			magic_info_set_errors(Errors)
		;
			{ MaybeRtti = found_polymorphic }
		)
	;
		{ error("check_args") }
	).

:- pred check_args_2(list(prog_var)::in, list(mer_mode)::in,
	list(mer_type)::in, term__context::in, int::in,
	magic_arg_id_type::in, rtti_arg_state::in, rtti_arg_state::out,
	magic_info::in, magic_info::out) is semidet.

check_args_2([], [], [], _, _, _, Rtti, Rtti) --> [].
check_args_2([Var | Vars], [ArgMode | ArgModes],
		[ArgType | ArgTypes], Context, ArgNo,
		ArgIdType, Rtti0, Rtti) -->
	magic_info_get_error_vars(ErrorVars0),
	( { set__member(Var, ErrorVars0) } ->
		{ NextArgNo = ArgNo + 1 },
		{ Rtti1 = Rtti0 }
	;
		(
			{ ArgIdType = arg_number },
			{ ArgId = arg_number(ArgNo) }
		;
			{ ArgIdType = var_name },
			magic_info_get_proc_info(ProcInfo),
			{ proc_info_varset(ProcInfo, VarSet) },
			{ varset__lookup_name(VarSet, Var, VarName) },
			{ ArgId = var_name(VarName) }
		),

		magic_info_get_error_pred_proc_id(PredProcId),
		magic_info_get_module_info(ModuleInfo),
		( { type_is_aditi_state(ArgType) } ->
			(
				{ \+ mode_is_input(ModuleInfo, ArgMode) },

				% The second `aditi__state' of the closure
				% passed to `aditi_bulk_modify' has mode
				% `unused'.
				{ \+ mode_is_unused(ModuleInfo, ArgMode) }
			->
				% aditi__states must not be output.
				{ StateError =
					[argument_error(output_aditi_state,
						ArgId, PredProcId) - Context] }
			;
				{ StateError = [] }
			)
		;
			{ StateError = [] }
		),

			% Check that the argument types are legal.
		check_type(ArgType, ErrorTypes, MaybeRtti),
		{ set__to_sorted_list(ErrorTypes, ErrorTypeList0) },

			% Check that partially instantiated modes are not used.
		{ mode_get_insts(ModuleInfo, ArgMode, Inst1, Inst2) },
		(
			{ inst_is_free(ModuleInfo, Inst1)
			; inst_is_ground(ModuleInfo, Inst1)
			},
			{ inst_is_free(ModuleInfo, Inst2)
			; inst_is_ground(ModuleInfo, Inst2)
			}
		->
			{ ErrorTypeList = ErrorTypeList0 }
		;
			{ ErrorTypeList =
				[partially_instantiated | ErrorTypeList0] }
		),

		{ ConvertError =
			(pred(ErrorType::in, MagicError::out) is det :-
				MagicError = argument_error(ErrorType,
					ArgId, PredProcId) - Context
			) },
		{ list__map(ConvertError, ErrorTypeList, TypeErrors) },

		( { TypeErrors = [] } ->
			{ set__insert(ErrorVars0, Var, ErrorVars) },
			magic_info_set_error_vars(ErrorVars)
		;
			[]
		),
		magic_info_get_errors(Errors0),
		{ set__insert_list(Errors0, TypeErrors, Errors1) },
		{ set__insert_list(Errors1, StateError, Errors) },
		magic_info_set_errors(Errors),

		{ list__member(polymorphic, ErrorTypeList) ->
			NextArgNo = ArgNo + 1,
			Rtti1 = found_polymorphic
		; MaybeRtti = yes(RttiArg) ->
			% Don't count type-infos when working
			% out what number the current argument is.
			NextArgNo = ArgNo,
			update_rtti_arg_state(Rtti0, RttiArg, Rtti1)
		;
			NextArgNo = ArgNo + 1,
			Rtti1 = Rtti0
		}
	),
	check_args_2(Vars, ArgModes, ArgTypes,
		Context, NextArgNo, ArgIdType, Rtti1, Rtti).

%-----------------------------------------------------------------------------%

:- type rtti_arg_state
	--->	no_rtti
	;	found_rtti(rtti_arg)
	;	found_polymorphic	% Report errors for the polymorphic
					% arguments, but don't report for the
					% typeinfos and typeclass infos
	.

:- pred update_rtti_arg_state(rtti_arg_state::in,
	rtti_arg::in, rtti_arg_state::out) is det.

update_rtti_arg_state(no_rtti, Arg, found_rtti(Arg)).
update_rtti_arg_state(found_rtti(Arg0), Arg1, found_rtti(Arg)) :-
	update_rtti_arg(Arg0, Arg1, Arg).
update_rtti_arg_state(found_polymorphic, _, found_polymorphic).

:- pred update_rtti_arg(rtti_arg::in, rtti_arg::in, rtti_arg::out) is det.

update_rtti_arg(both, _, both).
update_rtti_arg(type_info, type_info, type_info).
update_rtti_arg(type_info, typeclass_info, both).
update_rtti_arg(type_info, both, both).
update_rtti_arg(typeclass_info, typeclass_info, typeclass_info).
update_rtti_arg(typeclass_info, type_info, both).
update_rtti_arg(typeclass_info, both, both).

%-----------------------------------------------------------------------------%


	% Go over a type collecting any reasons why that type cannot
	% be an argument type of an Aditi relation.
:- pred check_type(mer_type::in, set(argument_error)::out,
	maybe(rtti_arg)::out, magic_info::in, magic_info::out) is det.

check_type(ArgType, Errors, MaybeRtti) -->

	% Polymorphic types are not allowed.
	% Errors for type_infos and typeclass_infos are only reported
	% if there are no other polymorphic arguments.
	( { polymorphism__type_is_type_info_or_ctor_type(ArgType) } ->
		{ set__init(Errors) },
		{ MaybeRtti = yes(type_info) }
	; { polymorphism__type_is_typeclass_info(ArgType) } ->
		{ set__init(Errors) },
		{ MaybeRtti = yes(typeclass_info) }
	;
		{ MaybeRtti = no },
		{ set__init(Errors0) },
		{ type_is_ground(ArgType) ->
			Errors1 = Errors0
		;
			set__insert(Errors0, polymorphic, Errors1)
		},

		{ set__init(Parents) },
		traverse_type(yes, Parents, ArgType,
			Errors1, Errors)
	).

:- pred traverse_type(bool::in, set(type_ctor)::in, mer_type::in,
	set(argument_error)::in, set(argument_error)::out,
	magic_info::in, magic_info::out) is det.

traverse_type(IsTopLevel, Parents, ArgType, Errors0, Errors) -->
	magic_info_get_module_info(ModuleInfo),
	( { type_is_atomic(ArgType, ModuleInfo) } ->
		{ Errors = Errors0 }
	; { type_is_higher_order(ArgType, _, _, _, _) } ->
		% Higher-order types are not allowed.
		{ set__insert(Errors0, higher_order, Errors) }
	; { type_is_tuple(ArgType, TupleArgTypes) } ->
		list__foldl2(traverse_type(no, Parents),
			TupleArgTypes, Errors0, Errors)
	; { type_is_aditi_state(ArgType) } ->
		( { IsTopLevel = no } ->
			{ set__insert(Errors0, embedded_aditi_state, Errors) }
		;
			{ Errors = Errors0 }
		)
	;
		% The type is user-defined.
		( { type_to_ctor_and_args(ArgType, TypeCtor, Args) } ->
			check_type_ctor(Parents, TypeCtor,
				Errors0, Errors1),
			list__foldl2(traverse_type(no, Parents),
				Args, Errors1, Errors)
		;
			% type variable - the type parameters
			% are checked separately.
			{ Errors = Errors0 }
		)
	).

:- pred check_type_ctor(set(type_ctor)::in, type_ctor::in,
	set(argument_error)::in, set(argument_error)::out,
	magic_info::in, magic_info::out) is det.

check_type_ctor(Parents, TypeCtor, Errors0, Errors) -->
	magic_info_get_ok_types(OKTypes0),
	magic_info_get_bad_types(BadTypes0),
	( { set__member(TypeCtor, Parents) } ->
		{ Errors = Errors0 }
	; { set__member(TypeCtor, OKTypes0) } ->
		{ Errors = Errors0 }
	; { map__search(BadTypes0, TypeCtor, TypeErrors) } ->
		{ set__union(Errors0, TypeErrors, Errors) }
	;
		magic_info_get_module_info(ModuleInfo),
		{ module_info_get_type_table(ModuleInfo, Types) },
		{ map__lookup(Types, TypeCtor, TypeDefn) },
		{ hlds_data__get_type_defn_body(TypeDefn, TypeBody) },
		{ set__init(NewErrors0) },
		{ set__insert(Parents, TypeCtor, Parents1) },
		check_type_defn(TypeBody, Parents1,
			NewErrors0, NewErrors),
		( { set__empty(NewErrors) } ->
			{ set__insert(OKTypes0, TypeCtor, OKTypes) },
			{ Errors = Errors0 },
			magic_info_set_ok_types(OKTypes)
		;
			{ map__det_insert(BadTypes0, TypeCtor,
				NewErrors, BadTypes) },
			{ set__union(Errors0, NewErrors, Errors) },
			magic_info_set_bad_types(BadTypes)
		)
	).

:- pred check_type_defn(hlds_type_body::in, set(type_ctor)::in,
	set(argument_error)::in, set(argument_error)::out,
	magic_info::in, magic_info::out) is det.

check_type_defn(du_type(Ctors, _, _, _, _, _),
		Parents, Errors0, Errors) -->
	list__foldl2(check_ctor(Parents), Ctors, Errors0, Errors).
check_type_defn(eqv_type(_), _, _, _) -->
	{ error("check_type_defn: eqv_type") }.
check_type_defn(abstract_type(_), _, Errors0, Errors) -->
	{ set__insert(Errors0, abstract, Errors) }.
check_type_defn(foreign_type(_), _, _, _) -->
	{ error("check_type_defn: foreign_type") }.
check_type_defn(solver_type(_, _), _, _, _) -->
	{ error("check_type_defn: solver_type") }.

:- pred check_ctor(set(type_ctor)::in, constructor::in,
	set(argument_error)::in, set(argument_error)::out,
	magic_info::in, magic_info::out) is det.

check_ctor(Parents, ctor(ExistQVars, _, _, CtorArgs),
		Errors0, Errors) -->
	( { ExistQVars = [] } ->
		{ assoc_list__values(CtorArgs, CtorArgTypes) },
		list__foldl2(traverse_type(no, Parents),
			CtorArgTypes, Errors0, Errors)
	;
		{ set__insert(Errors0, existentially_typed, Errors) }
	).

%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%

:- interface.

	% Information from the preprocessing pass about the magic input
	% variables for a procedure.
:- type magic_proc_info
	--->	magic_proc_info(
			list(mer_mode),	% pre-transformation arg modes
					% (minus aditi__states).
			list(prog_var),	% magic input vars.
			list(mer_type),	% types of magic input vars.
			list(mer_mode),	% modes of magic input vars.
			maybe(int)	% index of this proc's magic
					% input var in the above lists,
					% no if the procedure is not
					% an entry point of the sub-module.
		).

	% Map from post-transformation pred_proc_id to the
	% corresponding magic predicate. Magic predicates
	% collect the tuples which would occur as inputs in
	% a top-down execution.
:- type magic_map	==	map(pred_proc_id, pred_proc_id).

	% Map from pre-transformation pred_proc_id to
	% post transformation pred_proc_id.
:- type pred_map	==	map(pred_proc_id, pred_proc_id).

:- type magic_errors == set(magic_error).

:- type magic_info.

:- pred magic_info_init(module_info::in, magic_info::out) is det.

:- pred magic_info_get_module_info(module_info::out, magic_info::in,
	magic_info::out) is det.
:- pred magic_info_get_error_pred_proc_id(pred_proc_id::out, magic_info::in,
	magic_info::out) is det.
:- pred magic_info_get_curr_pred_proc_id(pred_proc_id::out, magic_info::in,
	magic_info::out) is det.
:- pred magic_info_get_pred_info(pred_info::out, magic_info::in,
	magic_info::out) is det.
:- pred magic_info_get_proc_info(proc_info::out, magic_info::in,
	magic_info::out) is det.
:- pred magic_info_get_scc(list(pred_proc_id)::out, magic_info::in,
	magic_info::out) is det.
:- pred magic_info_get_magic_map(magic_map::out, magic_info::in,
	magic_info::out) is det.
:- pred magic_info_get_magic_vars(list(prog_var)::out, magic_info::in,
	magic_info::out) is det.
:- pred magic_info_get_magic_var_map(map(pred_proc_id, prog_var)::out,
	magic_info::in, magic_info::out) is det.
:- pred magic_info_get_next_supp_id(int::out, magic_info::in,
	magic_info::out) is det.
:- pred magic_info_get_magic_proc_info(map(pred_proc_id, magic_proc_info)::out,
	magic_info::in, magic_info::out) is det.
:- pred magic_info_get_pred_map(pred_map::out,
	magic_info::in, magic_info::out) is det.
:- pred magic_info_get_error_vars(set(prog_var)::out,
	magic_info::in, magic_info::out) is det.
:- pred magic_info_get_errors(magic_errors::out,
	magic_info::in, magic_info::out) is det.
:- pred magic_info_get_ok_types(set(type_ctor)::out,
	magic_info::in, magic_info::out) is det.
:- pred magic_info_get_bad_types(map(type_ctor, set(argument_error))::out,
	magic_info::in, magic_info::out) is det.

:- pred magic_info_set_module_info(module_info::in, magic_info::in,
	magic_info::out) is det.
:- pred magic_info_set_error_pred_proc_id(pred_proc_id::in, magic_info::in,
	magic_info::out) is det.
:- pred magic_info_set_curr_pred_proc_id(pred_proc_id::in, magic_info::in,
	magic_info::out) is det.
:- pred magic_info_set_pred_info(pred_info::in, magic_info::in,
	magic_info::out) is det.
:- pred magic_info_set_proc_info(proc_info::in, magic_info::in,
	magic_info::out) is det.
:- pred magic_info_set_scc(list(pred_proc_id)::in, magic_info::in,
	magic_info::out) is det.
:- pred magic_info_set_magic_map(magic_map::in, magic_info::in,
	magic_info::out) is det.
:- pred magic_info_set_magic_vars(list(prog_var)::in, magic_info::in,
	magic_info::out) is det.
:- pred magic_info_set_magic_var_map(map(pred_proc_id, prog_var)::in,
	magic_info::in, magic_info::out) is det.
:- pred magic_info_set_magic_proc_info(map(pred_proc_id, magic_proc_info)::in,
	magic_info::in, magic_info::out) is det.
:- pred magic_info_set_pred_map(pred_map::in,
	magic_info::in, magic_info::out) is det.
:- pred magic_info_set_error_vars(set(prog_var)::in,
	magic_info::in, magic_info::out) is det.
:- pred magic_info_set_errors(magic_errors::in,
	magic_info::in, magic_info::out) is det.
:- pred magic_info_set_ok_types(set(type_ctor)::in,
	magic_info::in, magic_info::out) is det.
:- pred magic_info_set_bad_types(map(type_ctor, set(argument_error))::in,
	magic_info::in, magic_info::out) is det.

%-----------------------------------------------------------------------------%

:- implementation.

:- type magic_info --->
	magic_info(
		module_info		:: module_info,
		error_pred_proc_id	:: maybe(pred_proc_id),
		curr_pred_proc_id	:: maybe(pred_proc_id),
		pred_info		:: maybe(pred_info),
		proc_info		:: maybe(proc_info),
		scc			:: list(pred_proc_id),
					% preds in the current sub-module
		magic_map		:: magic_map,
					% magic pred_proc_id for
					% each pred_proc_id

		magic_vars		:: list(prog_var),
					% magic input variables

		magic_var_map		:: map(pred_proc_id, prog_var),
					% magic input variables for
					% each entry-point of the
					% sub-module
		next_supp_id		:: int,	% next supp id
		magic_proc_info		:: map(pred_proc_id, magic_proc_info),
		pred_map		:: pred_map,
					% map from old to transformed
					% pred_proc_id
		error_vars		:: set(prog_var),
					% vars for which errors have
					% been reported.
		errors			:: magic_errors,
		ok_types		:: set(type_ctor),
					% type_ctors which are allowed
					% as argument types of
					% Aditi predicates. A type
					% is ok if no part of it is
					% higher-order or abstract.
		bad_types		:: map(type_ctor, set(argument_error))
					% type_ctors which are not ok
					% as Aditi argument types.
	).

%-----------------------------------------------------------------------------%

magic_info_init(ModuleInfo, MagicInfo) :-
	map__init(MagicMap),
	map__init(VarMap),
	map__init(MagicProcInfo),
	map__init(PredMap),
	set__init(Errors),
	set__init(OKTypes),
	map__init(BadTypes),
	set__init(ErrorVars),
	MagicInfo = magic_info(ModuleInfo, no, no, no, no, [], MagicMap, [],
		VarMap, 1, MagicProcInfo, PredMap, ErrorVars, Errors,
		OKTypes, BadTypes).

magic_info_get_module_info(Info ^ module_info, Info, Info).

magic_info_get_error_pred_proc_id(PredProcId, Info, Info) :-
	( Info ^ error_pred_proc_id = yes(PredProcId1) ->
		PredProcId = PredProcId1
	;
		error("magic_info_get_error_pred_proc_id")
	).

magic_info_get_curr_pred_proc_id(PredProcId, Info, Info) :-
	( Info ^ curr_pred_proc_id = yes(PredProcId1) ->
		PredProcId = PredProcId1
	;
		error("magic_info_get_curr_pred_proc_id")
	).

magic_info_get_pred_info(PredInfo, Info, Info) :-
	( Info ^ pred_info = yes(PredInfo1) ->
		PredInfo = PredInfo1
	;
		error("magic_info_get_pred_info")
	).

magic_info_get_proc_info(ProcInfo, Info, Info) :-
	( Info ^ proc_info = yes(ProcInfo1) ->
		ProcInfo = ProcInfo1
	;
		error("magic_info_get_proc_info")
	).

magic_info_get_scc(Info ^ scc, Info, Info).

magic_info_get_magic_map(Info ^ magic_map, Info, Info).

magic_info_get_magic_vars(Info ^ magic_vars, Info, Info).

magic_info_get_magic_var_map(Info ^ magic_var_map, Info, Info).

magic_info_get_next_supp_id(SuppId0, Info0,
			Info0 ^ next_supp_id := SuppId0 + 1) :-
		SuppId0 = Info0 ^ next_supp_id.

magic_info_get_magic_proc_info(Info ^ magic_proc_info, Info, Info).

magic_info_get_pred_map(Info ^ pred_map, Info, Info).

magic_info_get_error_vars(Info ^ error_vars, Info, Info).

magic_info_get_errors(Info ^ errors, Info, Info).

magic_info_get_ok_types(Info ^ ok_types, Info, Info).

magic_info_get_bad_types(Info ^ bad_types, Info, Info).

%-----------------------------------------------------------------------------%

magic_info_set_module_info(ModuleInfo, Info, Info ^ module_info := ModuleInfo).

magic_info_set_error_pred_proc_id(PredProcId, Info0,
		Info0 ^ error_pred_proc_id := yes(PredProcId)).

magic_info_set_curr_pred_proc_id(PredProcId, Info0,
		Info0 ^ curr_pred_proc_id := yes(PredProcId)).

magic_info_set_pred_info(PredInfo, Info0, Info0 ^ pred_info := yes(PredInfo)).

magic_info_set_proc_info(ProcInfo, Info0, Info0 ^ proc_info := yes(ProcInfo)).

magic_info_set_scc(SCC, Info0, Info0 ^ scc := SCC).

magic_info_set_magic_map(MagicMap, Info0, Info0 ^ magic_map := MagicMap).

magic_info_set_magic_vars(Vars, Info0, Info0 ^ magic_vars := Vars).

magic_info_set_magic_var_map(Map, Info0, Info0 ^ magic_var_map := Map).

magic_info_set_magic_proc_info(MagicProcInfo, Info0,
		Info0 ^ magic_proc_info := MagicProcInfo).

magic_info_set_pred_map(PredMap, Info0, Info0 ^ pred_map := PredMap).

magic_info_set_error_vars(ErrorVars, Info0, Info0 ^ error_vars := ErrorVars).

magic_info_set_errors(Errors, Info0, Info0 ^ errors := Errors).

magic_info_set_ok_types(Types, Info0, Info0 ^ ok_types := Types).

magic_info_set_bad_types(Types, Info0, Info0 ^ bad_types := Types).

%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
% Error handling.

:- interface.

:- type magic_error == pair(magic_error_type, term__context).

:- type magic_arg_id_type
	--->	arg_number
	;	var_name
	.

:- type magic_arg_id
	--->	arg_number(int)
	;	var_name(string)
	.

:- type rtti_arg
	--->	type_info
	;	typeclass_info
	;	both
	.

:- type magic_error_type
	--->	argument_error(argument_error, magic_arg_id, pred_proc_id)
				% The maybe(int) here is an argument number.
				% If there is no argument number the error
				% occurred creating a supplementary predicate.
	;	nonspecific_polymorphism(pred_proc_id, rtti_arg)
				% There are type-info or typeclass-info
				% arguments, but there are no polymorphic
				% arguments.
	;	curried_argument(pred_proc_id)
				% Curried args to an aggregate closure are NYI.
	;	non_removeable_aditi_state(pred_proc_id,
			prog_varset, list(prog_var))
				% Other than in database calls, `aditi:state'
				% variables can only occur in assignment
				% unifications, since magic sets needs to
				% be able to remove them.
	;	context_error(linearity_error, pred_proc_id)
	;	mutually_recursive_context(pred_proc_id, list(pred_proc_id))
				% Procedures with a `context' marker must
				% not be mutually recursive with other
				% predicates.
	;	mixed_scc(list(pred_proc_id))
				% SCC with Aditi and non-Aditi components.
	.

:- type argument_error
	--->	partially_instantiated
	;	higher_order
	;	abstract
	;	polymorphic
	;	existentially_typed
	;	output_aditi_state
	;	embedded_aditi_state
	.

:- type linearity_error
	--->	end_goals_not_recursive
			% For a goal to be linear, either the first or
			% the last goal must be a recursive call.

	;	multi_rec_goal_not_multi_linear
			% The last call in a rule with multiple recursive
			% calls was not recursive.

	;	inputs_to_recursive_call
			% for the recursive call in a left-linear rule,
			% and for the internal recursive calls in
			% a multi-linear rule, the inputs must be the
			% inputs to the procedure.

	;	outputs_of_recursive_call
			% for the last recursive call in a right- or
			% multi-linear rule, the outputs must be the
			% outputs of the procedure.

	;	inputs_occur_in_other_goals
			% For left-linear rules, the inputs to the procedure
			% may only occur in the recursive call.
			% For multi-linear rules, the inputs to the procedure
			% may only occur as inputs to the interior recursive
			% calls.

	;	multi_inputs_occur_in_last_rec_call
			% For multi-linear predicates, the inputs
			% to the last recursive call may not include
			% any inputs to the procedure.
	.

%-----------------------------------------------------------------------------%

:- implementation.

report_errors(Errors, ModuleInfo, Verbose, !IO) :-
	list__foldl(report_error(ModuleInfo, Verbose),
		Errors, !IO).

:- pred report_error(module_info::in, bool::in, magic_error::in,
	io::di, io::uo) is det.

report_error(ModuleInfo, Verbose, MagicError - Context, !IO) :-
	MagicError = argument_error(Error, Arg, proc(PredId, _)),
	PredNamePieces = describe_one_pred_name(ModuleInfo,
		should_module_qualify, PredId),
	InPieces = [words("In Aditi") | PredNamePieces] ++ [suffix(":"), nl],
	error_arg_id_piece(Arg, ArgPiece),
	report_argument_error(Context, Error, ArgPiece, Verbose,
		ReportPieces),
	write_error_pieces(Context, 0, InPieces ++ ReportPieces, !IO).

report_error(ModuleInfo, _Verbose, MagicError - Context, !IO) :-
	MagicError = nonspecific_polymorphism(proc(PredId, _), _),
	PredNamePieces = describe_one_pred_name(ModuleInfo,
		should_module_qualify, PredId),
	Pieces = [words("In") | PredNamePieces] ++ [suffix(":"), nl,
		words("the code uses polymorphism or type-classes"),
		words("which are not supported by Aditi.")],
	write_error_pieces(Context, 0, Pieces, !IO).

report_error(ModuleInfo, _Verbose, MagicError - Context, !IO) :-
	MagicError = curried_argument(proc(PredId, _)),
	PredNamePieces = describe_one_pred_name(ModuleInfo,
		should_module_qualify, PredId),
	Pieces = [words("In") | PredNamePieces] ++ [suffix(":"), nl,
		words("sorry, curried closure arguments are not"),
		words("implemented for Aditi procedures."),
		words("Construct them within the closure instead.")],
	write_error_pieces(Context, 0, Pieces, !IO).

report_error(ModuleInfo, _Verbose, MagicError - Context, !IO) :-
	MagicError = non_removeable_aditi_state(proc(PredId, _), VarSet, Vars),
	PredNamePieces = describe_one_pred_name(ModuleInfo,
		should_module_qualify, PredId),
	InPieces = [words("In") | PredNamePieces] ++ [suffix(":"), nl],
	( Vars = [_] ->
		VarPiece = words("variable"),
		StatePiece = words("is a non-removable `aditi.state'.")
	;
		VarPiece = words("variables"),
		StatePiece = words("are non-removable `aditi.state's.")
	),
	list__map(varset__lookup_name(VarSet), Vars, VarNames),
	VarNamePieces = error_util__list_to_pieces(VarNames),
	Pieces = InPieces ++ [VarPiece] ++ VarNamePieces ++ [StatePiece],
	write_error_pieces(Context, 0, Pieces, !IO).

report_error(ModuleInfo, Verbose, MagicError - Context, !IO) :-
	MagicError = context_error(Error, proc(PredId, _ProcId)),
	PredNamePieces = describe_one_pred_name(ModuleInfo,
		should_module_qualify, PredId),
	report_linearity_error(ModuleInfo,
		Context, Verbose, Error, LinearityPieces),
	Pieces = [words("In") | PredNamePieces] ++ [suffix(":"), nl,
		words("with `:- pragma context(...)' declaration:"), nl,
		words("error: recursive rule is not linear.")]
		++ LinearityPieces,
	write_error_pieces(Context, 0, Pieces, !IO).

report_error(ModuleInfo, _Verbose, MagicError - Context, !IO) :-
	MagicError = mutually_recursive_context(PredProcId, OtherPredProcIds),
	ProcPieces = describe_one_proc_name(ModuleInfo,
		should_module_qualify, PredProcId),
	OtherProcPieces = describe_several_proc_names(ModuleInfo,
		should_module_qualify, OtherPredProcIds),
	Pieces = [words("Error: procedure")] ++ ProcPieces ++
		[words("with a"), fixed("`:- pragma context(...)'"),
		words("declaration is mutually recursive with")]
		++ OtherProcPieces ++ [suffix(".")],
	write_error_pieces(Context, 0, Pieces, !IO).

report_error(ModuleInfo, _Verbose, MagicError - Context, !IO) :-
	MagicError = mixed_scc(PredProcIds),
	SCCPieces = describe_several_proc_names(ModuleInfo,
		should_module_qualify, PredProcIds),
	Pieces = [words("In the strongly connected component consisting of")]
		++ SCCPieces ++
		[words("some, but not all procedures are marked"),
		words("for Aditi compilation.")],
	write_error_pieces(Context, 0, Pieces, !IO).

:- pred error_arg_id_piece(magic_arg_id::in,
	format_component::out) is det.

error_arg_id_piece(arg_number(ArgNo), words(ArgWords)) :-
	string__int_to_string(ArgNo, ArgStr),
	string__append("argument ", ArgStr, ArgWords).
error_arg_id_piece(var_name(Name), words(NameStr)) :-
	string__append_list(["`", Name, "'"], NameStr).

:- pred report_argument_error(term__context::in,
	argument_error::in, format_component::in, bool::in,
	list(format_component)::out) is det.

report_argument_error(_Context, partially_instantiated,
		ArgPiece, _Verbose, Pieces) :-
	Pieces = [ArgPiece, words("is partially instantiated.")].
report_argument_error(_Context, higher_order,
		ArgPiece, _, Pieces) :-
	Pieces = [words("the type of"), ArgPiece, words("is higher order.")].
report_argument_error(_Context, polymorphic, ArgPiece, _, Pieces) :-
	Pieces = [words("the type of"), ArgPiece, words("is polymorphic.")].
report_argument_error(_Context, existentially_typed,
		ArgPiece, _, Pieces) :-
	Pieces = [words("the type of"), ArgPiece,
		words("contains existentially typed constructors.")].
report_argument_error(_Context, abstract, ArgPiece, _, Pieces) :-
	Pieces = [words("the type of"), ArgPiece,
			words("contains abstract types.")].
report_argument_error(_Context, output_aditi_state,
		ArgPiece, _, Pieces) :-
	Pieces = [ArgPiece, words("is an output `aditi.state'.")].
report_argument_error(_Context, embedded_aditi_state,
		ArgPiece, _, Pieces) :-
	Pieces = [words("the type of"), ArgPiece,
		words("contains an embedded `aditi.state'.")].

:- pred report_linearity_error(module_info::in, term__context::in,
	bool::in, linearity_error::in, list(format_component)::out) is det.

report_linearity_error(_ModuleInfo, _Context, _Verbose,
		end_goals_not_recursive, Pieces) :-
	Pieces = [words("For a rule to be linear, either the first or last"),
		words("goal must be a recursive call.")].
report_linearity_error(_ModuleInfo, _Context, _Verbose,
		multi_rec_goal_not_multi_linear, Pieces) :-
	Pieces = [words("The rule contains multiple recursive calls but is"),
		words("not multi-linear because the last goal"),
		words("is not recursive.")].
report_linearity_error(_ModuleInfo, _Context, _Verbose,
		inputs_to_recursive_call, Pieces) :-
	Pieces = [words("For the rule to be linear, the input variables of"),
		words("this recursive call must be the same as the input"),
		words("variables of the clause head.")].
report_linearity_error(_, _, _,
		outputs_of_recursive_call, Pieces) :-
	Pieces = [words("For the rule to be linear, the output variables of"),
		words("this recursive call must be the same as the output"),
		words("variables of the clause head.")].
report_linearity_error(_, _, _,
		inputs_occur_in_other_goals, Pieces) :-
	Pieces = [words("The inputs to the rule may only occur in"),
		words("recursive calls, unless the rule is right-linear.")].
report_linearity_error(_, _, _,
		multi_inputs_occur_in_last_rec_call, Pieces) :-
	Pieces = [words("In a multi-linear rule, the inputs to the"),
		words("procedure may not occur as arguments of the last"),
		words("recursive call.")].

%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%