[m-dev.] for review: `possible' alias analysis stage

[Nancy MAZUR]

Hi, 

here's the code.

waiting to be shot (can I be blindfolded, please?),
Nancy

===================================================================

estimated hours taken: 100

Added `possible' alias analysis stage (before unique modes analysis).
(definition: possible alias, as opposed to definite aliasing, 
expresses whether two datastructures might be (partially) aliased
to one another at run-time.)

To switch analysis on: --infer-possible-aliases
To dump alias-information into the dump-hlds: --dump-hlds-options kulalias
	(or --dump-hlds-options k )

The analysis considers only first order code, works on an
intermodular basis (i.e. generates and loads interface-files,
which I gave the extension "opt.ka"), and at this moment fails
on everything that cannot be handled:
	- higher-order calls / typeclasses
	- special calls (c-code, .. )
	- calls to predicates of a module for which no interface-file
	  has been loaded (i.e. no non-local alias information available).

Near-future changes: 
	- instead of failing, handle special calls appropriately and
	  proceed (i.e. introduce `top' as abstract substitution);
	- calls to predicates handling builtin-types could be
	  shortcutted in the sense that aliases cannot be created.
	- abstract representations of the aliases are normalized
	  after each analysis of a procedure. This normalization 
	  is now based solely on the type-information (and thus
	  tails of lists are mapped to lists), and ought to be
	  extended to take into account the instmaps of the variables
	  concerned.

Less near future changes:
	- higher-order?
	- abstract data-types?


===
compiler/handle_options.m
compiler/hlds_out.m 
	added option/handler to print alias information in hlds_dumps
	(`kulalias' or `k')

compiler/options.m
compiler/mercury_compile.m
	added option/handler to switch on alias analysis
	(`infer-possible-aliases')

compiler/prog_data.m
compiler/prog_io_pragma.m
compiler/module_qual.m
compiler/modules.m
compiler/mercury_to_mercury.m
compiler/make_hlds.m
	added new prog_data__pragma_type constructor: ka_alias_info/5
	added new pragma-declaration: ka_alias_info/3
		:- pragma ka_alias_info( <small pred declaration>,
			vars( <list of headvars> ), 
			maybe( <printed alias-information> ) ).
		This pragma-declaration is not intended to be 
		used directly by the programmer.

compiler/hlds_pred.m: 
	added new field in proc_info

===
new files:  (ka = KUL-alias)
compiler/ka_alias_as.m  : definition of the abstract substitution and
			 it's primitive operations
compiler/ka_run.m : main module for effectively running the analysis pass
compiler/ka_util.m : some extra types/procedures, mainly definition of
		a fixpoint table.


Index: handle_options.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/handle_options.m,v
retrieving revision 1.88
diff -u -r1.88 handle_options.m
--- handle_options.m	2000/01/10 05:26:18	1.88
+++ handle_options.m	2000/02/08 00:15:19
@@ -854,9 +854,11 @@
 :- pred convert_dump_alias(string, string).
 :- mode convert_dump_alias(in, out) is semidet.
 
-convert_dump_alias("ALL", "abcdfgilmnprstuvCIMPTU").
-convert_dump_alias("all", "abcdfgilmnprstuvCMPT").
+convert_dump_alias("ALL", "abcdfgiklmnprstuvCIMPTU").
+convert_dump_alias("all", "abcdfgiklmnprstuvCMPT").
 convert_dump_alias("codegen", "dfnprsu").
 convert_dump_alias("vanessa", "ltuCIU").
 convert_dump_alias("paths", "cP").
 convert_dump_alias("petdr", "din").
+convert_dump_alias("kulalias", "k").
+
Index: hlds_out.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_out.m,v
retrieving revision 1.235
diff -u -r1.235 hlds_out.m
--- hlds_out.m	2000/01/13 06:15:45	1.235
+++ hlds_out.m	2000/02/08 01:07:04
@@ -244,6 +244,7 @@
 
 :- import_module int, string, set, assoc_list, map, multi_map.
 :- import_module require, getopt, std_util, term_io, varset.
+:- import_module ka_alias_as.
 
 
 hlds_out__write_type_id(Name - Arity) -->
@@ -2840,6 +2841,7 @@
 	{ proc_info_typeinfo_varmap(Proc, TypeInfoMap) },
 	{ proc_info_typeclass_info_varmap(Proc, TypeClassInfoMap) },
 	{ proc_info_is_address_taken(Proc, IsAddressTaken) },
+	{ proc_info_possible_aliases(Proc, MaybeAliases) }, 
 	{ Indent1 is Indent + 1 },
 
 	hlds_out__write_indent(Indent1),
@@ -2866,6 +2868,19 @@
 	;
 		[]
 	),
+
+	( 	
+		{ string__contains_char(Verbose, 'k') } 
+	->
+		hlds_out__write_indent(Indent),
+		io__write_string("% Possible aliases: "),
+		ka_alias_as__print_maybe_possible_aliases(MaybeAliases,
+					Proc),
+		io__nl
+	;
+		[]
+	),
+	
 
 	hlds_out__write_indent(Indent),
 	hlds_out__write_var_types(Indent, VarSet, AppendVarnums,
Index: hlds_pred.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_pred.m,v
retrieving revision 1.70
diff -u -r1.70 hlds_pred.m
--- hlds_pred.m	2000/01/26 02:04:24	1.70
+++ hlds_pred.m	2000/02/08 00:19:31
@@ -16,6 +16,7 @@
 :- import_module hlds_data, hlds_goal, hlds_module, llds, prog_data, instmap.
 :- import_module globals, term_util.
 :- import_module bool, list, set, map, std_util, term, varset.
+:- import_module ka_alias_as.
 
 :- implementation.
 
@@ -1488,6 +1489,13 @@
 :- pred proc_info_set_rl_exprn_id(proc_info, rl_exprn_id, proc_info).
 :- mode proc_info_set_rl_exprn_id(in, in, out) is det.
 
+:- pred proc_info_possible_aliases(proc_info, maybe(ka_alias_as__alias_as)).
+:- mode proc_info_possible_aliases(in, out) is det.
+
+:- pred proc_info_set_possible_aliases(proc_info, alias_as, proc_info).
+:- mode proc_info_set_possible_aliases(in, in, out) is det.
+
+
 	% For a set of variables V, find all the type variables in the types 
 	% of the variables in V, and return set of typeinfo variables for 
 	% those type variables. (find all typeinfos for variables in V).
@@ -1595,13 +1603,17 @@
 					% must be considered as having its
 					% address taken, since it is possible
 					% that some other module may do so.
-			maybe(rl_exprn_id)
+			maybe(rl_exprn_id),
 					% For predicates with an
 					% `aditi_top_down' marker, which are
 					% executed top-down on the Aditi side
 					% of the connection, we generate an RL
 					% expression, for which this is an
 					% identifier. See rl_update.m.
+			maybe(alias_as)
+					% `Possible' aliases annotations per
+					% procedure. This field is set by the
+					% KUL alias analysis (module ka_run).
 		).
 
 	% Some parts of the procedure aren't known yet. We initialize
@@ -1627,11 +1639,12 @@
 	map__init(TVarsMap),
 	map__init(TCVarsMap),
 	RLExprn = no,
+	ALIAS = no,
 	NewProc = procedure(
 		MaybeDet, BodyVarSet, BodyTypes, HeadVars, Modes, MaybeArgLives,
 		ClauseBody, MContext, StackSlots, InferredDet, CanProcess,
 		ArgInfo, InitialLiveness, TVarsMap, TCVarsMap, eval_normal,
-		no, no, DeclaredModes, IsAddressTaken, RLExprn
+		no, no, DeclaredModes, IsAddressTaken, RLExprn, ALIAS
 	).
 
 proc_info_set(DeclaredDetism, BodyVarSet, BodyTypes, HeadVars, HeadModes,
@@ -1639,11 +1652,12 @@
 		CanProcess, ArgInfo, Liveness, TVarMap, TCVarsMap, ArgSizes,
 		Termination, IsAddressTaken, ProcInfo) :-
 	RLExprn = no,
+	ALIAS = no,
 	ProcInfo = procedure(
 		DeclaredDetism, BodyVarSet, BodyTypes, HeadVars, HeadModes,
 		HeadLives, Goal, Context, StackSlots, InferredDetism,
 		CanProcess, ArgInfo, Liveness, TVarMap, TCVarsMap, eval_normal, 
-		ArgSizes, Termination, no, IsAddressTaken, RLExprn).
+		ArgSizes, Termination, no, IsAddressTaken, RLExprn, ALIAS ).
 
 proc_info_create(VarSet, VarTypes, HeadVars, HeadModes, Detism, Goal,
 		Context, TVarMap, TCVarsMap, IsAddressTaken, ProcInfo) :-
@@ -1651,17 +1665,18 @@
 	set__init(Liveness),
 	MaybeHeadLives = no,
 	RLExprn = no,
+	ALIAS = no,
 	ProcInfo = procedure(yes(Detism), VarSet, VarTypes, HeadVars, HeadModes,
 		MaybeHeadLives, Goal, Context, StackSlots, Detism, yes, [],
 		Liveness, TVarMap, TCVarsMap, eval_normal, no, no, no, 
-		IsAddressTaken, RLExprn).
+		IsAddressTaken, RLExprn, ALIAS).
 
 proc_info_set_body(ProcInfo0, VarSet, VarTypes, HeadVars, Goal,
 		TI_VarMap, TCI_VarMap, ProcInfo) :-
 	ProcInfo0 = procedure(A, _, _, _, E, F, _,
-		H, I, J, K, L, M, _, _, P, Q, R, S, T, U),
+		H, I, J, K, L, M, _, _, P, Q, R, S, T, U, V),
 	ProcInfo = procedure(A, VarSet, VarTypes, HeadVars, E, F, Goal,
-		H, I, J, K, L, M, TI_VarMap, TCI_VarMap, P, Q, R, S, T, U).
+		H, I, J, K, L, M, TI_VarMap, TCI_VarMap, P, Q, R, S, T, U, V).
 
 proc_info_interface_determinism(ProcInfo, Determinism) :-
 	proc_info_declared_determinism(ProcInfo, MaybeDeterminism),
@@ -1719,87 +1734,91 @@
 
 proc_info_declared_determinism(ProcInfo, A) :-
 	ProcInfo = procedure(A, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, 
-    		_, _, _, _, _).
+    		_, _, _, _, _, _).
 
 proc_info_varset(ProcInfo, B) :-
 	ProcInfo = procedure(_, B, _, _, _, _, _, _, _, _, _, _, _, _, _, _, 
-		_, _, _, _, _).
+		_, _, _, _, _, _).
 
 proc_info_vartypes(ProcInfo, C) :-
 	ProcInfo = procedure(_, _, C, _, _, _, _, _, _, _, _, _, _, _, _, _, 
-		_, _, _, _, _).
+		_, _, _, _, _, _).
 
 proc_info_headvars(ProcInfo, D) :-
 	ProcInfo = procedure(_, _, _, D, _, _, _, _, _, _, _, _, _, _, _, _, 
-		_, _, _, _, _).
+		_, _, _, _, _, _).
 
 proc_info_argmodes(ProcInfo, E) :-
 	ProcInfo = procedure(_, _, _, _, E, _, _, _, _, _, _, _, _, _, _, _, 
-		_, _, _, _, _).
+		_, _, _, _, _, _).
 
 proc_info_maybe_arglives(ProcInfo, F) :-
 	ProcInfo = procedure(_, _, _, _, _, F, _, _, _, _, _, _, _, _, _, _, 
-		_, _, _, _, _).
+		_, _, _, _, _, _).
 
 proc_info_goal(ProcInfo, G) :-
 	ProcInfo = procedure(_, _, _, _, _, _, G, _, _, _, _, _, _, _, _, _, 
-		_, _, _, _, _).
+		_, _, _, _, _, _).
 
 proc_info_context(ProcInfo, H) :-
 	ProcInfo = procedure(_, _, _, _, _, _, _, H, _, _, _, _, _, _, _, _, 
-		_, _, _, _, _).
+		_, _, _, _, _, _).
 
 proc_info_stack_slots(ProcInfo, I) :-
 	ProcInfo = procedure(_, _, _, _, _, _, _, _, I, _, _, _, _, _, _, _, 
-		_, _, _, _, _).
+		_, _, _, _, _, _).
 
 proc_info_inferred_determinism(ProcInfo, J) :-
 	ProcInfo = procedure(_, _, _, _, _, _, _, _, _, J, _, _, _, _, _, _, 
-		_, _, _, _, _).
+		_, _, _, _, _, _).
 
 proc_info_can_process(ProcInfo, K) :-
 	ProcInfo = procedure(_, _, _, _, _, _, _, _, _, _, K, _, _, _, _, _, 
-		_, _, _, _, _).
+		_, _, _, _, _, _).
 
 proc_info_arg_info(ProcInfo, L) :- 
 	ProcInfo = procedure(_, _, _, _, _, _, _, _, _, _, _, L, _, _, _, _, 
-		_, _, _, _, _).
+		_, _, _, _, _, _).
 
 proc_info_liveness_info(ProcInfo, M) :-
 	ProcInfo = procedure(_, _, _, _, _, _, _, _, _, _, _, _, M, _, _, _,
-		_, _, _, _, _).
+		_, _, _, _, _, _).
 
 proc_info_typeinfo_varmap(ProcInfo, N) :-
 	ProcInfo = procedure(_, _, _, _, _, _, _, _, _, _, _, _, _, N, _, _, 
-		_, _, _, _, _).
+		_, _, _, _, _, _).
 
 proc_info_typeclass_info_varmap(ProcInfo, O) :-
 	ProcInfo = procedure(_, _, _, _, _, _, _, _, _, _, _, _, _, _, O, _, 
-		_, _, _, _, _).
+		_, _, _, _, _, _).
 
 proc_info_eval_method(ProcInfo, P) :-
 	ProcInfo = procedure(_, _, _, _, _, _, _, _, _, _, _, _, _, _, _, P, 
-		_, _, _, _, _).
+		_, _, _, _, _, _).
 
 proc_info_get_maybe_arg_size_info(ProcInfo, Q) :-
 	ProcInfo = procedure(_, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, 
-		Q, _, _, _, _).
+		Q, _, _, _, _, _).
 
 proc_info_get_maybe_termination_info(ProcInfo, R) :-
 	ProcInfo = procedure(_, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, 
-		_, R, _, _, _).
+		_, R, _, _, _, _).
 
 proc_info_maybe_declared_argmodes(ProcInfo, S) :-
 	ProcInfo = procedure(_, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, 
-		_, _, S, _, _).
+		_, _, S, _, _, _).
 
 proc_info_is_address_taken(ProcInfo, T) :-
 	ProcInfo = procedure(_, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, 
-		_, _, _, T, _).
+		_, _, _, T, _, _).
 
 proc_info_get_rl_exprn_id(ProcInfo, U) :-
+	ProcInfo = procedure(_, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, 
+		_, _, _, _, U, _).
+
+proc_info_possible_aliases(ProcInfo, V) :- 
 	ProcInfo = procedure(_, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, 
-		_, _, _, _, U).
+		_, _, _, _, _, V).
 
 % :- type proc_info
 % 	--->	procedure(
@@ -1869,105 +1888,112 @@
 
 proc_info_set_varset(ProcInfo0, B, ProcInfo) :-
 	ProcInfo0 = procedure(A, _, C, D, E, F, G, H, I, J, K, L, M, N, O, 
-		P, Q, R, S, T, U),
+		P, Q, R, S, T, U, V),
 	ProcInfo  = procedure(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O, 
-		P, Q, R, S, T, U).
+		P, Q, R, S, T, U, V).
 
 proc_info_set_vartypes(ProcInfo0, C, ProcInfo) :-
 	ProcInfo0 = procedure(A, B, _, D, E, F, G, H, I, J, K, L, M, N, O, 
-		P, Q, R, S, T, U),
+		P, Q, R, S, T, U, V),
 	ProcInfo  = procedure(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O, 
-		P, Q, R, S, T, U).
+		P, Q, R, S, T, U, V).
 
 proc_info_set_headvars(ProcInfo0, D, ProcInfo) :-
 	ProcInfo0 = procedure(A, B, C, _, E, F, G, H, I, J, K, L, M, N, O, 
-		P, Q, R, S, T, U),
+		P, Q, R, S, T, U, V),
 	ProcInfo  = procedure(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O, 
-		P, Q, R, S, T, U).
+		P, Q, R, S, T, U, V).
 
 proc_info_set_argmodes(ProcInfo0, E, ProcInfo) :-
 	ProcInfo0 = procedure(A, B, C, D, _, F, G, H, I, J, K, L, M, N, O, 
-		P, Q, R, S, T, U),
+		P, Q, R, S, T, U, V),
 	ProcInfo  = procedure(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O, 
-		P, Q, R, S, T, U).
+		P, Q, R, S, T, U, V).
 
 proc_info_set_maybe_arglives(ProcInfo0, F, ProcInfo) :-
 	ProcInfo0 = procedure(A, B, C, D, E, _, G, H, I, J, K, L, M, N, O, 
-		P, Q, R, S, T, U),
+		P, Q, R, S, T, U, V),
 	ProcInfo  = procedure(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O, 
-		P, Q, R, S, T, U).
+		P, Q, R, S, T, U, V).
 
 proc_info_set_goal(ProcInfo0, G, ProcInfo) :-
 	ProcInfo0 = procedure(A, B, C, D, E, F, _, H, I, J, K, L, M, N, O, 
-		P, Q, R, S, T, U),
+		P, Q, R, S, T, U, V),
 	ProcInfo  = procedure(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O, 
-		P, Q, R, S, T, U).
+		P, Q, R, S, T, U, V).
 
 proc_info_set_stack_slots(ProcInfo0, I, ProcInfo) :-
 	ProcInfo0 = procedure(A, B, C, D, E, F, G, H, _, J, K, L, M, N, O, 
-		P, Q, R, S, T, U),
+		P, Q, R, S, T, U, V),
 	ProcInfo  = procedure(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O, 
-		P, Q, R, S, T, U).
+		P, Q, R, S, T, U, V).
 
 proc_info_set_inferred_determinism(ProcInfo0, J, ProcInfo) :-
 	ProcInfo0 = procedure(A, B, C, D, E, F, G, H, I, _, K, L, M, N, O, 
-		P, Q, R, S, T, U),
+		P, Q, R, S, T, U, V),
 	ProcInfo  = procedure(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O, 
-		P, Q, R, S, T, U).
+		P, Q, R, S, T, U, V).
 
 proc_info_set_can_process(ProcInfo0, K, ProcInfo) :-
 	ProcInfo0 = procedure(A, B, C, D, E, F, G, H, I, J, _, L, M, N, O, 
-		P, Q, R, S, T, U),
+		P, Q, R, S, T, U, V),
 	ProcInfo  = procedure(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O, 
-		P, Q, R, S, T, U).
+		P, Q, R, S, T, U, V).
 
 proc_info_set_arg_info(ProcInfo0, L, ProcInfo) :-
 	ProcInfo0 = procedure(A, B, C, D, E, F, G, H, I, J, K, _, M, N, O, 
-		P, Q, R, S, T, U),
+		P, Q, R, S, T, U, V),
 	ProcInfo  = procedure(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O, 
-		P, Q, R, S, T, U).
+		P, Q, R, S, T, U, V).
 
 proc_info_set_liveness_info(ProcInfo0, M, ProcInfo) :-
 	ProcInfo0 = procedure(A, B, C, D, E, F, G, H, I, J, K, L, _, N, O, 
-		P, Q, R, S, T, U),
+		P, Q, R, S, T, U, V),
 	ProcInfo  = procedure(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O, 
-		P, Q, R, S, T, U).
+		P, Q, R, S, T, U, V).
 
 proc_info_set_typeinfo_varmap(ProcInfo0, N, ProcInfo) :-
 	ProcInfo0 = procedure(A, B, C, D, E, F, G, H, I, J, K, L, M, _, O, 
-		P, Q, R, S, T, U),
+		P, Q, R, S, T, U, V),
 	ProcInfo  = procedure(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O, 
-		P, Q, R, S, T, U).
+		P, Q, R, S, T, U, V).
 
 proc_info_set_typeclass_info_varmap(ProcInfo0, O, ProcInfo) :-
 	ProcInfo0 = procedure(A, B, C, D, E, F, G, H, I, J, K, L, M, N, _, 
-		P, Q, R, S, T, U),
+		P, Q, R, S, T, U, V),
 	ProcInfo  = procedure(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O, 
-		P, Q, R, S, T, U).
+		P, Q, R, S, T, U, V).
 
 proc_info_set_eval_method(ProcInfo0, P, ProcInfo) :-
 	ProcInfo0 = procedure(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O,
-		_, Q, R, S, T, U),
+		_, Q, R, S, T, U, V),
 	ProcInfo  = procedure(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O,
-		P, Q, R, S, T, U).
+		P, Q, R, S, T, U, V).
 
 proc_info_set_maybe_arg_size_info(ProcInfo0, Q, ProcInfo) :-
 	ProcInfo0 = procedure(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O, 
-		P, _, R, S, T, U),
+		P, _, R, S, T, U, V),
 	ProcInfo  = procedure(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O, 
-		P, Q, R, S, T, U).
+		P, Q, R, S, T, U, V).
 
 proc_info_set_maybe_termination_info(ProcInfo0, R, ProcInfo) :-
 	ProcInfo0 = procedure(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O, 
-		P, Q, _, S, T, U),
+		P, Q, _, S, T, U, V),
 	ProcInfo  = procedure(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O, 
-		P, Q, R, S, T, U).
+		P, Q, R, S, T, U, V).
 
 proc_info_set_rl_exprn_id(ProcInfo0, U, ProcInfo) :-
 	ProcInfo0 = procedure(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O, 
-		P, Q, R, S, T, _),
+		P, Q, R, S, T, _, V),
 	ProcInfo  = procedure(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O, 
-		P, Q, R, S, T, yes(U)).
+		P, Q, R, S, T, yes(U), V).
+
+proc_info_set_possible_aliases(ProcInfo0, V, ProcInfo) :-
+	ProcInfo0 = procedure(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O, 
+		P, Q, R, S, T, U, _),
+	ProcInfo  = procedure(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O, 
+		P, Q, R, S, T, U, yes(V)).
+
 
 proc_info_get_typeinfo_vars_setwise(ProcInfo, Vars, TypeInfoVars) :-
 	set__to_sorted_list(Vars, VarList),
Index: make_hlds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/make_hlds.m,v
retrieving revision 1.322
diff -u -r1.322 make_hlds.m
--- make_hlds.m	2000/01/25 04:09:47	1.322
+++ make_hlds.m	2000/02/14 03:34:37
@@ -63,6 +63,7 @@
 
 :- import_module string, char, int, set, bintree, map, multi_map, require.
 :- import_module bag, term, varset, getopt, assoc_list, term_io.
+:- import_module ka_alias_as.
 
 parse_tree_to_hlds(module(Name, Items), MQInfo0, EqvMap, Module, 
 		UndefTypes, UndefModes) -->
@@ -480,6 +481,11 @@
 			MaybeArgSizeInfo, MaybeTerminationInfo, Context,
 			Module0, Module)
 	;
+		{ Pragma = ka_alias_info(_PredOrFunc, _SymName, _ModeList,
+			_HeadVars, _MaybeAliasInfo) },
+		% ignore ka_alias_info pragma's in .m files
+		{ Module = Module0 }
+	;
 		{ Pragma = terminates(Name, Arity) },
 		add_pred_marker(Module0, "terminates", Name, Arity,
 			ImportStatus, Context, terminates,
@@ -1352,6 +1358,7 @@
 	    ****   { module_info_incr_errors(Module0, Module) }
 	    ***/
 	).
+
 
 %-----------------------------------------------------------------------------%
 
Index: mercury_compile.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mercury_compile.m,v
retrieving revision 1.147
diff -u -r1.147 mercury_compile.m
--- mercury_compile.m	2000/01/10 00:43:44	1.147
+++ mercury_compile.m	2000/02/09 00:09:29
@@ -52,6 +52,7 @@
 :- import_module mercury_to_mercury, mercury_to_goedel.
 :- import_module dependency_graph, prog_util, rl_dump, rl_file.
 :- import_module options, globals, passes_aux.
+:- import_module ka_run.
 
 %-----------------------------------------------------------------------------%
 
@@ -906,7 +907,13 @@
 		mercury_compile__maybe_dump_hlds(HLDS9, "09", "determinism"),
 		!,
 
-		mercury_compile__check_unique_modes(HLDS9, Verbose, Stats,
+		% check aliases
+		mercury_compile__possible_aliases(HLDS9, Verbose, Stats,
+							HLDS9b), !,
+		mercury_compile__maybe_dump_hlds(HLDS9b, "09b",
+						"possible_aliases"), !, 
+
+		mercury_compile__check_unique_modes(HLDS9b, Verbose, Stats,
 			HLDS10, FoundUniqError), !,
 		mercury_compile__maybe_dump_hlds(HLDS10, "10", "unique_modes"),
 		!,
@@ -938,6 +945,7 @@
 		;
 			{ FoundError = yes }
 		)
+
 	),
 
 	{ HLDS20 = HLDS12 },
@@ -1468,6 +1476,27 @@
 		HLDS0, HLDS),
 	maybe_write_string(Verbose, "% done.\n"),
 	maybe_report_stats(Stats).
+
+:- pred mercury_compile__possible_aliases( module_info, bool, bool, 
+						module_info, io__state,
+						io__state).
+:- mode mercury_compile__possible_aliases( in, in, in, out, di, uo) is det.
+
+mercury_compile__possible_aliases(HLDS0, Verbose, Stats, HLDS ) -->
+	globals__io_lookup_bool_option( infer_possible_aliases, InferAliases),
+	( 	
+		{ InferAliases = yes }
+	->
+		maybe_write_string(Verbose, 
+				"% Annotating with possible aliases...\n"),
+		maybe_flush_output(Verbose),
+		ka_run__aliases_pass( HLDS0, HLDS ),
+		maybe_write_string(Verbose, "% done.\n"),
+		maybe_report_stats(Stats)
+	;
+		{ HLDS = HLDS0 }
+	).
+
 
 %-----------------------------------------------------------------------------%
 
Index: mercury_to_mercury.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mercury_to_mercury.m,v
retrieving revision 1.166
diff -u -r1.166 mercury_to_mercury.m
--- mercury_to_mercury.m	2000/01/25 04:09:52	1.166
+++ mercury_to_mercury.m	2000/02/09 06:20:33
@@ -31,6 +31,9 @@
 				io__state, io__state).
 :- mode convert_to_mercury(in, in, in, di, uo) is det.
 
+:- pred mercury_output_sym_name(sym_name, io__state, io__state).
+:- mode mercury_output_sym_name(in, di, uo) is det.
+
 :- pred mercury_output_item(item, prog_context, io__state, io__state).
 :- mode mercury_output_item(in, in, di, uo) is det.
 
@@ -415,6 +418,9 @@
 			PredName, ModeList, Context,
 			MaybeArgSizeInfo, MaybeTerminationInfo)
 	;
+		{ Pragma = ka_alias_info(_,_,_,_,_) },
+		[]
+	;
 		{ Pragma = terminates(Pred, Arity) },
 		mercury_output_pragma_decl(Pred, Arity, predicate, "terminates")
 	;
@@ -2667,9 +2673,6 @@
 	% Use mercury_output_bracketed_sym_name when the sym_name has
 	% no arguments, otherwise use mercury_output_sym_name.
 	%
-
-:- pred mercury_output_sym_name(sym_name, io__state, io__state).
-:- mode mercury_output_sym_name(in, di, uo) is det.
 
 mercury_output_sym_name(SymName) -->
 	mercury_output_sym_name(SymName, not_next_to_graphic_token).
Index: module_qual.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/module_qual.m,v
retrieving revision 1.53
diff -u -r1.53 module_qual.m
--- module_qual.m	2000/01/13 04:29:40	1.53
+++ module_qual.m	2000/02/09 06:58:13
@@ -946,6 +946,10 @@
 		termination_info(PredOrFunc, SymName, ModeList, Args, Term), 
 		Info0, Info) --> 
 	qualify_mode_list(ModeList0, ModeList, Info0, Info).
+qualify_pragma(ka_alias_info(PredOrFunc, SymName, ModeList0, Vars, MaybeAS),
+		ka_alias_info(PredOrFunc, SymName, ModeList, Vars, MaybeAS),
+		Info0, Info) -->
+	qualify_mode_list(ModeList0, ModeList, Info0, Info).
 qualify_pragma(terminates(A, B), terminates(A, B), Info, Info) --> [].
 qualify_pragma(does_not_terminate(A, B), does_not_terminate(A, B), 
 		Info, Info) --> [].
Index: modules.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/modules.m,v
retrieving revision 1.115
diff -u -r1.115 modules.m
--- modules.m	2000/01/11 07:53:40	1.115
+++ modules.m	2000/02/09 07:00:27
@@ -910,6 +910,7 @@
 pragma_allowed_in_interface(unused_args(_, _, _, _, _), no).
 pragma_allowed_in_interface(type_spec(_, _, _, _, _, _, _), yes).
 pragma_allowed_in_interface(termination_info(_, _, _, _, _), yes).
+pragma_allowed_in_interface(ka_alias_info(_, _, _, _, _), yes).
 pragma_allowed_in_interface(terminates(_, _), yes).
 pragma_allowed_in_interface(does_not_terminate(_, _), yes).
 pragma_allowed_in_interface(check_termination(_, _), yes).
Index: options.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/options.m,v
retrieving revision 1.277
diff -u -r1.277 options.m
--- options.m	2000/01/10 00:43:45	1.277
+++ options.m	2000/02/08 00:17:08
@@ -121,6 +121,7 @@
 		;	strict_sequential
 		;	infer_types
 		;	infer_modes
+		;	infer_possible_aliases
 		;	infer_det
 		;	infer_all
 		;	type_inference_iteration_limit
@@ -493,6 +494,7 @@
 	fully_strict		-	bool(yes),
 	infer_types		-	bool(no),
 	infer_modes		-	bool(no),
+	infer_possible_aliases  - 	bool(no),
 	infer_det		-	bool(yes),
 	infer_all		-	bool_special,
 	type_inference_iteration_limit	-	int(60),
@@ -863,6 +865,7 @@
 long_option("infer-all",		infer_all).
 long_option("infer-types",		infer_types).
 long_option("infer-modes",		infer_modes).
+long_option("infer-possible-aliases",		infer_possible_aliases).
 long_option("infer-determinism",	infer_det).
 long_option("infer-det",		infer_det).
 long_option("type-inference-iteration-limit",
Index: prog_data.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_data.m,v
retrieving revision 1.52
diff -u -r1.52 prog_data.m
--- prog_data.m	2000/01/24 17:47:15	1.52
+++ prog_data.m	2000/02/09 04:01:01
@@ -24,6 +24,7 @@
 
 :- import_module (inst).
 :- import_module bool, list, assoc_list, map, varset, term, std_util.
+:- import_module ka_alias_as.
 
 %-----------------------------------------------------------------------------%
 
@@ -248,6 +249,13 @@
 			% termination_info pragmas are used in opt and
 			% trans_opt files.
 
+	;	ka_alias_info(pred_or_func, sym_name, list(mode),
+				list(prog_var), maybe(alias_as))
+			% the list(mode) is the declared argmodes of the
+			% procedure. 
+			% This pragma is used to define information about
+			% a predicates possible aliases set. 
+			% These pragma's are used in opt.ka files
 
 	;	terminates(sym_name, arity)
 			% Predname, Arity
Index: prog_io_pragma.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_io_pragma.m,v
retrieving revision 1.21
diff -u -r1.21 prog_io_pragma.m
--- prog_io_pragma.m	1999/07/13 08:53:24	1.21
+++ prog_io_pragma.m	2000/02/09 07:48:46
@@ -25,6 +25,7 @@
 :- import_module prog_io, prog_io_goal, prog_util.
 :- import_module term_util, term_errors.
 :- import_module int, map, string, std_util, bool, require.
+:- import_module ka_alias_as.
 
 parse_pragma(ModuleName, VarSet, PragmaTerms, Result) :-
 	(
@@ -613,7 +614,48 @@
 		"syntax error in `:- pragma termination_info' declaration",
 		ErrorTerm)
     ).
-			
+	
+parse_pragma_type(ModuleName, "ka_alias_info", PragmaTerms, ErrorTerm, 
+		_VarSet, Result) :- 
+    (
+	PragmaTerms = [ 
+		PredAndModesTerm0,
+		HVsTerm,
+		AliasInformation
+	],
+	parse_pred_or_func_and_arg_modes(yes(ModuleName), PredAndModesTerm0,
+		ErrorTerm, "`:- pragma ka_alias_info' declaration",
+		NameAndModesResult),
+	NameAndModesResult = ok(PredName - PredOrFunc, ModeList),
+	
+	% variables
+	HVsTerm = term__functor(term__atom("vars"), ListHVTerm, _),
+	term__vars_list(ListHVTerm, HeadVarsGeneric),
+	list__map(term__coerce_var, HeadVarsGeneric, HeadVars),
+
+	% aliases
+
+	(
+	   	AliasInformation = term__functor(
+					term__atom("not_available"),_,_),
+		MaybeAliasInfo = no
+	;
+		AliasInformation = term__functor(
+					term__atom("yes"), ReadAliases, _),
+		ka_alias_as__parse_read_aliases(ReadAliases, Alias_as),
+		MaybeAliasInfo = yes(Alias_as)
+	),
+
+	Result0 = ok(pragma(ka_alias_info(PredOrFunc, PredName, ModeList,
+					HeadVars, MaybeAliasInfo)))
+   ->
+   	Result = Result0
+   ;
+        Result = error( 
+		"syntax error in `:- pragma ka_alias_info' declaration", 
+		ErrorTerm)	
+   ).
+
 parse_pragma_type(ModuleName, "terminates", PragmaTerms,
 				ErrorTerm, _VarSet, Result) :-
 	parse_simple_pragma(ModuleName, "terminates",



-------
new file: ka_alias_as.m

%-----------------------------------------------------------------------------%
% Copyright (C) 1996-2000 The University of Melbourne.
% This file may only be copied under the terms of the GNU General
% Public License - see the file COPYING in the Mercury distribution.
%-----------------------------------------------------------------------------%

% module ka_alias_as: defines the KUL alias abstract substitution 
% main author: nancy

% notes: 
% 1. 	 internally at some point, this abstract substitution uses
% 	 the notion of a `selector'. This concept corresponds to the
%        `selector' used by bta. At some moment the code related to
%        these selectors should be shared. This is not the case at this
%	 moment. 
% 2. 	 _partially instantiated datastructures_ : the day they'll be 
% 	 introduced, a couple of things will have to be changed.

:- module ka_alias_as.

:- interface.

%-------------------------------------------------------------------%
%-- import_module 

:- import_module list, map.

:- import_module prog_data.
:- import_module hlds_goal.
:- import_module hlds_pred, hlds_module.
:- import_module instmap.
:- import_module io, std_util, term. 


%-------------------------------------------------------------------%
%-- exported types

:- type alias_as.

%-------------------------------------------------------------------%
%-- exported predicates

	
:- pred init( alias_as::out ) is det.
:- pred is_bottom( alias_as::in ) is semidet.

	% project alias abstract substitution on a list of variables.
:- pred project( list(prog_var), alias_as, alias_as).
:- mode project( in, in, out ) is det.

	% rename abstract substitution according to a mapping
	% of prog_vars (map (FROM_VARS, TO_VARS) ).
:- pred rename( map(prog_var, prog_var), alias_as, alias_as).
:- mode rename( in, in, out ) is det.

	% returns true if both abstract substitutions are equal. 
	% needed for fixpoint
:- pred equal( alias_as, alias_as).
:- mode equal( in, in) is semidet.

	% first abstract subst. is less than or equal to second
	% abstract subst. (for fixpoint). (not used)
:- pred leq( alias_as, alias_as).
:- mode leq( in ,in ) is semidet.

	% compute least upper bound. 
:- pred least_upper_bound( alias_as, alias_as, alias_as).
:- mode least_upper_bound( in, in, out) is det.

	% compute least upper bound of a list of abstract substitutions.
:- pred least_upper_bound_list( list(alias_as), alias_as).
:- mode least_upper_bound_list( in, out) is det.

	% extend( NEW, OLD, RESULT).
	% extend a given abstract substitution with new information.
:- pred extend( alias_as, alias_as, alias_as).
:- mode extend( in, in, out) is det.

	% specialized extend for unifications
:- pred extend_unification( hlds_goal__unification, alias_as, alias_as).
:- mode extend_unification( in, in, out) is det.

	% normalization of the representation based on the types of
	% the variables (retreived from proc_info) and the instmaps.
:- pred normalize( hlds_pred__proc_info, module_info, instmap, alias_as, alias_as).
:- mode normalize( in, in, in, in, out ) is det.

	% print-procedures:
	% print_maybe_possible_aliases: routine used within
	% hlds_dumps.
:- pred print_maybe_possible_aliases( maybe(alias_as), proc_info,
				io__state, io__state).
:- mode print_maybe_possible_aliases( in, in, di, uo) is det.

	% print_maybe_interface_aliases: routine for printing
	% alias information in interface files.
:- pred print_maybe_interface_aliases( maybe(alias_as), 
				proc_info, io__state, io__state).
:- mode print_maybe_interface_aliases( in, in, di, uo) is det.

	% reverse routine of print_maybe_interface_aliases.
:- pred parse_read_aliases(list(term(T)), alias_as).
:- mode parse_read_aliases(in,out) is det.

%-------------------------------------------------------------------%
%-------------------------------------------------------------------%
:- implementation.

:- import_module std_util.
:- import_module hlds_data.
:- import_module hlds_out.
:- import_module varset.

%-------------------------------------------------------------------%
%-- type definitions 

:- type alias_as ---> 
			real_as( list(alias) )
		;	bottom.
	% where list(alias) contains no doubles!
	% near future: alias_as should also include top(string),
	% where string could be some sort of message.

:- type alias == pair(datastruct).
:- type datastruct ---> cel(prog_var,selector).
:- type selector == list(unit_sel).
:- type unit_sel ---> us( cons_id, index ).
:- type index == int.


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

	% init
init(bottom).

	% is_bottom
is_bottom(bottom).
is_bottom(real_as([])).

	% project
project( _Listvar, bottom, bottom).
project( Listvar, real_as(Aliases), ASout) :-
	list__foldl( project_alias( Listvar ), Aliases, [], PAliases),
	wrap(PAliases, ASout).

rename( _Mapvar, bottom, bottom).
rename( Mapvar, real_as(Aliases), ASout) :-
	list__foldl( rename_alias( Mapvar ), Aliases, [], RAliases),
	wrap(RAliases, ASout).

equal( bottom, bottom).
equal( real_as(LIST1), real_as(LIST2)):-
	list__length(LIST1, L),
	list__length(LIST2, L),
	list__takewhile(alias_occurs_in(LIST2),LIST1,_, AfterList),
	AfterList = [].

leq( bottom, _ ).
leq( real_as(LIST1), real_as(LIST2) ) :- 
	list__takewhile(alias_subsumed_by_list(LIST2),LIST1,_, AfterList),
	AfterList = [].


least_upper_bound( A1, A2, RESULT) :-
	(
		A1 = real_as(LIST1),
		A2 = real_as(LIST2)
	->
		alias_list_lub(LIST1,LIST2,Aliases),
		wrap(Aliases, RESULT)
	;
		A1 = bottom
	->
		RESULT = A2
	;
		RESULT = A1
	).
		
:- pred alias_list_lub(list(alias),list(alias),list(alias)).
:- mode alias_list_lub(in,in,out) is det.

alias_list_lub(LIST1,LIST2,Aliases):-
	list__foldl(alias_add_subsuming,LIST1,LIST2,Aliases).

least_upper_bound_list( AS_LIST, AS ) :-
	list__foldl(least_upper_bound, AS_LIST, bottom, AS).

extend( A1, A2, RESULT ):-
	( 
		A1 = real_as(NEW),
		A2 = real_as(OLD)
	->
		alias_altclosure(NEW,OLD,Aliases),
		wrap(Aliases,RESULT)
	;
		A1 = bottom
	->
		RESULT = A2
	;
		RESULT = A1
	).

extend_unification( Unif, ASin, ASout ):-
	alias_from_unification( Unif, AUnif),
	extend( AUnif, ASin, ASout).


normalize( ProcInfo, HLDS, _INSTMAP, ALIASin, ALIASout):- 
	normalize_with_type_information( ProcInfo, HLDS, ALIASin, ALIAS1),
	remove_doubles( ALIAS1, ALIASout).

:- pred remove_doubles( alias_as, alias_as).
:- mode remove_doubles( in, out ) is det.

remove_doubles( AS0, AS ):-
	(
		AS0 = real_as( Aliases0 )
	->
		list__foldl( add_without_doubles, Aliases0, [], Aliases ),
		wrap( Aliases, AS )
	;
		AS = AS0
	).

:- pred add_without_doubles( alias, list(alias), list(alias) ).
:- mode add_without_doubles( in, in, out ) is det.

add_without_doubles( Alias, Aliases0, Aliases ) :-
	(
		alias_occurs_in(Aliases0, Alias)
	->
		Aliases = Aliases0
	;
		Aliases = [ Alias | Aliases0 ]
	).


%-------------------------------------------------------------------%
% printing routines
%-------------------------------------------------------------------%

	% MaybeAs = yes( Alias_as) -> print out Alias_as
	%         = no		   -> print "not available"
print_maybe_possible_aliases( MaybeAS, ProcInfo ) -->
	(
		{ MaybeAS = yes(AS) }
	->	
		io__nl,
		print_possible_aliases( AS, ProcInfo)
	;
		io__write_string(" not available.")
	).

	% print_possible_aliases( Abstract Substitution, Proc Info).
	% print alias abstract substitution
:- pred print_possible_aliases( alias_as, proc_info, io__state, io__state).
:- mode print_possible_aliases( in, in, di, uo ) is det. 

print_possible_aliases( AS, ProcInfo ) -->
	(
		{ AS = real_as(Aliases) }
	->
		io__write_list( Aliases, "", print_alias(ProcInfo,"% ", "\n")),
		io__write_string("% -- end aliases")
	;
		io__write_string("% aliases = bottom")
	).

	% MaybeAs = yes(Alias_as) -> print `yes( printed Alias_as)'
	%         = no		  -> print `not_available'
print_maybe_interface_aliases( MaybeAS, ProcInfo ) -->
	(
		{ MaybeAS = yes(AS) }
	->
		io__write_string("yes("),
		(
			{ AS = real_as(Aliases) }
		->
			io__write_string("["),
			io__write_list( Aliases, ",", print_alias(ProcInfo," ","")),
			io__write_string("]")
		;
			io__write_string("bottom")
		),
		io__write_string(")")
	;
		io__write_string("not_available")
	).

:- pred print_alias( proc_info, string, string, alias, io__state, io__state).
:- mode print_alias( in, in, in, in, di, uo) is det.

print_alias( ProcInfo, FrontString, EndString, ALIAS ) -->
	{ ALIAS = D1 - D2 },
	io__write_string( FrontString ),
	io__write_string( "pair( " ),
	print_datastructure( D1, ProcInfo ),
	io__write_string(" , "),
	print_datastructure( D2, ProcInfo ),
	io__write_string(" ) "),
	io__write_string( EndString ).

:- pred print_datastructure( datastruct, proc_info, io__state, io__state).
:- mode print_datastructure( in, in, di, uo) is det.

print_datastructure( D, ProcInfo) -->
	{ D = cel( ProgVar, SEL ) },
	{ proc_info_varset(ProcInfo, ProgVarset) },
	{ varset__lookup_name( ProgVarset, ProgVar, ProgName ) },
	io__write_string("cel("),
	io__write_string( ProgName ), 
	io__write_string(", ["),
	io__write_list( SEL, ",", print_unit_selector ),
	io__write_string("])").

:- import_module mercury_to_mercury, string, prog_io.

:- pred print_unit_selector( unit_sel, io__state, io__state).
:- mode print_unit_selector( in, di, uo) is det.

print_unit_selector( us( CONS, INDEX ) ) -->
	{ cons_id_arity( CONS, ARITY ) },
	io__write_string( "sel("),
	mercury_output_cons_id(CONS, needs_brackets),
	io__write_string( "," ),
	io__write_int( ARITY ),
	io__write_string(","),
	io__write_int(INDEX),
	io__write_string(")").

%-------------------------------------------------------------------%
% parsing routines
%-------------------------------------------------------------------%

parse_read_aliases( LISTTERM ,AS ):- 
	(
		% LISTTERM ought to have only one element
		LISTTERM = [ OneITEM ]
	->
		(
			OneITEM = term__functor( term__atom(CONS), TERMS, _ )
		->
			(
				CONS = ".",
				TERMS = [ ELEM , RESTTERMS ]
			->
				parse_alias_term( ELEM, RESTTERMS, Aliases),
				wrap(Aliases, AS)
				% AS = bottom
			;
				CONS = "bottom"
			->
				AS = bottom
			;
				string__append(
			"(ka) parse_read_aliases: could not parse aliases, top cons: ", CONS, Msg),
				error(Msg)
			)
		;
			error("(ka) parse_read_aliases: term not a functor")
		)
	;
		list__length( LISTTERM, L ),
		string__int_to_string(L, LS), 
		string__append_list( ["(ka) parse_read_aliases: wrong number of arguments. yes/", LS,
				" should be yes/1"], Msg),
		error(Msg)
	).

:- pred parse_alias_term( term(T), term(T),list(alias)).
:- mode parse_alias_term( in, in, out) is det.

parse_alias_term( First, Rest, Aliases) :- 
	parse_one_alias_term( First, Alias ),
	(
		Rest = term__functor( term__atom(CONS), Args, _ )
	->
		(
			CONS = ".",
			Args = [ Second, NewRest]
		->
			parse_alias_term(Second, NewRest, RestAliases),
			Aliases = [ Alias | RestAliases ]
		;
			Aliases = [ Alias ]
		)
	;
		error("(ka) parse_alias_term: term is not a functor")
	).

:- pred parse_one_alias_term( term(T), alias).
:- mode parse_one_alias_term( in, out ) is det.

parse_one_alias_term( TERM , A ) :- 
	(
		TERM = term__functor( term__atom(CONS), Args, _)
	->
		( 
			CONS = "pair"
		->
			(
				Args = [ First, Second ]
			->
				parse_datastructure_term( First, D1 ),
				parse_datastructure_term( Second, D2 ),
				A = D1 - D2
			;
				list__length(Args, L),
				string__int_to_string(L,LS),
				string__append_list(
					[ "(ka) parse_one_alias_term: ", 
					"wrong number of arguments. `-'/",
					LS,"should be `-'/2"],Msg),
				error(Msg)
			)
		;
			term__det_term_to_type( TERM, TYPE),
			varset__init(V),
			mercury_type_to_string(V, TYPE, StringTerm),
			string__append_list([ 
					"(ka) parse_one_alias_term: ",
					"wrong constructor. `",
					StringTerm,
					"' should be `pair'"],Msg),
			error(Msg)
		)
	;
		error("(ka) parse_one_alias_term: term is not a functor")
	).

:- pred parse_datastructure_term( term(T), datastruct ).
:- mode parse_datastructure_term( in, out ) is det.

parse_datastructure_term( TERM, Data ):- 
   (
      TERM = term__functor( term__atom( CONS ), Args, _ )
   ->
      (
         CONS = "cel"
      ->
         (
            Args = [ VarTerm, SelectorTerm ]
         ->
           (
              VarTerm = term__variable(VAR)
	   ->
	      term__coerce_var(VAR, PROGVAR),
	      parse_selector_term(SelectorTerm, SELECTOR),
	      Data = cel(PROGVAR, SELECTOR)
	   ;
	      error("(ka) parse_datastructure_term: wrong term. variable, should be functor")
	   )
	 ;
	   list__length(Args, L),
	   string__int_to_string( L, LS),
	   string__append_list(["(ka) parse_datastructure_term: wrong number of arguments. cel/",LS,
	   			"should be cel/2"],Msg),
	   error(Msg)
	 )
      ;
         string__append_list(["(ka) parse_datastructure_term: wrong constructor. `",CONS,
	 			"' should be `cel'"],Msg),
	   error(Msg)
      )
   ;
      error("(ka) parse_datastructure_term: term not a functor")
   ).

:- pred parse_selector_term( term(T), selector).
:- mode parse_selector_term(in,out) is det.

parse_selector_term( TERM, SEL ):- 
	(
		TERM = term__functor( term__atom(CONS), Args, _)
	->
		(
			CONS = ".",
			Args = [ First , Rest ]
		->
			parse_unit_selector( First, US),
			parse_selector_term( Rest, SELrest ),
			SEL = [ US | SELrest ]
		;
			SEL = []
		)
	;
		error("(ka) parse_selector_term: term not a functor")
	).

:- pred parse_unit_selector( term(T), unit_sel).
:- mode parse_unit_selector( in, out) is det.

parse_unit_selector( TERM, US ):- 
   (
      TERM = term__functor( term__atom(CONS), Args, _)
   ->
      (
         CONS = "sel",
         Args = [ CONS_TERM, ARITY_TERM, POS_TERM ]
      ->
         ( 
            prog_io__sym_name_and_args( CONS_TERM, ConsID_SN, ConsID_ARGS ),
            ConsID_ARGS = [],
	    ARITY_TERM = term__functor( term__integer( Arity ), _, _),
            POS_TERM = term__functor( term__integer( Pos ), _, _ )
         ->
	    ConsID = cons( ConsID_SN, Arity ),
	    US = us( ConsID, Pos )
	 ;
	    CONS_TERM = term__functor( term__integer( X ), _, _)
	 ->
	    ConsID = int_const( X ), 
	    US = us( ConsID, 0 )
	 ;
	    CONS_TERM = term__functor( term__float( X ), _, _)
	 ->
	    ConsID = float_const( X ),
	    US = us( ConsID, 0)
	 ;
	    CONS_TERM = term__functor( term__string( S ), _, _)
	 ->
	    ConsID = string_const( S ),
	    US = us( ConsID, 0 )
	 ;
	    error("(ka) parse_unit_selector: unknown cons_id in unit selector")
	 )
      ; 
         error("(ka) parse_unit_selector: top constructor should be sel/3")
      )
   ;
      error("(ka) parse_unit_selector: term not a functor")
   ).

%-------------------------------------------------------------------%
%-- additional predicates

:- pred wrap( list(alias), alias_as).
:- mode wrap( in, out) is det.

wrap( LIST, AS) :-
	(
		LIST = []
	->
		AS = bottom
	;
		AS = real_as(LIST)
	).


%-------------------------------------------------------------------%
%-------------------------------------------------------------------%
%-- alias predicates
%-------------------------------------------------------------------%
%-------------------------------------------------------------------%

:- pred project_alias( list(prog_var), alias, 
			list(alias), list(alias)).
:- mode project_alias( in, in, in, out) is det.

project_alias( LIST, Alias, LISTin, LISTout) :- 
	Alias = Data1 - Data2,
	datastruct_get_var(Data1, Var1),
	datastruct_get_var(Data2, Var2),
	(
		list__member(Var1, LIST),
		list__member(Var2, LIST)
	->
		LISTout = [Alias | LISTin]
	;
		LISTout = LISTin
	).

:- pred rename_alias( map(prog_var, prog_var), alias, 
			list(alias), list(alias)).
:- mode rename_alias( in, in, in, out) is det.

rename_alias( MAP, Alias, LISTin, LISTout) :-
	Alias = Data1 - Data2,
	datastruct_rename( MAP, Data1, RData1),
	datastruct_rename( MAP, Data2, RData2),
	RAlias = RData1 - RData2, 
	LISTout = [RAlias | LISTin].

:- pred alias_occurs_in( list(alias), alias).
:- mode alias_occurs_in( in, in ) is semidet.

alias_occurs_in( [A1 | R ], A2 ):-
	(
		alias_equal(A1,A2)
	-> 
		true
	;
		alias_occurs_in( R, A2 )
	). 

:- pred alias_equal( alias, alias ).
:- mode alias_equal( in, in ) is semidet.

alias_equal( A1, A2 ) :- 
	A1 = D1a - D1b,
	A2 = D2a - D2b,
	(
		datastruct_equal(D1a,D2a),
		datastruct_equal(D1b,D2b)
	;
		datastruct_equal(D1a,D2b),
		datastruct_equal(D1b,D2a)
	).

:- pred alias_subsumed_by_list( list(alias), alias ).
:- mode alias_subsumed_by_list( in, in) is semidet.

alias_subsumed_by_list( [A1 | R ] , A2 ) :- 
	(
		alias_leq(A2,A1) 
	->
		true
	;
		alias_subsumed_by_list( R, A2)
	).


:- pred alias_leq( alias, alias).
:- mode alias_leq( in, in ) is semidet.

alias_leq( A1, A2 ) :-
	A1 = D1a - D1b,
	A2 = D2a - D2b,
	(
		datastruct_same_vars(D1a,D2a),
		datastruct_same_vars(D1b,D2b)
	->
		datastruct_leq_selectors(D1a,D2a),
		datastruct_leq_selectors(D1b,D2b)
	;
		( 
			datastruct_same_vars(D1a,D2b),
			datastruct_same_vars(D1b,D2a)
		->
			datastruct_leq_selectors(D1a,D2b),
			datastruct_leq_selectors(D1b,D2a)
		;
			fail
		)
	).

:- pred alias_add_subsuming(alias,list(alias),list(alias)).
:- mode alias_add_subsuming(in,in, out) is det.

alias_add_subsuming( ALIAS, [], [ALIAS]).
alias_add_subsuming( ALIAS, [ A | R ], RESULT ):-
	(
		alias_leq(ALIAS,A)
	->
		RESULT = [ A | R ]
	;
		alias_leq(A, ALIAS)
	->
		RESULT = [ ALIAS | R ] 
	;
		alias_add_subsuming( ALIAS, R, TEMP),
		RESULT = [ A | TEMP ]
	).

	% alias_altclosure( NEW, OLD, RESULT)
	% computes the alternating closure of two lists of aliases.
	% RESULT = NEW + OLD + path2(NEW,OLD) + path3(NEW,OLD).
	% where path2(NEW,OLD) is: (a,b), such that (a,c) in NEW, 
	%				  and       (c,b) in OLD
	% where path3(NEW,OLD) is: (a,b), such that (a,c) in NEW,
	%					    (c,d) in OLD,
	%					    (d,b) in NEW
	% taking into account termshifts.
:- pred alias_altclosure(list(alias),list(alias),list(alias)).
:- mode alias_altclosure(in,in,out) is det.

alias_altclosure( NEW, OLD, RESULT) :-
	(
		NEW = []
	->
		RESULT = OLD
	;
		OLD = []
	->
		RESULT = NEW
	;
		altclosure_path2_3(NEW,OLD,PATH2,PATH3),
		list__foldl(alias_list_lub,[OLD,PATH2,PATH3],NEW,RESULT)
	).

:- pred altclosure_path2_3(list(alias),list(alias),list(alias),list(alias)).
:- mode altclosure_path2_3(in,in,out,out) is det.

altclosure_path2_3(NEW,OLD,PATH2,PATH3):-
		% not only this returns the path2 results,
		% but these results are also such that:
		% ALIAS =  D1 - D2, where D1 is from NEW, en D2
		% from OLD
		% constructs paths from NEW to OLD
	list__foldl(altclos_ordered_path(OLD),NEW,[],PATH2),
		% constructs paths from PATH2 (NEW -> OLD) to NEW
	list__foldl(altclos_ordered_path(NEW),PATH2,[],PATH3).


	% altclos_ordered_path( to_aliases, from_alias, temporary result,
	%						new result).
:- pred altclos_ordered_path(list(alias),alias,list(alias),list(alias)).
:- mode altclos_ordered_path(in,in,in,out) is det.

altclos_ordered_path( TO_LIST, FROM_ALIAS, LISTin, LISTout) :-
	list__filter_map(single_altclos(FROM_ALIAS),TO_LIST,NEW),
	list__append(NEW,LISTin,LISTout).

	% single_altclos( FROM_ALIAS, TO_ALIAS, RESULT_ALIAS).
	% --> semidet!
:- pred single_altclos(alias,alias,alias).
:- mode single_altclos(in,in,out) is semidet.

single_altclos( FROM , TO , RESULT ) :-
	FROM = DFa - DFb,
	TO   = DTa - DTb,
	(
		datastruct_same_vars(DFb,DTa)
	-> 
		single_directed_altclos(FROM, TO, RESULT)
	;
		datastruct_same_vars(DFa,DTa)
	->
		alias_switch(FROM,FROMsw),
		single_directed_altclos(FROMsw,TO,RESULT)
	;
		datastruct_same_vars(DFb,DTb)
	->
		alias_switch(TO,TOsw),
		single_directed_altclos(FROM,TOsw,RESULT)
	;
		datastruct_same_vars(DFa,DTb)
	->
		alias_switch(FROM,FROMsw),
		alias_switch(TO,TOsw),
		single_directed_altclos(FROMsw,TOsw,RESULT)
	;
		fail
	).

	% single_directed_altclos(FROM,TO, RESULT), with matching
	% middle vars!
:- pred single_directed_altclos(alias,alias,alias).
:- mode single_directed_altclos(in,in,out) is semidet.
		
single_directed_altclos( FROM, TO, RESULT) :-
	FROM = DFa - DFb,
	TO   = DTa - DTb,
	datastruct_get_selector(DFb,SF),
	datastruct_get_selector(DTa,ST),
	(
		selector_match(SF,ST,EXT1)
	->
		% SF.EXT1 = ST
		datastruct_termshift(DFa,EXT1,DRa),
		RESULT = DRa - DTb
	;
		selector_match(ST,SF,EXT2)
	->
		% ST.EXT1 = SF
		datastruct_termshift(DTb,EXT2,DRb),
		RESULT = DFa - DRb
	;
		fail
	).


:- pred alias_from_unification(hlds_goal__unification, alias_as).
:- mode alias_from_unification(in, out) is det.

alias_from_unification( construct( VAR, CONS, ARGS, _, _, _, _ ), AS ) :-
	list__foldl( alias_from_unif(VAR,CONS),ARGS, 1 - [], _N - R),
	wrap(R, AS).

alias_from_unification(deconstruct( VAR, CONS, ARGS, _, _ ), AS) :-
	list__foldl( alias_from_unif(VAR,CONS),ARGS, 1 - [], _N - R),
	wrap(R, AS).

alias_from_unification(assign(VAR1,VAR2), AS):-
	datastruct_create_top(VAR1,D1),
	datastruct_create_top(VAR2,D2),
	ALIAS = D1 - D2,
	wrap( [ALIAS], AS).

alias_from_unification(simple_test(_A,_B), AS):-
	init(AS).

alias_from_unification(complicated_unify(_,_,_), AS):-
	% XXXX only if partially instantiated datastructures cannot
	% exist.
	init(AS).

:- import_module int.
:- pred alias_from_unif(prog_var, cons_id, prog_var, 
				pair(int, list(alias)),
				pair(int, list(alias))).
:- mode alias_from_unif(in, in, in, in, out) is det.
alias_from_unif( VAR, CONS, ARG, N - LISTin, N1 - LISTout):-
	datastruct_create( VAR, CONS, N, D1),
	datastruct_create_top( ARG, D2 ),
	ALIAS = D1 - D2,
	N1 is N + 1, 
	LISTout = [ALIAS | LISTin].

	% switch the order of the alias...
:- pred alias_switch(alias,alias).
:- mode alias_switch(in,out) is det.

alias_switch( D1 - D2, D2 - D1 ).
	

%-------------------------------------------------------------------%
% NORMALIZATION WITH TYPE INFORMATION
%-------------------------------------------------------------------%

:- import_module type_util, require.

:- pred normalize_with_type_information( proc_info, module_info, 
						alias_as, alias_as).
:- mode normalize_with_type_information( in, in, in, out) is det.

normalize_with_type_information( ProcInfo, HLDS, Alias0, Alias):-
	(
		Alias0 = real_as(Aliases0)
	->
		proc_info_vartypes( ProcInfo, VarTypes ), 
		list__map( normalize_wti_alias(VarTypes, HLDS), 
				Aliases0, Aliases),
		wrap(Aliases, Alias)
	;
		Alias = Alias0
	).

:- pred normalize_wti_alias( vartypes, module_info, alias, alias ).
:- mode normalize_wti_alias( in, in, in, out) is det.

normalize_wti_alias( VarTypes, HLDS, A0, A ):-
	A0 = Da0 - Db0,
	normalize_wti_datastruct( VarTypes, HLDS, Da0, Da),
	normalize_wti_datastruct( VarTypes, HLDS, Db0, Db),
	A = Da - Db.

:- pred normalize_wti_datastruct( vartypes, module_info, datastruct, datastruct ).
:- mode normalize_wti_datastruct( in, in, in, out) is det.

normalize_wti_datastruct( VarTypes, HLDS, D0, D ):-
	D0 = cel( ProgVar, SEL0 ), 
	map__lookup(VarTypes, ProgVar, VarType),
	(
		type_util__is_introduced_type_info_type(VarType)
	->
		D = D0
	;
		normalize_wti_selector( VarType, HLDS, SEL0, SEL),
		D = cel( ProgVar, SEL )
	).

:- pred normalize_wti_selector( type, module_info, selector, selector).
:- mode normalize_wti_selector( in, in, in, out) is det.

normalize_wti_selector( VarType, HLDS, SEL0, SEL ):-
	branch_map_init( B0 ), 
	selector_init( TOP ),
	branch_map_insert( VarType, TOP, B0, B1 ),
	normalize_wti_selector_2( VarType, HLDS, B1, TOP, SEL0, SEL).

:- pred normalize_wti_selector_2( type, module_info, branch_map, 
				selector, selector, selector).
:- mode normalize_wti_selector_2( in, in, in, in, in, out) is det.

normalize_wti_selector_2( VarType, HLDS, B0, Acc0, SEL0, SEL ):-
	(
		selector_top( SEL0 )
	->
		SEL = Acc0
	;
		selector_take_first_us( SEL0, US, SELR ),
		US = us(CONS, INDEX), 
		type_util__classify_type( VarType, HLDS, Class ),
		(
			Class = user_type
		->
			true
		;
			error("(ka) ka_alias_as: not user type")
		),
		
		type_util__get_cons_id_arg_types(HLDS, VarType, CONS,
							ArgTypes ),
		(
			list__index1(ArgTypes, INDEX, CType )
		->
			( 
				branch_map_search( B0, CType, BSel )
			->
				normalize_wti_selector_2( CType, HLDS,
						B0, BSel, SELR, SEL )
			;
				selector_add_us( Acc0, US, Acc1 ),
				branch_map_insert( CType, Acc1, B0, B1 ),
				normalize_wti_selector_2( CType, HLDS, 
						B1, Acc1, SELR, SEL )
			)
		;
			error("(ka) ka_alias_as: index not found")
		)
	).
			
	
%-------------------------------------------------------------------%
% BRANCH_MAP : copy/pasted from wimvh/bta_reduce.m
%-------------------------------------------------------------------%

:- import_module assoc_list.

:- type branch_map == assoc_list(type, selector).

:- pred branch_map_init(branch_map).
:- mode branch_map_init(out) is det.

:- pred branch_map_insert(type, selector, branch_map, branch_map).
:- mode branch_map_insert(in, in, in, out) is det.
        
:- pred branch_map_search(branch_map, type, selector).
:- mode branch_map_search(in, in, out) is semidet.

branch_map_init([]).

branch_map_insert(Type, SelPart, Map1, [(Type - SelPart) | Map1]).

branch_map_search([ (T1 - S1) | Ms ], T2, S):-
        map__init(Empty),
                % The two types are considered equal if they
		% unify
                % under an empty substitution
        ( 
		type_unify(T1, T2, [], Empty, Subst), 
		map__is_empty(Subst)
	->
                S = S1
	;
	        branch_map_search(Ms, T2, S)
	).

%-------------------------------------------------------------------%
%-- datastruct manipulations

:- pred datastruct_get_var(datastruct,prog_var).
:- mode datastruct_get_var(in,out) is det.

:- pred datastruct_get_selector(datastruct, selector).
:- mode datastruct_get_selector(in,out) is det.

datastruct_get_var(cel(VAR, _Sel), VAR).
datastruct_get_selector(cel(_Var, SEL), SEL).


:- pred datastruct_rename(map(prog_var,prog_var), datastruct, datastruct).
:- mode datastruct_rename(in, in ,out) is det.

datastruct_rename( MAP, DATAin, DATAout) :-
	DATAin = cel(VAR, SEL),
	map__lookup( MAP, VAR, RVAR),
	DATAout = cel(RVAR, SEL).


:- pred datastruct_equal(datastruct, datastruct).
:- mode datastruct_equal(in,in) is semidet.

datastruct_equal( D1, D2 ):- D1 = D2.

:- pred datastruct_same_vars(datastruct,datastruct).
:- mode datastruct_same_vars(in,in) is semidet.

datastruct_same_vars(D1, D2):-
	datastruct_get_var(D1,V),
	datastruct_get_var(D2,V).

:- pred datastruct_leq_selectors(datastruct,datastruct).
:- mode datastruct_leq_selectors(in,in) is semidet.

datastruct_leq_selectors(D1,D2):-
	(
		D1 = D2
	->
		true
	;
		datastruct_get_selector(D1,S1),
		datastruct_get_selector(D2,S2),
		selector_leq(S1,S2)
	).

:- pred datastruct_termshift(datastruct, selector, datastruct).
:- mode datastruct_termshift(in,in,out) is det.

datastruct_termshift(Din, S, Dout):-
	Din = cel(V,Sin),
	selector_termshift(Sin,S,Sout),
	Dout = cel(V,Sout).

:- pred datastruct_create(prog_var, cons_id, int, datastruct).
:- mode datastruct_create(in,in,in,out) is det.

datastruct_create( V, CONS, INDEX, Dout) :-
	unit_sel_create(CONS,INDEX, US),
	SEL = [US],
	Dout = cel(V,SEL).

:- pred datastruct_create_top(prog_var,datastruct).
:- mode datastruct_create_top(in,out) is det.

datastruct_create_top( V, Dout) :-
	SEL = [],
	Dout = cel(V, SEL).

%-------------------------------------------------------------------%
%-- selector manipulations

:- pred selector_init(selector::out) is det.
:- pred selector_top(selector::in) is semidet.

selector_init([]).
selector_top([]).

:- pred selector_take_first_us( selector, unit_sel, selector).
:- mode selector_take_first_us( in, out, out) is det.

selector_take_first_us( SEL0, US, SEL ):-
	(
		SEL0 = [ F | R ]
	->
		US = F, SEL = R
	;
		error("(ka) ka_alias_as: trying to split empty selector!")
	).

:- pred selector_add_us( selector, unit_sel, selector).
:- mode selector_add_us( in, in, out) is det.

selector_add_us( S0, US, S ):-
	list__append( S0, [US], S ).
:- pred unit_sel_create(cons_id, index, unit_sel).
:- mode unit_sel_create(in,in,out) is det.

unit_sel_create(CONS, INDEX, US):-
	US = us( CONS, INDEX).

:- pred selector_leq(selector, selector).
:- mode selector_leq(in, in) is semidet.

selector_leq( S1, S2 ) :- 
		% XXXX dirty dirty dirty
		% S1 is less than or equal (i.e., is subsumed by) S2,
		% if S1 can be selected through S2 by appending extra
		% unit-selectors to S2.
	list__append(S2, _ , S1). 

	% selector_match(S1,S2,EXT) such that
	% S1.EXT = S2
:- pred selector_match(selector,selector,selector).
:- mode selector_match(in,in,out) is semidet.

selector_match( S1, S2, EXT) :-
	list__append(S1,EXT,S2).

:- pred selector_termshift(selector,selector,selector).
:- mode selector_termshift(in,in,out) is det.

selector_termshift(S1,S2,S):- list__append(S1,S2,S).

-------
new file: ka_util.m

%-----------------------------------------------------------------------------%
% Copyright (C) 1996-2000 The University of Melbourne.
% This file may only be copied under the terms of the GNU General
% Public License - see the file COPYING in the Mercury distribution.
%-----------------------------------------------------------------------------%

% module ka_util: extra datastructures and predicates needed by the
%		  KUL aliasing pass
% main author: nancy

:- module ka_util.

:- interface.

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

:- import_module list, map, bool.
:- import_module hlds_pred.
:- import_module ka_alias_as.

	% table of alias substitutions needed for fixpoint computation.
:- type ka_fixpoint_table ---> 
			ka_fixpoint(
					int, 	      % counts the runs
					is_recursive, % default = no
					is_stable,    % default = yes
					map( pred_proc_id, tabled_alias_as)
				).
:- type tabled_alias_as --->
			not_available ; available(alias_as).
			
:- type is_recursive == bool.
:- type is_stable == bool.

	% initialize the table given the pred_proc_id's which will be
	% handled in this fixpoint computation. 
:- pred ka_fixpoint_table_init(list(pred_proc_id)::in, ka_fixpoint_table::out) is det.

	% the datastructure keeps track of the number of fixpoint runs
	% performed, this predicates adds one. 
:- pred ka_fixpoint_table_new_run( ka_fixpoint_table::in, ka_fixpoint_table::out) is det.

	% check whether all entries are stable. If so, one has reached
	% a fixpoint
:- pred ka_fixpoint_table_all_stable( ka_fixpoint_table:: in ) is semidet.

	% at the end of the analysis of one single pred_proc_id, 
	% the new exit alias information is stored. This might
	% change the stability of the table. 
	% if the pred_proc_id is not in the table --> error
:- pred ka_fixpoint_table_new_as( pred_proc_id, alias_as, 
			ka_fixpoint_table, ka_fixpoint_table).
:- mode ka_fixpoint_table_new_as( in, in, in, out) is det.

	% retreive the alias abstract substitution of a given
	% pred_proc_id. If this information is not available,
	% the general character of the fixpoint-table will be
	% set to `recursive'
	% if the pred_proc_id is not in the table --> fail
:- pred ka_fixpoint_table_get_as( pred_proc_id, alias_as, 
			ka_fixpoint_table, ka_fixpoint_table).
:- mode ka_fixpoint_table_get_as( in, out, in, out) is semidet.

	% retreive alias_as information, without changing the
	% table. To be used after fixpoint has been reached. 
:- pred ka_fixpoint_table_get_final_as( pred_proc_id, alias_as, 
						ka_fixpoint_table).
:- mode ka_fixpoint_table_get_final_as( in, out, in) is det.


%-------------------------------------------------------------------%
%-------------------------------------------------------------------%
:- implementation.

:- import_module require,int.

ka_fixpoint_table_init( PRED_PROC_IDS, TABLE):- 
	map__init( Map0 ),
	list__foldl( pred( PRED_PROC::in, Min::in, Mout::out) is det :-
			( map__det_insert( Min, PRED_PROC, not_available, Mout )),
		     PRED_PROC_IDS,
		     Map0,
		     Map1 ),
	TABLE = ka_fixpoint( 1, no, yes, Map1 ).

ka_fixpoint_table_new_run( Tin, Tout ) :-
	Tin = ka_fixpoint( Runs, R, S, M),
	Runs1 is Runs + 1,
	Tout = ka_fixpoint( Runs1, R, S, M).

ka_fixpoint_table_all_stable( TABLE ) :-
	TABLE = ka_fixpoint( _, R, S, _ ),
	(
		R = yes
	->
		S = yes
	;
		true 
	).
	

ka_fixpoint_table_new_as( PRED_PROC_ID, ALIAS_AS, Tin, Tout) :-
	Tin = ka_fixpoint( Runs, R, _S, Min),
	map__lookup( Min, PRED_PROC_ID, TabledASin),
	(
		TabledASin = available( SomeAS),
		ka_alias_as__equal( SomeAS, ALIAS_AS )
	->	
		Stability = yes,
		TabledASout = TabledASin
	;
		Stability = no,
		TabledASout = available( ALIAS_AS )
	),
	map__det_update( Min, PRED_PROC_ID, TabledASout, Mout),
	Tout = ka_fixpoint( Runs, R, Stability, Mout).

ka_fixpoint_table_get_as( PRED_PROC_ID, ALIAS_AS, Tin, Tout) :-
	Tin = ka_fixpoint( Runs, _R, S, M ),
	map__search( M, PRED_PROC_ID, TabledAS), % can fail
	(
		TabledAS = available(AS)
	->
		ALIAS_AS = AS,
		Rout = no,
		Mout = M
	;
		ka_alias_as__init(ALIAS_AS),
		NewTabled = available(ALIAS_AS),
					% the alias_as in the table
					% is also updated. 
		map__det_update( M, PRED_PROC_ID, NewTabled, Mout),
		Rout = yes   		% fixpoint now recursive
	),
	Tout = ka_fixpoint( Runs, Rout, S, Mout ).

ka_fixpoint_table_get_final_as( PRED_PROC_ID, ALIAS_AS, T ):-
	T = ka_fixpoint( _Runs, _R, _S, M ),
	map__lookup( M, PRED_PROC_ID, TabledAS), 
	(	
		TabledAS = available(AS)
	->
		ALIAS_AS = AS
	;
		error("Internal error: ka_util__fixpoint_get_final_as")
	).




-------
new file: ka_run.m

%-----------------------------------------------------------------------------%
% Copyright (C) 1996-2000 The University of Melbourne.
% This file may only be copied under the terms of the GNU General
% Public License - see the file COPYING in the Mercury distribution.
%-----------------------------------------------------------------------------%

% module ka_run: implements the process of annotating each predicate, each
%                procedure with KUL alias information
% main author: nancy

:- module ka_run.

:- interface.

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

:- import_module io.
:- import_module hlds_module.

:- pred ka_run__aliases_pass( module_info, module_info, io__state, io__state).
:- mode ka_run__aliases_pass( in, out, di, uo) is det.

%-------------------------------------------------------------------%
%-------------------------------------------------------------------%
:- implementation.

:- import_module require.
:- import_module list, map.
:- import_module dependency_graph.
:- import_module instmap.
:- import_module hlds_pred, hlds_goal, prog_data.
:- import_module ka_util, ka_alias_as.
:- import_module std_util, string.



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

ka_run__aliases_pass( HLDSin, HLDSout ) -->
		% first load all interfaces.
	ka_run__ensure_loaded_interfaces( HLDSin, HLDS0 ),
		% strongly connected components needed
	{ module_info_ensure_dependency_info( HLDS0, HLDS1) },
	{ module_info_get_maybe_dependency_info( HLDS1, MaybeDepInfo) } ,
	(
		{ MaybeDepInfo = yes(DepInfo) }
	->
		{ hlds_dependency_info_get_dependency_ordering( DepInfo, DepOrdering ) },
		% perform the analysis
		{ run_with_dependencies( DepOrdering, HLDS1, HLDSout) },
		% write out the results
		ka_run__make_ka_interface( HLDSout )
	;
		{ error("(ka) ka_run module: no dependency info") }
	).

:- pred run_with_dependencies( dependency_ordering, module_info, 
					module_info).
:- mode run_with_dependencies( in, in, out) is det.

run_with_dependencies( Deps, HLDSin, HLDSout) :- 
	list__foldl( run_with_dependency, Deps, HLDSin, HLDSout ).

:- pred run_with_dependency( list(pred_proc_id), module_info, module_info).
:- mode run_with_dependency( in, in, out ) is det.

run_with_dependency( SCC , HLDSin, HLDSout ) :-
	(
		% analysis ignores special predicates
		some_are_special_preds(SCC, HLDSin)
	->
		HLDSout = HLDSin
	;
		% for each list of strongly connected components, 
		% perform a fixpoint computation.
		ka_util__ka_fixpoint_table_init( SCC, FPtable0 ),
		run_with_dependency_until_fixpoint( SCC, FPtable0, 
					HLDSin, HLDSout )
	).

:- pred some_are_special_preds( list(pred_proc_id), module_info).
:- mode some_are_special_preds( in, in ) is semidet.

some_are_special_preds( SCC, HLDS ):-
	module_info_get_special_pred_map( HLDS, MAP), 
	map__values( MAP, SpecPRED_IDS ), 
	list__takewhile( pred_id_in(SpecPRED_IDS), SCC,
				_SCC_IN, SCC_NOT_IN ),
	SCC_NOT_IN = [].

:- pred pred_id_in( list(pred_id), pred_proc_id ).
:- mode pred_id_in( in, in) is semidet.

pred_id_in( IDS, PRED_PROC_ID):-
	PRED_PROC_ID = proc( PRED_ID, _),
	list__member( PRED_ID, IDS ). 

:- pred run_with_dependency_until_fixpoint( list(pred_proc_id), 
		ka_util__ka_fixpoint_table, module_info, module_info ).
:- mode run_with_dependency_until_fixpoint( in, in, in, out ) is det.

run_with_dependency_until_fixpoint( SCC, FPtable0, HLDSin, HLDSout ):-
	list__foldl( analyse_pred_proc( HLDSin), SCC, FPtable0, FPtable),
	(
		ka_fixpoint_table_all_stable( FPtable )
	->
		list__foldl( update_alias_in_module_info(FPtable), SCC, HLDSin, HLDSout)
	;
		ka_util__ka_fixpoint_table_new_run(FPtable,FPtable1),	
		run_with_dependency_until_fixpoint( SCC, FPtable1, HLDSin, HLDSout )
	).

%-------------------------------------------------------------------%
% THE KERNEL 
%-------------------------------------------------------------------%
:- pred analyse_pred_proc( module_info, pred_proc_id, ka_fixpoint_table, 
						ka_fixpoint_table).
:- mode analyse_pred_proc( in, in, in, out) is det.

analyse_pred_proc( HLDS, PRED_PROC_ID , FPtable0, FPtable):-
	module_info_pred_proc_info( HLDS, PRED_PROC_ID, _PredInfo, ProcInfo),
	proc_info_goal( ProcInfo, Goal), 
	proc_info_headvars( ProcInfo, HeadVars),
	Goal = _ - GoalInfo,
	goal_info_get_instmap_delta(GoalInfo, InstMapDelta),
	instmap__init_reachable(InitIM),
	instmap__apply_instmap_delta(InitIM, InstMapDelta, InstMap),

	ka_alias_as__init(Alias0),
	analyse_goal( HLDS, Goal, FPtable0, FPtable1, Alias0, Alias1 ),
	ka_alias_as__project( HeadVars, Alias1, Alias2),
	ka_alias_as__normalize( ProcInfo, HLDS, InstMap, Alias2, Alias ),
		
	ka_fixpoint_table_new_as( PRED_PROC_ID, Alias, FPtable1, FPtable).

	% analyse a given goal, with module_info and fixpoint table
	% to lookup extra information, starting from an initial abstract
	% substitution, and creating a new one. During this process,
	% the fixpoint table might change (when recursive predicates are
	% encountered).
:- pred analyse_goal( module_info, hlds_goal,
				ka_fixpoint_table, ka_fixpoint_table,
				alias_as, alias_as).
:- mode analyse_goal( in, in, in, out, in, out) is det.

analyse_goal( HLDS, Goal, FPtable0, FPtable, Alias0, Alias ) :- 
	Goal = GoalExpr - _GoalInfo ,
	analyse_goal_expr( GoalExpr, HLDS, FPtable0, FPtable, Alias0, Alias).
	
:- pred analyse_goal_expr( hlds_goal_expr, module_info, 
				ka_fixpoint_table, ka_fixpoint_table,
				alias_as, alias_as).
:- mode analyse_goal_expr( in, in, in, out, in, out) is det.

analyse_goal_expr( conj(Goals), HLDS , T0, T, A0, A) :-
	list__foldl2( analyse_goal(HLDS),  Goals, T0, T, A0, A).
	
analyse_goal_expr( call(PredID, ProcID, ARGS, _,_, _PName), HLDS, T0, T, A0, A):- 
	PRED_PROC_ID = proc(PredID, ProcID),
	lookup_call_alias( PRED_PROC_ID, HLDS, T0, T, CallAlias), 
	rename_call_alias( PRED_PROC_ID, HLDS, ARGS, CallAlias, RenamedCallAlias),
	ka_alias_as__extend( RenamedCallAlias, A0, A ).

analyse_goal_expr( generic_call(_,_,_,_), _HLDS , T, T, A, A):- 
	error("(ka) generic_call not handled") .

analyse_goal_expr( switch(_Var,_CF,Cases,_SM), HLDS, T0, T, A0, A ):-
	list__map_foldl( analyse_case(HLDS, A0), Cases, SwitchAliases, T0, T),
	ka_alias_as__least_upper_bound_list( SwitchAliases, A ).

:- pred analyse_case( module_info, alias_as, case, alias_as, ka_fixpoint_table,
						   ka_fixpoint_table ).
:- mode analyse_case( in, in, in, out, in, out ) is det.

analyse_case( HLDS, Alias0, CASE, Alias, T0, T ):-
	CASE = case( _, Goal),
	analyse_goal( HLDS, Goal, T0, T, Alias0, Alias).

analyse_goal_expr( unify(_,_,_,Unification,_), _, T, T, A0, A ):-
	ka_alias_as__extend_unification( Unification, A0, A).

analyse_goal_expr( disj(Goals, _SM), HLDS, T0, T, A0, A ):-
	list__map_foldl( 
		pred( Goal::in, Alias::out, FPT0::in, FPT::out) is det :- 
			( analyse_goal( HLDS, Goal, FPT0, FPT, A0, Alias)),
		Goals,
		DisjAliases,
		T0, T ),
	ka_alias_as__least_upper_bound_list( DisjAliases, A ).

analyse_goal_expr( not(Goal), HLDS , T0, T, A0, A ):-
	analyse_goal( HLDS, Goal, T0, T, A0, A).

analyse_goal_expr( some(_Vars,_,_Goal), _ , T, T, A, A):-
	error( "(ka) some goal not handled") .

analyse_goal_expr( if_then_else(_VARS, IF, THEN, ELSE, _SM), HLDS , T0, T, A0, A) :- 
	analyse_goal( HLDS, IF, T0, T1, A0, A1),
	analyse_goal( HLDS, THEN, T1, T2, A1, A2),
	analyse_goal( HLDS, ELSE, T2, T, A0, A3),
	ka_alias_as__least_upper_bound( A2, A3, A).

analyse_goal_expr( pragma_c_code( _,_,_,_,_,_,_  ), _ , T, T, A, A) :- 
	error( "(ka) pragma_c_code not handled") .
analyse_goal_expr( par_conj( _Goals, _SM), _ , T, T, A, A) :-  
	error( "(ka) par_conj not handled") .
analyse_goal_expr( bi_implication( _G1, _G2), _ , T, T, A, A) :- 
	error( "(ka) bi_implication not handled") .

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

	% lookup the alias of the procedure with given pred_proc_id,
	% look first in table, if this fails (then not in same SCC), 
	% look in module_info. If this fails, an error is produced.
	% XXXX: near future: if the types used within an unknown
	% call are all primitive types, aliases cannot be created 
	% anyway, and analysis could proceed. Not yet implemented.
:- pred lookup_call_alias( pred_proc_id, module_info, ka_fixpoint_table,
			 	ka_fixpoint_table, alias_as ).
:- mode lookup_call_alias( in, in, in, out, out) is det.

lookup_call_alias( PRED_PROC_ID, HLDS, FPtable0, FPtable, Alias) :-
	(
		ka_fixpoint_table_get_as( PRED_PROC_ID, AL, FPtable0, FPtable1)
	->
		FPtable = FPtable1,
		Alias = AL
	;
		module_info_pred_proc_info( HLDS, PRED_PROC_ID, PredInfo,
						ProcInfo),
		proc_info_possible_aliases(ProcInfo, MaybeAliases),
		(
			MaybeAliases = yes( SomeAL)
		->
			FPtable = FPtable0,
			Alias = SomeAL
		;
			PRED_PROC_ID = proc(PRED_ID, PROC_ID),
			pred_info_name(PredInfo, PNAME), 
			pred_id_to_int(PRED_ID, IPRED_ID),
			proc_id_to_int(PROC_ID, IPROC_ID),
			string__int_to_string(IPRED_ID, SPRED_ID),
			string__int_to_string(IPROC_ID, SPROC_ID),
			string__append_list(["(ka) lookup alias failed for ",PNAME,"(",SPRED_ID, ",", SPROC_ID, ")"], ErrMsg),
			error(ErrMsg)
		)
	).

:- pred rename_call_alias( pred_proc_id, module_info, list(prog_var),
				alias_as, alias_as).
:- mode rename_call_alias( in, in, in, in, out) is det.

rename_call_alias( PRED_PROC_ID, HLDS, ARGS, Ain, Aout ):-
	module_info_pred_proc_info( HLDS, PRED_PROC_ID, _P, ProcInfo),
	proc_info_headvars(ProcInfo, Headvars),
	map__from_corresponding_lists(Headvars,ARGS,Dict),
	ka_alias_as__rename( Dict, Ain, Aout ).

%-------------------------------------------------------------------%
%-------------------------------------------------------------------%
% easy stuff

	% once the abstract alias substitution is computed for
	% a procedure, one must simply update the proc-information
	% of that procedure.
:- pred update_alias_in_module_info(ka_util__ka_fixpoint_table, 
					pred_proc_id, module_info,
					module_info).
:- mode update_alias_in_module_info(in, in, in, out) is det.

update_alias_in_module_info( FPtable, PRED_PROC_ID, HLDSin, HLDSout) :-
	module_info_pred_proc_info(HLDSin, PRED_PROC_ID, PredInfo, ProcInfo),
	ka_fixpoint_table_get_final_as( PRED_PROC_ID, ALIAS_AS, FPtable),
	proc_info_set_possible_aliases( ProcInfo, ALIAS_AS, NewProcInfo),
	module_info_set_pred_proc_info(HLDSin, PRED_PROC_ID, PredInfo,
					NewProcInfo, HLDSout).


%-------------------------------------------------------------------%
%-------------------------------------------------------------------%
% make the interface

:- import_module globals, modules, passes_aux, bool, options.
:- import_module varset.
:- import_module mercury_to_mercury.

	% inspiration taken from termination.m
:- pred ka_run__make_ka_interface( module_info, io__state, io__state ).
:- mode ka_run__make_ka_interface( in, di, uo ) is det.

ka_run__make_ka_interface( HLDS ) --> 
	{ module_info_name( HLDS, ModuleName ) },
	modules__module_name_to_file_name( ModuleName, ".opt.ka", bool__no, KaFileName),
	globals__io_lookup_bool_option(verbose, Verbose),
	maybe_write_string(Verbose, "% -> writing possible aliases to `"),
	maybe_write_string(Verbose, KaFileName ),
	maybe_write_string(Verbose, "'..."),
	maybe_flush_output(Verbose),

	io__open_output( KaFileName, KaFileRes ),
	(
		{ KaFileRes = ok(KaFile) },
		io__set_output_stream( KaFile, OldStream ),
		ka_run__make_ka_interface_2( HLDS ), 
		io__set_output_stream( OldStream, _ ),
		io__close_output( KaFile ),
		maybe_write_string(Verbose, " done.\n"),
		maybe_flush_output(Verbose)
	;
		{ KaFileRes = error( IOError ) },
		maybe_write_string(Verbose, " failed!\n"),
		maybe_flush_output(Verbose),
		{ io__error_message( IOError, IOErrorMsg ) },
		io__write_strings(["Error opening file `",
                        KaFileName, "' for output: ", IOErrorMsg]),
		io__set_exit_status(1)
        ).

:- pred ka_run__make_ka_interface_2( module_info, 
					io__state, io__state).
:- mode ka_run__make_ka_interface_2( in, di, uo) is det.

ka_run__make_ka_interface_2( HLDS ) -->
	{ module_info_name( HLDS, ModuleName ) },
	{ module_info_predids( HLDS, PredIds ) },
	{ module_info_get_special_pred_map( HLDS, MAP ) },
	{ map__values( MAP, SpecPredIds ) },
	io__write_string(":- module "),
	mercury_output_sym_name( ModuleName ), 
	io__write_string(".\n\n"),
	io__write_string(":- interface. \n"),
	list__foldl( make_ka_interface_pred(HLDS, SpecPredIds), PredIds ).

:- pred ka_run__make_ka_interface_pred(module_info, list(pred_id),pred_id, 
					io__state, io__state).
:- mode ka_run__make_ka_interface_pred( in, in, in, di ,uo) is det.

ka_run__make_ka_interface_pred( HLDS, SpecPredIds, PredId ) -->
	{ module_info_pred_info( HLDS, PredId, PredInfo ) },
	(
		{ pred_info_is_exported( PredInfo ) }
	->
		( 
			{ list__member( PredId, SpecPredIds ) }
		->
			[]
		;
			{ pred_info_exported_procids( PredInfo , ProcIds ) } ,
			{ pred_info_procedures( PredInfo, ProcTable ) },
			list__foldl( make_ka_interface_pred_proc( PredInfo, ProcTable),
					ProcIds )
		)
	;
		[]
	).

:- pred ka_run__make_ka_interface_pred_proc( pred_info, proc_table, proc_id,
						io__state, io__state).
:- mode ka_run__make_ka_interface_pred_proc( in, in, in, di, uo) is det.

ka_run__make_ka_interface_pred_proc( PredInfo, ProcTable, ProcId) -->
	io__write_string(":- pragma ka_alias_info("),

		% write a simple predicate declaration

	{ varset__init( InitVarSet ) },
	{ pred_info_name( PredInfo, PredName ) },
	{ pred_info_get_is_pred_or_func( PredInfo, PredOrFunc ) },
	{ pred_info_module( PredInfo, ModuleName ) },
	{ pred_info_context( PredInfo, Context ) },
	{ SymName = qualified( ModuleName, PredName ) },

	{ map__lookup( ProcTable, ProcId, ProcInfo ) },
	{ proc_info_declared_argmodes( ProcInfo, Modes ) },

	(
		{ PredOrFunc = predicate },
		mercury_output_pred_mode_subdecl( InitVarSet, SymName, Modes,
			std_util__no, Context )
	;
		{ PredOrFunc = function },
		{ pred_args_to_func_args( Modes, FuncModes, RetMode ) },
		mercury_output_func_mode_subdecl( InitVarSet, SymName, 
			FuncModes, RetMode, std_util__no, Context )
	),

	io__write_string(", "),

		% write headvars vars(HeadVar__1, ... HeadVar__n)

	{ proc_info_varset(ProcInfo, ProgVarset) },
	{ proc_info_headvars(ProcInfo, HeadVars) },
	io__write_string("vars("),
	mercury_output_vars(HeadVars, ProgVarset, no),
	io__write_string(")"),

	io__write_string(", "),

		% write alias information

	{ proc_info_possible_aliases(ProcInfo, MaybeAliases) },

	ka_alias_as__print_maybe_interface_aliases( MaybeAliases, ProcInfo),

	io__write_string(").\n").

		

%-------------------------------------------------------------------%
%-------------------------------------------------------------------%
% ensure loaded interfaces.

:- import_module term, set, prog_io, globals, prog_out, prog_io_util.
:- import_module hlds_out, assoc_list, mode_util.

	% load interfaces of the imported modules. 
	% If some interface file appears to be unavailable, a warning
	% is generated, and probably the code will fail at some later
	% point. 
:- pred ka_run__ensure_loaded_interfaces( module_info, module_info, 
						io__state, io__state).
:- mode ka_run__ensure_loaded_interfaces( in, out, di, uo) is det.

ka_run__ensure_loaded_interfaces( HLDS0, HLDS) -->
	{ module_info_get_imported_module_specifiers( HLDS0, ModSpecs ) },
	{ set__to_sorted_list( ModSpecs, LModSpecs ) },
	list__foldl2( load_interface, LModSpecs, HLDS0, HLDS).

:- pred load_interface( module_specifier, module_info, module_info,
			io__state, io__state).
:- mode load_interface( in, in, out, di, uo) is det.

load_interface( ModuleSpec, HLDS0, HLDS ) -->
	globals__io_lookup_bool_option(very_verbose, VeryVerbose),
	module_name_to_file_name( ModuleSpec, ".opt.ka", no, FileName ),
	maybe_write_string(VeryVerbose, "% Reading `"),
	maybe_write_string(VeryVerbose, FileName ),
	maybe_write_string(VeryVerbose, "'... "),
	maybe_flush_output(VeryVerbose),
	prog_io__read_module( FileName, ModuleSpec, yes, Err, _ModuleName, 
				Msgs, Items),
	(
		{ Err = fatal }
	->
		maybe_write_string(VeryVerbose, "fatal error(s).\n")
	;
		{ Err = yes }
	->
		maybe_write_string(VeryVerbose, "parse_error(s).\n")
	;
		maybe_write_string(VeryVerbose, "successfull parse.\n")
	),
	prog_out__write_messages(Msgs),
	(
		{ Err = fatal }
	-> 
		maybe_write_string(VeryVerbose, "% Continuing... errors might occur later.\n")
	;
		{ Err = yes }
	->
		maybe_write_string(VeryVerbose, "% Continuing... errors might occur later.\n")
	;
		maybe_write_string(VeryVerbose, "% Cool!\n")
	),

	list__foldl2( add_item_from_opt_ka, Items, HLDS0, HLDS ).

:- pred add_item_from_opt_ka( item_and_context, module_info, module_info, 
					io__state, io__state ).
:- mode add_item_from_opt_ka( in, in, out, di, uo) is det.

add_item_from_opt_ka( Item - _Context, HLDS0, HLDS ) -->
	(
		{ Item = pragma(Pragma) }
	->
		add_pragma_item_from_opt_ka( Pragma , HLDS0, HLDS)
	;
	 	prog_io_util__report_warning(
				"Only pragma ka_alias_info allowed in `.opt.ka' file.")	,
		{ HLDS = HLDS0 }
	).

:- pred add_pragma_item_from_opt_ka( pragma_type, module_info, module_info,
					io__state, io__state).
:- mode add_pragma_item_from_opt_ka( in, in, out, di, uo) is det.

add_pragma_item_from_opt_ka( Pragma, HLDS0, HLDS) -->
	(
		{ Pragma = ka_alias_info( PredOrFunc, SymName, Modes,
					HeadVars, MaybeAlias) }
	->
		add_pragma_possible_aliases_info( PredOrFunc, SymName, Modes,
					HeadVars, MaybeAlias, HLDS0, HLDS)
	;
		prog_io_util__report_warning(
				"Only pragma ka_alias_info allowed in `.opt.ka' file.")	,
		{ HLDS = HLDS0 }
	).


:- pred add_pragma_possible_aliases_info( pred_or_func, sym_name, list(mode),
		list(var(T)), maybe(alias_as),
		module_info, module_info, 
		io__state, io__state).
:- mode add_pragma_possible_aliases_info( in, in, in, in, in, in, out, di, uo) 
		is det.

add_pragma_possible_aliases_info(_, _, _, _, no, Module, Module) --> [].
add_pragma_possible_aliases_info(PredOrFunc,SymName, Modes, 
				HeadVars, yes(AliasAS),
				Module0, Module) --> 
	{ module_info_get_predicate_table(Module0, Preds) },
	{ list__length(Modes, Arity) },
	(
		{ predicate_table_search_pf_sym_arity( Preds,
			PredOrFunc, SymName, Arity, PredIds) },
		{ PredIds \= [] }
	->
	   (
		{ PredIds = [PredId] }
	   ->
		{ module_info_preds(Module0, PredTable0) },
		{ map__lookup(PredTable0, PredId, PredInfo0) },
		{ pred_info_procedures(PredInfo0, ProcTable0) },
		{ map__to_assoc_list(ProcTable0, ProcList) },
		(
			{ get_procedure_matching_declmodes( ProcList,
				Modes, Module0, ProcId) }
		->
			{ map__lookup(ProcTable0, ProcId, ProcInfo0) },
			{ proc_info_headvars(ProcInfo0, ProcHeadVars) },
			{ list__map( term__coerce_var, HeadVars, CHeadVars )},
			{ map__from_corresponding_lists(CHeadVars,
				ProcHeadVars, MapHeadVars) },
			{ ka_alias_as__rename( MapHeadVars, AliasAS, 
						RenAliasAS) },
			{ proc_info_set_possible_aliases( ProcInfo0, 
				RenAliasAS, ProcInfo ) },
			{ map__det_update(ProcTable0, ProcId, ProcInfo,
					ProcTable) },
			{ pred_info_set_procedures(PredInfo0, ProcTable,
					PredInfo) },
			{ map__det_update(PredTable0, PredId, PredInfo,
					PredTable) },
			{ module_info_set_preds( Module0, PredTable, Module) }
		;

		        % 	{ module_info_incr_errors(Module0, Module) },
			io__write_string(
				"Error: `:- pragma ka_alias_info' "),
			io__write_string(
				"declaration for undeclared mode of "),
			hlds_out__write_simple_call_id(PredOrFunc,
				SymName/Arity),
			io__write_string(".\n"),
			{ Module = Module0 },
			io__set_exit_status(1)
		)
	   ;
	   	io__write_string("Error: ambiguous predicate name "),
		hlds_out__write_simple_call_id(PredOrFunc, SymName/Arity),
		io__write_string(" in `pragma ka_alias_info'.\n"),
		{ Module = Module0 },
		io__set_exit_status(1)
		% { module_info_incr_errors(Module0, Module) }
	   )
	;
	   io__write_string("Error: no corresponding predicate found "),
	   hlds_out__write_simple_call_id(PredOrFunc, SymName/Arity),
	   io__write_string(" in `pragma ka_alias_info'.\n"),
	   { Module = Module0 },
	   io__set_exit_status(1)
	   % { module_info_incr_errors(Module0, Module) }
	).

	% Find the procedure with declared argmodes which match the ones 
	% we want.  If there was no mode declaration, then use the inferred
	% argmodes.
	% Copy/pasted from make_hlds.m
:- pred get_procedure_matching_declmodes(assoc_list(proc_id, proc_info),
		list(mode), module_info, proc_id).
:- mode get_procedure_matching_declmodes(in, in, in, out) is semidet.
get_procedure_matching_declmodes([P|Procs], Modes, ModuleInfo, OurProcId) :-
	P = ProcId - ProcInfo,
	proc_info_declared_argmodes(ProcInfo, ArgModes),
	( mode_list_matches(Modes, ArgModes, ModuleInfo) ->
		OurProcId = ProcId
	;
		get_procedure_matching_declmodes(Procs, Modes, ModuleInfo, 
			OurProcId)
	).

:- pred mode_list_matches(list(mode), list(mode), module_info).
:- mode mode_list_matches(in, in, in) is semidet.

mode_list_matches([], [], _).
mode_list_matches([Mode1 | Modes1], [Mode2 | Modes2], ModuleInfo) :-
	% Use mode_get_insts_semidet instead of mode_get_insts to avoid
	% aborting if there are undefined modes.
	mode_get_insts_semidet(ModuleInfo, Mode1, Inst1, Inst2),
	mode_get_insts_semidet(ModuleInfo, Mode2, Inst1, Inst2),
	mode_list_matches(Modes1, Modes2, ModuleInfo).

--------------------------------------------------------------------------
mercury-developers mailing list
Post messages to:       mercury-developers at cs.mu.oz.au
Administrative Queries: owner-mercury-developers at cs.mu.oz.au
Subscriptions:          mercury-developers-request at cs.mu.oz.au
--------------------------------------------------------------------------