for review: last call modulo constructors [3/3]

David Matthew Overton dmo at students.cs.mu.OZ.AU
Mon Jun 22 16:32:53 AEST 1998


Index: compiler/mode_util.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/mode_util.m,v
retrieving revision 1.99.2.17
diff -u -r1.99.2.17 mode_util.m
--- 1.99.2.17	1998/06/17 04:13:33
+++ mode_util.m	1998/06/22 04:07:13
@@ -197,14 +197,6 @@
 
 %-----------------------------------------------------------------------------%
 
-	% Given a list of variables, and a list of livenesses,
-	% select the live variables.
-	%
-:- pred get_live_vars(list(var), list(is_live), list(var)).
-:- mode get_live_vars(in, in, out) is det.
-
-%-----------------------------------------------------------------------------%
-
 	% Construct a mode corresponding to the standard `in',
 	% `out', or `uo' mode.
 :- pred in_mode((mode)::out) is det.
@@ -212,6 +204,14 @@
 :- pred uo_mode((mode)::out) is det.
 
 %-----------------------------------------------------------------------------%
+
+	% Given a list of variables, and a list of livenesses,
+	% select the live variables.
+	%
+:- pred get_live_vars(list(var), list(is_live), list(var)).
+:- mode get_live_vars(in, in, out) is det.
+
+%-----------------------------------------------------------------------------%
 %-----------------------------------------------------------------------------%
 
 :- implementation.
@@ -249,11 +249,11 @@
 	% This is just to make error messages and inferred modes
 	% more readable.
 	%
-	( Initial = free, Final = ground(shared, no) ->
+	( Initial = free(unique), Final = ground(shared, no) ->
 		make_std_mode("out", [], Mode)
-	; Initial = free, Final = ground(unique, no) ->
+	; Initial = free(unique), Final = ground(unique, no) ->
 		make_std_mode("uo", [], Mode)
-	; Initial = free, Final = ground(mostly_unique, no) ->
+	; Initial = free(unique), Final = ground(mostly_unique, no) ->
 		make_std_mode("muo", [], Mode)
 	; Initial = ground(shared, no), Final = ground(shared, no) ->
 		make_std_mode("in", [], Mode)
@@ -267,7 +267,7 @@
 	; Initial = ground(mostly_unique, no),
 	  Final = ground(mostly_unique, no) ->
 		make_std_mode("mdi", [], Mode)
-	; Initial = free ->
+	; Initial = free(unique) ->
 		make_std_mode("out", [Final], Mode)
 	; Final = ground(clobbered, no) ->
 		make_std_mode("di", [Initial], Mode)
@@ -351,14 +351,25 @@
 
 :- pred mode_to_arg_mode_2(inst_table, module_info, mode, arg_mode).
 :- mode mode_to_arg_mode_2(in, in, in, out) is det.
+
 mode_to_arg_mode_2(InstTable, ModuleInfo, Mode, ArgMode) :-
 	mode_get_insts(ModuleInfo, Mode, InitialInst, FinalInst),
 	( inst_is_bound(InitialInst, InstTable, ModuleInfo) ->
 		ArgMode = top_in
 	; inst_is_bound(FinalInst, InstTable, ModuleInfo) ->
-		ArgMode = top_out
+		( inst_is_free_alias(InitialInst, InstTable, ModuleInfo) ->
+			ArgMode = ref_in
+		;
+			ArgMode = top_out
+		)
 	;
-		ArgMode = top_unused
+		( 
+			inst_is_free_alias(FinalInst, InstTable, ModuleInfo)
+		->
+			ArgMode = ref_out
+		;
+			ArgMode = top_unused
+		)
 	).
 
 %-----------------------------------------------------------------------------%
@@ -385,8 +396,9 @@
 		% the code is unreachable
 		ArgInst = not_reached
 	).
-get_single_arg_inst(free, _InstTable, _, _, free).
-get_single_arg_inst(free(_Type), _InstTable, _, _, free).  % XXX loses type info
+get_single_arg_inst(free(A), _InstTable, _, _, free(A)).
+get_single_arg_inst(free(A, _Type), _InstTable, _, _, free(A)).  
+							% XXX loses type info
 get_single_arg_inst(alias(Key), InstTable, ModuleInfo, ConsId, Inst) :-
 	inst_table_get_inst_key_table(InstTable, IKT),
 	inst_key_table_lookup(IKT, Key, Inst0),
@@ -445,10 +457,10 @@
 		% the code is unreachable
 		list__duplicate(Arity, not_reached, ArgInsts)
 	).
-get_arg_insts(free, _ConsId, Arity, ArgInsts) :-
-	list__duplicate(Arity, free, ArgInsts).
-get_arg_insts(free(_Type), _ConsId, Arity, ArgInsts) :-
-	list__duplicate(Arity, free, ArgInsts).
+get_arg_insts(free(A), _ConsId, Arity, ArgInsts) :-
+	list__duplicate(Arity, free(A), ArgInsts).
+get_arg_insts(free(A, _Type), _ConsId, Arity, ArgInsts) :-
+	list__duplicate(Arity, free(A), ArgInsts).
 get_arg_insts(any(Uniq), _ConsId, Arity, ArgInsts) :-
 	list__duplicate(Arity, any(Uniq), ArgInsts).
 
@@ -606,8 +618,8 @@
 	inst_table_get_inst_key_table(InstTable, IKT),
 	inst_key_table_lookup(IKT, Key, Inst),
 	inst_has_no_duplicate_inst_keys(Set1, Set, Inst, InstTable, ModuleInfo).
+inst_has_no_duplicate_inst_keys(Set, Set, free(_, _), _InstTable, _ModuleInfo).
 inst_has_no_duplicate_inst_keys(Set, Set, free(_), _InstTable, _ModuleInfo).
-inst_has_no_duplicate_inst_keys(Set, Set, free, _InstTable, _ModuleInfo).
 inst_has_no_duplicate_inst_keys(Set0, Set, bound(_, BoundInsts), InstTable,
 		ModuleInfo) :-
 	bound_insts_list_has_no_duplicate_inst_keys(Set0, Set, BoundInsts,
@@ -787,10 +799,10 @@
 
 % propagate_ctor_info(free, Type, _, _, _, free(Type)).
 							% temporarily disabled
-propagate_ctor_info(free, _Type, _, _, _, free).
+propagate_ctor_info(free(A), _Type, _, _, _, free(A)).
 							% XXX temporary hack
 
-propagate_ctor_info(free(_), _, _, _, _, _) :-
+propagate_ctor_info(free(_, _), _, _, _, _, _) :-
 	error("propagate_ctor_info: type info already present").
 propagate_ctor_info(bound(Uniq, BoundInsts0), Type, _Constructors, InstTable,
 		ModuleInfo, Inst) :-
@@ -860,10 +872,10 @@
 
 % propagate_ctor_info_lazily(free, Type, _, _, _, free(Type)).
 							% temporarily disabled
-propagate_ctor_info_lazily(free, _Type, _, _, _, free).
+propagate_ctor_info_lazily(free(A), _Type, _, _, _, free(A)).
 							% XXX temporary hack
 
-propagate_ctor_info_lazily(free(_), _, _, _, _, _) :-
+propagate_ctor_info_lazily(free(_, _), _, _, _, _, _) :-
 	error("propagate_ctor_info_lazily: type info already present").
 propagate_ctor_info_lazily(bound(Uniq, BoundInsts0), Type0, Subst, 
 		InstTable, ModuleInfo, Inst) :-
@@ -945,7 +957,7 @@
 
 default_higher_order_func_inst(PredArgTypes, ModuleInfo, PredInstInfo) :-
 	In = (ground(shared, no) -> ground(shared, no)),
-	Out = (free -> ground(shared, no)),
+	Out = (free(unique) -> ground(shared, no)),
 	list__length(PredArgTypes, NumPredArgs),
 	NumFuncArgs is NumPredArgs - 1,
 	list__duplicate(NumFuncArgs, In, FuncArgModes),
@@ -1163,8 +1175,8 @@
 inst_apply_substitution(any(Uniq), _, any(Uniq)).
 inst_apply_substitution(alias(Var), _, alias(Var)) :-
 	error("inst_apply_substitution: alias").
-inst_apply_substitution(free, _, free).
-inst_apply_substitution(free(T), _, free(T)).
+inst_apply_substitution(free(A), _, free(A)).
+inst_apply_substitution(free(A, T), _, free(A, T)).
 inst_apply_substitution(ground(Uniq, PredStuff0), Subst,
 			ground(Uniq, PredStuff)) :-
 	maybe_pred_inst_apply_substitution(PredStuff0, Subst, PredStuff).
@@ -1435,8 +1447,15 @@
 		goal_info_set_instmap_delta(GoalInfo1, InstMapDelta, GoalInfo),
 		instmap__init_unreachable(InstMap)
 	;
-		goal_info_get_nonlocals(GoalInfo1, NonLocals),
-		instmap_delta_restrict(InstMapDelta0, NonLocals, InstMapDelta),
+		% AAA some non-locals that have their insts changed by
+		% this call may not be in the non-locals set, if they were
+		% changed via aliases.   Andrew Bromage is working on
+		% a solution to this, but for now it is necessary to
+		% keep all vars in the instmap_delta, even if they're
+		% not in NonLocals.
+		%goal_info_get_nonlocals(GoalInfo1, NonLocals),
+		%instmap_delta_restrict(InstMapDelta0, NonLocals, InstMapDelta),
+		InstMapDelta = InstMapDelta0,
 		goal_info_set_instmap_delta(GoalInfo1, InstMapDelta, GoalInfo),
 		instmap__apply_instmap_delta(InstMap0, InstMapDelta, InstMap)
 	),
@@ -2051,7 +2070,14 @@
 		InstMap0 = InstMap,
 		IKT0 = IKT
 	;
-		inst_key_table_add(IKT0, Inst, InstKey, IKT),
+		( Inst = free(_) ->
+			NewInst = free(alias)
+		; Inst = free(_, T) ->
+			NewInst = free(alias, T)
+		;
+			NewInst = Inst
+		),
+		inst_key_table_add(IKT0, NewInst, InstKey, IKT),
 		instmap__set(InstMap0, Var, alias(InstKey), InstMap)
 	).
 
@@ -2131,8 +2157,8 @@
 strip_builtin_qualifiers_from_inst(inst_var(V), inst_var(V)).
 strip_builtin_qualifiers_from_inst(alias(V), alias(V)).
 strip_builtin_qualifiers_from_inst(not_reached, not_reached).
-strip_builtin_qualifiers_from_inst(free, free).
-strip_builtin_qualifiers_from_inst(free(Type), free(Type)).
+strip_builtin_qualifiers_from_inst(free(A), free(A)).
+strip_builtin_qualifiers_from_inst(free(A, Type), free(A, Type)).
 strip_builtin_qualifiers_from_inst(any(Uniq), any(Uniq)).
 strip_builtin_qualifiers_from_inst(ground(Uniq, Pred0), ground(Uniq, Pred)) :-
 	strip_builtin_qualifiers_from_pred_inst(Pred0, Pred).
@@ -2265,7 +2291,7 @@
 		InstTable, ModuleInfo) :-
 	( ConsId = cons(_, Arity) ->
 		list__duplicate(Arity, dead, ArgLives),
-		list__duplicate(Arity, free, ArgInsts)
+		list__duplicate(Arity, free(unique), ArgInsts)
 	;
 		ArgLives = [],
 		ArgInsts = []
@@ -2290,14 +2316,6 @@
 %-----------------------------------------------------------------------------%
 %-----------------------------------------------------------------------------%
 
-in_mode(Mode) :- make_std_mode("in", [], Mode).
-
-out_mode(Mode) :- make_std_mode("out", [], Mode).
-
-uo_mode(Mode) :- make_std_mode("uo", [], Mode).
-
-%-----------------------------------------------------------------------------%
-
 :- pred make_std_mode(string, list(inst), mode).
 :- mode make_std_mode(in, in, out) is det.
 
@@ -2414,6 +2432,14 @@
 
 %-----------------------------------------------------------------------------%
 
+in_mode(Mode) :- make_std_mode("in", [], Mode).
+
+out_mode(Mode) :- make_std_mode("out", [], Mode).
+
+uo_mode(Mode) :- make_std_mode("uo", [], Mode).
+
+%-----------------------------------------------------------------------------%
+
 	% Given a list of variables, and a list of livenesses,
 	% select the live variables.
 
Index: compiler/modecheck_unify.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/modecheck_unify.m,v
retrieving revision 1.22.2.12
diff -u -r1.22.2.12 modecheck_unify.m
--- 1.22.2.12	1998/06/05 08:46:16
+++ modecheck_unify.m	1998/06/22 01:02:59
@@ -578,7 +578,8 @@
 			% return any old garbage
 		RHS = lambda_goal(PredOrFunc, ArgVars, Vars,
 				Modes0, Det, IMDelta, LambdaGoal0),
-		Mode = (free -> free) - (free -> free),
+		Mode = (free(unique) -> free(unique)) - 
+			(free(unique) -> free(unique)),
 		Unification = Unification0
 	),
 	Goal = unify(X, RHS, Mode, Unification, UnifyContext).
@@ -723,8 +724,15 @@
 	;
 		map__init(Sub0),
 		abstractly_unify_inst_functor(LiveX, InstOfX, ConsId,
-			InstArgs, LiveArgs, real_unify, InstTable1, ModuleInfo1, Sub0,
-			UnifyInst, Det1, InstTable2, ModuleInfo2, Sub)
+			InstArgs, LiveArgs, real_unify, InstTable1, ModuleInfo1,
+			Sub0, UnifyInst, Det1, InstTable2, ModuleInfo2, Sub),
+		\+ inst_contains_free_alias(UnifyInst, InstTable2, ModuleInfo2)
+			% AAA when we allow users to create
+			% free(alias) insts themselves we will need a
+			% better scheduling algorithm.  For now, it's
+			% ok to disallow free(alias) insts in
+			% mode-checking because they are only created
+			% in the LCO pass.
 	->
 		Inst = UnifyInst,
 		mode_info_set_module_info(ModeInfo1, ModuleInfo2, ModeInfo2),
@@ -917,7 +925,8 @@
 		mode_info_set_var_types(VarTypes, ModeInfo1, ModeInfo2),
 
 		% change the main unification to use `Var' instead of Var0
-		UniMode = (InitialInstX - free -> InitialInstX - InitialInstX),
+		UniMode = (InitialInstX - free(unique) -> 
+				InitialInstX - InitialInstX),
 
 		% Compute the instmap that results after the main unification.
 		% We just need to set the inst of `Var'.
Index: compiler/module_qual.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/module_qual.m,v
retrieving revision 1.22.2.8
diff -u -r1.22.2.8 module_qual.m
--- 1.22.2.8	1998/06/05 08:46:25
+++ module_qual.m	1998/06/22 01:02:59
@@ -514,9 +514,11 @@
 qualify_inst(any(A), any(A), Info, Info) --> [].
 qualify_inst(alias(V), alias(V), Info, Info) -->
 	{ error("qualify_inst: alias") }.
-qualify_inst(free, free, Info, Info) --> [].
+qualify_inst(free(unique), free(unique), Info, Info) --> [].
+qualify_inst(free(alias), _, _, _) -->
+	{ error("compiler generated inst not expected") }.
 qualify_inst(not_reached, not_reached, Info, Info) --> [].
-qualify_inst(free(_), _, _, _) -->
+qualify_inst(free(_, _), _, _, _) -->
 	{ error("compiler generated inst not expected") }.
 qualify_inst(bound(Uniq, BoundInsts0), bound(Uniq, BoundInsts),
 				Info0, Info) -->
Index: compiler/par_conj_gen.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/par_conj_gen.m,v
retrieving revision 1.1.2.1
diff -u -r1.1.2.1 par_conj_gen.m
--- 1.1.2.1	1998/06/17 04:54:55
+++ par_conj_gen.m	1998/06/22 01:02:59
@@ -159,7 +159,8 @@
 	code_info__get_stack_slots(AllSlots),
 	code_info__get_known_variables(Variables),
 	{ set__list_to_set(Variables, LiveVars) },
-	{ map__select(AllSlots, LiveVars, StoreMap) },
+	{ map__select(AllSlots, LiveVars, LiveSlots) },
+	code_info__stack_slots_to_store_map(LiveSlots, StoreMap),
 	code_info__generate_branch_end(model_det, StoreMap, SaveCode),
 	{ Goal = _GoalExpr - GoalInfo },
 	{ goal_info_get_instmap_delta(GoalInfo, Delta) },
Index: compiler/pd_util.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/pd_util.m,v
retrieving revision 1.1.6.1
diff -u -r1.1.6.1 pd_util.m
--- 1.1.6.1	1998/06/09 04:28:28
+++ pd_util.m	1998/06/22 01:03:00
@@ -160,7 +160,10 @@
 	{ simplify_info_init(DetInfo0, Simplifications, InstMap0,
 		VarSet0, VarTypes0, SimplifyInfo0) },
 
-	{ simplify__process_goal(Goal0, Goal, SimplifyInfo0, SimplifyInfo) },
+	pd_info_get_io_state(IO0),
+	{ simplify__process_goal(Goal0, Goal, SimplifyInfo0, SimplifyInfo,
+		IO0, IO) },
+	pd_info_set_io_state(IO),
 
 	%
 	% Deconstruct the simplify_info.
@@ -479,7 +482,7 @@
 			Case = case(_, CaseIMD, _ - CaseInfo),
 			goal_info_get_instmap_delta(CaseInfo, GoalIMD),
 			instmap_delta_apply_instmap_delta(CaseIMD, GoalIMD,
-				InstMapDelta) % AAA is this right?
+				InstMapDelta)
 		)),
 	list__map(GetCaseInstMapDelta, Cases, InstMapDeltas).
 pd_util__get_branch_instmap_deltas(disj(Disjuncts, _) - _, InstMapDeltas) :-
@@ -727,7 +730,7 @@
 :- mode inst_MSG_2(in, in, in, in, out) is semidet.
 
 inst_MSG_2(any(_), any(Uniq), _IT, _M, any(Uniq)).
-inst_MSG_2(free, free, _IT, _M, free).
+inst_MSG_2(free(Aliasing), free(Aliasing), _IT, _M, free(Aliasing)).
 
 inst_MSG_2(bound(_, ListA), bound(UniqB, ListB), InstTable, ModuleInfo, Inst) :-
 	bound_inst_list_MSG(ListA, ListB, InstTable, ModuleInfo, UniqB, ListB,
@@ -814,8 +817,8 @@
 
 pd_util__inst_size_2(_, _, not_reached, _, 0).
 pd_util__inst_size_2(_, _, any(_), _, 0).
-pd_util__inst_size_2(_, _, free, _, 0).
 pd_util__inst_size_2(_, _, free(_), _, 0).
+pd_util__inst_size_2(_, _, free(_,_), _, 0).
 pd_util__inst_size_2(_, _, ground(_, _), _, 0).
 pd_util__inst_size_2(_, _, inst_var(_), _, 0).
 pd_util__inst_size_2(_, _, abstract_inst(_, _), _, 0).
Index: compiler/polymorphism.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/polymorphism.m,v
retrieving revision 1.117.2.10
diff -u -r1.117.2.10 polymorphism.m
--- 1.117.2.10	1998/06/17 04:13:51
+++ polymorphism.m	1998/06/22 01:03:00
@@ -1487,7 +1487,7 @@
 
 		% create the construction unification to initialize the variable
 	BaseUnification = construct(BaseVar, ConsId, [], []),
-	BaseUnifyMode = (free -> ground(shared, no)) -
+	BaseUnifyMode = (free(unique) -> ground(shared, no)) -
 			(ground(shared, no) -> ground(shared, no)),
 	BaseUnifyContext = unify_context(explicit, []),
 		% XXX the UnifyContext is wrong
@@ -1515,13 +1515,13 @@
 
 		% create the construction unification to initialize the
 		% variable
-	UniMode = (free - ground(shared, no) ->
+	UniMode = (free(unique) - ground(shared, no) ->
 		   ground(shared, no) - ground(shared, no)),
 	list__length(NewArgVars, NumArgVars),
 	list__duplicate(NumArgVars, UniMode, UniModes),
 	Unification = construct(NewVar, NewConsId, NewArgVars,
 		UniModes),
-	UnifyMode = (free -> ground(shared, no)) -
+	UnifyMode = (free(unique) -> ground(shared, no)) -
 			(ground(shared, no) -> ground(shared, no)),
 	UnifyContext = unify_context(explicit, []),
 		% XXX the UnifyContext is wrong
@@ -1860,7 +1860,8 @@
 
 	CountTerm = functor(CountConsId, []),
 	CountInst = bound(unique, [functor(int_const(Num), [])]),
-	CountUnifyMode = (free -> CountInst) - (CountInst -> CountInst),
+	CountUnifyMode = (free(unique) -> CountInst) -
+			(CountInst -> CountInst),
 	CountUnifyContext = unify_context(explicit, []),
 		% XXX the UnifyContext is wrong
 	CountUnify = unify(CountVar, CountTerm, CountUnifyMode,
@@ -1933,7 +1934,7 @@
 	Term = functor(cons(PredName2, 0), []),
 
 	Inst = bound(unique, [functor(cons(PredName2, 0), [])]),
-	UnifyMode = (free -> Inst) - (Inst -> Inst),
+	UnifyMode = (free(unique) -> Inst) - (Inst -> Inst),
 	UnifyContext = unify_context(explicit, []),
 		% XXX the UnifyContext is wrong
 	Unify = unify(Var, Term, UnifyMode, Unification, UnifyContext),
@@ -2042,12 +2043,12 @@
 		TypeInfoVar, VarSet, VarTypes),
 
 	% create the construction unification to initialize the variable
-	UniMode = (free - ground(shared, no) ->
+	UniMode = (free(unique) - ground(shared, no) ->
 		   ground(shared, no) - ground(shared, no)),
 	list__length(ArgVars, NumArgVars),
 	list__duplicate(NumArgVars, UniMode, UniModes),
 	Unification = construct(TypeInfoVar, ConsId, ArgVars, UniModes),
-	UnifyMode = (free -> ground(shared, no)) -
+	UnifyMode = (free(unique) -> ground(shared, no)) -
 			(ground(shared, no) -> ground(shared, no)),
 	UnifyContext = unify_context(explicit, []),
 		% XXX the UnifyContext is wrong
@@ -2100,7 +2101,7 @@
 
 	% create the construction unification to initialize the variable
 	Unification = construct(BaseTypeInfoVar, ConsId, [], []),
-	UnifyMode = (free -> ground(shared, no)) -
+	UnifyMode = (free(unique) -> ground(shared, no)) -
 			(ground(shared, no) -> ground(shared, no)),
 	UnifyContext = unify_context(explicit, []),
 		% XXX the UnifyContext is wrong
Index: compiler/prog_io_util.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/prog_io_util.m,v
retrieving revision 1.5.4.7
diff -u -r1.5.4.7 prog_io_util.m
--- 1.5.4.7	1998/06/05 08:47:28
+++ prog_io_util.m	1998/06/22 01:03:01
@@ -175,7 +175,7 @@
 	Term = term__functor(Name, Args0, _Context),
 	% `free' insts
 	( Name = term__atom("free"), Args0 = [] ->
-		Result = free
+		Result = free(unique)
 
 	% `any' insts
 	; Name = term__atom("any"), Args0 = [] ->
Index: compiler/prog_util.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/prog_util.m,v
retrieving revision 1.35.4.5
diff -u -r1.35.4.5 prog_util.m
--- 1.35.4.5	1998/06/17 04:13:58
+++ prog_util.m	1998/06/22 01:03:01
@@ -176,7 +176,7 @@
 :- pred split_type_and_mode(type_and_mode, bool, type, mode, bool).
 :- mode split_type_and_mode(in, in, out, out, out) is det.
 
-split_type_and_mode(type_only(T), _, T, (free -> free), no).
+split_type_and_mode(type_only(T), _, T, (free(unique) -> free(unique)), no).
 split_type_and_mode(type_and_mode(T,M), R, T, M, R).
 
 split_type_and_mode(type_only(T), T, no).
Index: compiler/simplify.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/simplify.m,v
retrieving revision 1.46.2.12
diff -u -r1.46.2.12 simplify.m
--- 1.46.2.12	1998/06/17 04:14:05
+++ simplify.m	1998/06/22 01:03:01
@@ -38,8 +38,8 @@
 :- mode simplify__proc(in, in, in, in, out, in, out, out, out, di, uo) is det.
 
 :- pred simplify__process_goal(hlds_goal, hlds_goal,
-		simplify_info, simplify_info).
-:- mode simplify__process_goal(in, out, in, out) is det.
+		simplify_info, simplify_info, io__state, io__state).
+:- mode simplify__process_goal(in, out, in, out, di, uo) is det.
 	
 	% Find out which simplifications should be run from the options table
 	% stored in the globals. The first argument states whether warnings
@@ -70,6 +70,7 @@
 :- import_module hlds_module, hlds_data, (inst), inst_match.
 :- import_module options, passes_aux, prog_data, mode_util, type_util.
 :- import_module code_util, quantification, modes, purity, pd_cost.
+:- import_module unify_proc, mode_info.
 :- import_module set, require, std_util, int.
 
 %-----------------------------------------------------------------------------%
@@ -109,13 +110,13 @@
 	simplify_info_init(DetInfo0, Simplifications, InstMap0,
 		VarSet0, VarTypes0, Info0),
 	proc_info_goal(ProcInfo0, Goal0),
-	simplify__process_goal(Goal0, Goal, Info0, Info),
+	simplify__process_goal(Goal0, Goal, Info0, Info, State1, State2),
 
 	simplify_info_get_module_info(Info, ModuleInfo),
 	simplify_info_get_msgs(Info, Msgs0),
 	set__to_sorted_list(Msgs0, Msgs),
 	det_report_msgs(Msgs, ModuleInfo, WarnCnt,
-			ErrCnt, State1, State),
+			ErrCnt, State2, State),
 	simplify_info_get_varset(Info, VarSet),
 	simplify_info_get_var_types(Info, VarTypes),
 	simplify_info_get_inst_table(Info, InstTable),
@@ -124,7 +125,7 @@
 	proc_info_set_goal(ProcInfo2, Goal, ProcInfo3),
 	proc_info_set_inst_table(ProcInfo3, InstTable, ProcInfo).
 
-simplify__process_goal(Goal0, Goal, Info0, Info) :-
+simplify__process_goal(Goal0, Goal, Info0, Info, IOState0, IOState) :-
 	simplify_info_get_simplifications(Info0, Simplifications0),
 	simplify_info_get_instmap(Info0, InstMap0),
 
@@ -137,7 +138,8 @@
 		simplify_info_set_simplifications(Info0, Simplifications1,
 			Info1),
 		
-		simplify__do_process_goal(Goal0, Goal1, Info1, Info2),
+		simplify__do_process_goal(Goal0, Goal1, Info1, Info2,
+			IOState0, IOState1),
 
 		NotOnSecondPass = [warn_simple_code, warn_duplicate_calls,
 			common_struct, duplicate_calls],
@@ -146,16 +148,18 @@
 		simplify_info_reinit(Simplifications2, InstMap0, Info2, Info3)
 	;
 		Info3 = Info0,
-		Goal1 = Goal0
+		Goal1 = Goal0,
+		IOState1 = IOState0
 	),
 		% On the second pass do excess assignment elimination and
 		% some cleaning up after the common structure pass.
-	simplify__do_process_goal(Goal1, Goal, Info3, Info).
+	simplify__do_process_goal(Goal1, Goal, Info3, Info, IOState1, IOState).
 
 :- pred simplify__do_process_goal(hlds_goal::in, hlds_goal::out,
-		simplify_info::in, simplify_info::out) is det.
+		simplify_info::in, simplify_info::out, io__state::di,
+		io__state::uo) is det.
 
-simplify__do_process_goal(Goal0, Goal, Info0, Info) :-
+simplify__do_process_goal(Goal0, Goal, Info0, Info, IOState0, IOState) :-
 	simplify_info_get_instmap(Info0, InstMap0),
 	simplify__goal(Goal0, Goal1, Info0, Info1),
 	simplify_info_get_varset(Info1, VarSet0),
@@ -178,12 +182,16 @@
 		proc_info_arglives(ProcInfo, ModuleInfo1, ArgLives),
 		recompute_instmap_delta(ArgVars, ArgLives, VarTypes, Goal2,
 			Goal, InstMap0, InstTable0, InstTable, _, ModuleInfo1,
-			ModuleInfo),
+			ModuleInfo2),
+		modecheck_queued_procs(check_unique_modes(
+			may_change_called_proc), ModuleInfo2, ModuleInfo,
+			_Changed, IOState0, IOState),
 		simplify_info_set_module_info(Info3, ModuleInfo, Info4),
 		simplify_info_set_inst_table(Info4, InstTable, Info)
 	;
 		Goal = Goal1,
-		Info = Info1
+		Info = Info1,
+		IOState = IOState0
 	).
 
 %-----------------------------------------------------------------------------%
@@ -1029,7 +1037,7 @@
 		RevGoals0, RevGoals, GoalNeeded, Info0, Info) :-
 	(
 		simplify_do_excess_assigns(Info0),
-		Goal0 = unify(_, _, _, Unif, _) - _,
+		Goal0 = unify(_, _, LMode - RMode, Unif, _) - _,
 		goal_info_get_nonlocals(ConjInfo, NonLocals),
 		Unif = assign(LeftVar, RightVar),
 		( \+ set__member(LeftVar, NonLocals) ->
@@ -1038,7 +1046,16 @@
 			LocalVar = RightVar, ReplacementVar = LeftVar
 		;
 			fail
-		)
+		),
+
+		% If one of the variables is free(alias) before the call
+		% then we can't remove the assignment.
+		simplify_info_get_module_info(Info0, ModuleInfo),
+		simplify_info_get_inst_table(Info0, InstTable),
+		mode_get_insts(ModuleInfo, LMode, LInitInst, _LFinInst),
+		\+ inst_is_free_alias(LInitInst, InstTable, ModuleInfo),
+		mode_get_insts(ModuleInfo, RMode, RInitInst, _RFinInst),
+		\+ inst_is_free_alias(RInitInst, InstTable, ModuleInfo)
 	->
 		GoalNeeded = no,
 		map__init(Subn0),
@@ -1137,7 +1154,8 @@
 	),
 	InstToUniMode =
 		lambda([ArgInst::in, ArgUniMode::out] is det, (
-			ArgUniMode = ((ArgInst - free) -> (ArgInst - ArgInst))
+			ArgUniMode = ((ArgInst - free(unique)) -> 
+				(ArgInst - ArgInst))
 		)),
 	list__map(InstToUniMode, ArgInsts, UniModes),
 	UniMode = (Inst0 -> Inst0) - (Inst0 -> Inst0),
Index: compiler/store_alloc.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/store_alloc.m,v
retrieving revision 1.55.2.7
diff -u -r1.55.2.7 store_alloc.m
--- 1.55.2.7	1998/06/17 04:14:07
+++ store_alloc.m	1998/06/22 01:03:02
@@ -36,8 +36,8 @@
 
 :- implementation.
 
-:- import_module follow_vars, liveness, hlds_goal, llds.
-:- import_module options, globals, goal_util, mode_util, instmap, trace.
+:- import_module follow_vars, liveness, hlds_goal, hlds_data, llds, trace.
+:- import_module options, globals, goal_util, mode_util, instmap, inst_match.
 :- import_module list, map, set, std_util, assoc_list.
 :- import_module bool, int, require, term.
 
@@ -54,9 +54,9 @@
 store_alloc_in_proc(ProcInfo0, PredId, ModuleInfo, ProcInfo) :-
 	module_info_globals(ModuleInfo, Globals),
 	globals__lookup_bool_option(Globals, follow_vars, ApplyFollowVars),
+	proc_info_inst_table(ProcInfo0, InstTable),
 	( ApplyFollowVars = yes ->
 		proc_info_goal(ProcInfo0, Goal0),
-		proc_info_inst_table(ProcInfo0, InstTable),
 
 		find_final_follow_vars(ProcInfo0, FollowVars0),
 		find_follow_vars_in_goal(Goal0, InstTable, ModuleInfo,
@@ -68,7 +68,7 @@
 	;
 		proc_info_goal(ProcInfo0, Goal2)
 	),
-	initial_liveness(ProcInfo0, PredId, ModuleInfo, Liveness0),
+	initial_liveness(ProcInfo0, PredId, ModuleInfo, Liveness0, _Refs),
 	globals__get_trace_level(Globals, TraceLevel),
 	( ( TraceLevel = interface ; TraceLevel = full ) ->
 		trace__fail_vars(ModuleInfo, ProcInfo0, ResumeVars0)
@@ -109,13 +109,14 @@
 	% Any variables that become magically live at the end of the goal
 	% should not be included in the store map.
 	set__union(Liveness4, PostBirths, Liveness),
+	goal_info_get_refs(GoalInfo0, Refs),
 	(
 		Goal1 = switch(Var, CanFail, Cases, FollowVars)
 	->
 		set__union(Liveness4, ResumeVars0, MappedSet),
 		set__to_sorted_list(MappedSet, MappedVars),
-		store_alloc_allocate_storage(MappedVars, FollowVars,
-			StackSlotInfo, StoreMap),
+		store_alloc_allocate_storage(MappedVars, FollowVars, 
+			StackSlotInfo, Refs, StoreMap),
 		Goal = switch(Var, CanFail, Cases, StoreMap)
 	;
 		Goal1 = if_then_else(Vars, Cond, Then, Else, FollowVars)
@@ -123,7 +124,7 @@
 		set__union(Liveness4, ResumeVars0, MappedSet),
 		set__to_sorted_list(MappedSet, MappedVars),
 		store_alloc_allocate_storage(MappedVars, FollowVars,
-			StackSlotInfo, StoreMap),
+			StackSlotInfo, Refs, StoreMap),
 		Goal = if_then_else(Vars, Cond, Then, Else, StoreMap)
 	;
 		Goal1 = disj(Disjuncts, FollowVars)
@@ -131,7 +132,7 @@
 		set__union(Liveness4, ResumeVars0, MappedSet),
 		set__to_sorted_list(MappedSet, MappedVars),
 		store_alloc_allocate_storage(MappedVars, FollowVars,
-			StackSlotInfo, StoreMap),
+			StackSlotInfo, Refs, StoreMap),
 		Goal = disj(Disjuncts, StoreMap)
 	;
 		Goal = Goal1
@@ -301,10 +302,11 @@
 	% real location.
 
 :- pred store_alloc_allocate_storage(list(var), follow_vars, stack_slot_info,
-	store_map).
-:- mode store_alloc_allocate_storage(in, in, in, out) is det.
+		set(var), store_map).
+:- mode store_alloc_allocate_storage(in, in, in, in, out) is det.
 
-store_alloc_allocate_storage(LiveVars, FollowVars, StackSlotInfo, StoreMap) :-
+store_alloc_allocate_storage(LiveVars, FollowVars, StackSlotInfo, Refs,
+		StoreMap) :-
 
 	% This addresses point 1
 	map__keys(FollowVars, FollowKeys),
@@ -317,8 +319,8 @@
 		SeenLvals0, SeenLvals, StoreMap0, StoreMap1),
 
 	% This addresses point 2
-	store_alloc_allocate_extras(LiveVars, N, SeenLvals, StackSlotInfo,
-		StoreMap1, StoreMap).
+	store_alloc_allocate_extras(LiveVars, N, SeenLvals, Refs, 
+		StackSlotInfo, StoreMap1, StoreMap).
 
 :- pred store_alloc_remove_nonlive(list(var), list(var), store_map, store_map).
 :- mode store_alloc_remove_nonlive(in, in, in, out) is det.
@@ -341,7 +343,7 @@
 		StoreMap, StoreMap).
 store_alloc_handle_conflicts_and_nonreal([Var | Vars], N0, N,
 		SeenLvals0, SeenLvals, StoreMap0, StoreMap) :-
-	map__lookup(StoreMap0, Var, Lval),
+	map__lookup(StoreMap0, Var, store_info(ValOrRef, Lval)),
 	(
 		( artificial_lval(Lval)
 		; set__member(Lval, SeenLvals0)
@@ -349,7 +351,8 @@
 	->
 		next_free_reg(N0, SeenLvals0, N1),
 		FinalLval = reg(r, N1),
-		map__det_update(StoreMap0, Var, FinalLval, StoreMap1)
+		map__det_update(StoreMap0, Var, 
+			store_info(ValOrRef, FinalLval), StoreMap1)
 	;
 		N1 = N0,
 		FinalLval = Lval,
@@ -359,12 +362,13 @@
 	store_alloc_handle_conflicts_and_nonreal(Vars, N1, N,
 		SeenLvals1, SeenLvals, StoreMap1, StoreMap).
 
-:- pred store_alloc_allocate_extras(list(var), int, set(lval), stack_slot_info,
-	store_map, store_map).
-:- mode store_alloc_allocate_extras(in, in, in, in, in, out) is det.
+:- pred store_alloc_allocate_extras(list(var), int, set(lval), set(var),
+	stack_slot_info, store_map, store_map).
+:- mode store_alloc_allocate_extras(in, in, in, in, in, in, out) is det.
 
-store_alloc_allocate_extras([], _, _, _, StoreMap, StoreMap).
-store_alloc_allocate_extras([Var | Vars], N0, SeenLvals0, StackSlotInfo,
+store_alloc_allocate_extras([], _N, _SeenLvals, _Refs, _StackSlotInfo,
+		StoreMap, StoreMap).
+store_alloc_allocate_extras([Var | Vars], N0, SeenLvals0, Refs, StackSlotInfo,
 		StoreMap0, StoreMap) :-
 	(
 		map__contains(StoreMap0, Var)
@@ -402,10 +406,18 @@
 			next_free_reg(N0, SeenLvals0, N1),
 			Locn = reg(r, N1)
 		),
-		map__det_insert(StoreMap0, Var, Locn, StoreMap1),
+		(
+			set__member(Var, Refs)
+		->
+			ValOrRef = ref
+		;
+			ValOrRef = val
+		),
+		map__det_insert(StoreMap0, Var, store_info(ValOrRef, Locn),
+			StoreMap1),
 		set__insert(SeenLvals0, Locn, SeenLvals1)
 	),
-	store_alloc_allocate_extras(Vars, N1, SeenLvals1, StackSlotInfo,
+	store_alloc_allocate_extras(Vars, N1, SeenLvals1, Refs, StackSlotInfo,
 		StoreMap1, StoreMap).
 
 %-----------------------------------------------------------------------------%
Index: compiler/stratify.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/stratify.m,v
retrieving revision 1.10.2.8
diff -u -r1.10.2.8 stratify.m
--- 1.10.2.8	1998/06/17 04:14:09
+++ stratify.m	1998/06/22 01:03:02
@@ -770,7 +770,7 @@
 		% always to case, but should be a suitable approximation for
 		% the stratification analysis
 		RHS = lambda_goal(_PredOrFunc, _NonLocals, _Vars, _Modes,
-				_Determinism, _IMelta, Goal - _GoalInfo)
+				_Determinism, _IMDelta, Goal - _GoalInfo)
 	->
 		get_called_procs(Goal, [], CalledProcs),
 		set__insert_list(HasAT0, CalledProcs, HasAT)
Index: compiler/table_gen.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/table_gen.m,v
retrieving revision 1.1.6.1
diff -u -r1.1.6.1 table_gen.m
--- 1.1.6.1	1998/06/09 04:28:33
+++ table_gen.m	1998/06/22 01:03:02
@@ -654,7 +654,7 @@
 	),
 	
 	TableVarInst = ground(unique, no), 
-	TableVarMode = (free -> TableVarInst), 
+	TableVarMode = (free(unique) -> TableVarInst), 
 	get_table_var_type(TableVarType),
 	
 	inst_table_init(InstTable),
@@ -1201,7 +1201,7 @@
 
 	Inst = bound(unique, [functor(int_const(VarValue), [])]),
 	VarUnify = unify(Var, functor(int_const(VarValue), []),
-		(free -> Inst) - (Inst -> Inst), 
+		(free(unique) -> Inst) - (Inst -> Inst), 
 		construct(Var, int_const(VarValue), [], []),
 		unify_context(explicit, [])),
 	set__singleton_set(VarNonLocals, Var),
@@ -1225,7 +1225,7 @@
 
 	Inst = bound(unique, [functor(string_const(VarValue), [])]),
 	VarUnify = unify(Var, functor(string_const(VarValue), []),
-		(free -> Inst) - (Inst -> Inst), 
+		(free(unique) -> Inst) - (Inst -> Inst), 
 		construct(Var, string_const(VarValue), [], []),
 		unify_context(explicit, [])),
 	set__singleton_set(VarNonLocals, Var),
Index: compiler/unify_gen.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/unify_gen.m,v
retrieving revision 1.83.2.5
diff -u -r1.83.2.5 unify_gen.m
--- 1.83.2.5	1998/03/26 00:45:22
+++ unify_gen.m	1998/06/22 01:03:03
@@ -33,9 +33,10 @@
 :- mode unify_gen__generate_assignment(in, in, out, in, out) is det.
 
 	% Generate a construction unification
-:- pred unify_gen__generate_construction(var, cons_id,
-	list(var), list(uni_mode), code_tree, code_info, code_info).
-:- mode unify_gen__generate_construction(in, in, in, in, out, in, out) is det.
+:- pred unify_gen__generate_construction(var, cons_id, list(var),
+	list(uni_mode), code_tree, code_info, code_info).
+:- mode unify_gen__generate_construction(in, in, in, in, out, in, out)
+	is det.
 
 :- pred unify_gen__generate_det_deconstruction(var, cons_id,
 	list(var), list(uni_mode), code_tree, code_info, code_info).
@@ -75,16 +76,22 @@
 	% bound variable as the expression that generates the free
 	% variable. No immediate code is generated.
 
-unify_gen__generate_assignment(VarA, VarB, empty) -->
-	(
-		code_info__variable_is_forward_live(VarA)
-	->
-		code_info__cache_expression(VarA, var(VarB))
-	;
-		% For free-free unifications, the mode analysis reports
-		% them as assignment to the dead variable.  For such
-		% unifications we of course don't generate any code
-		{ true }
+unify_gen__generate_assignment(VarA, VarB, Code) -->
+	( code_info__var_is_free_alias(VarA) ->
+		code_info__cache_expression(VarA, var(VarB)),
+		code_info__produce_variable_in_references(VarA, Code)
+	;
+		(
+			code_info__variable_is_forward_live(VarA)
+		->
+			code_info__cache_expression(VarA, var(VarB))
+		;
+			% For free-free unifications, the mode analysis reports
+			% them as assignment to the dead variable.  For such
+			% unifications we of course don't generate any code
+			{ true }
+		),
+		{ Code = empty }
 	).
 
 %---------------------------------------------------------------------------%
@@ -232,25 +239,21 @@
 	code_info__cons_id_to_tag(Var, Cons, Tag),
 	unify_gen__generate_construction_2(Tag, Var, Args, Modes, Code).
 
-:- pred unify_gen__generate_construction_2(cons_tag, var, 
-					list(var), list(uni_mode),
-					code_tree, code_info, code_info).
-:- mode unify_gen__generate_construction_2(in, in, in, in, out,
-					in, out) is det.
+:- pred unify_gen__generate_construction_2(cons_tag, var, list(var),
+	list(uni_mode), code_tree, code_info, code_info).
+:- mode unify_gen__generate_construction_2(in, in, in, in, out, in, out) is det.
 
 unify_gen__generate_construction_2(string_constant(String),
 		Var, _Args, _Modes, Code) -->
-	{ Code = empty },
-	code_info__cache_expression(Var, const(string_const(String))).
+	unify_gen__cache_unification(Var, const(string_const(String)), Code).
 unify_gen__generate_construction_2(int_constant(Int),
 		Var, _Args, _Modes, Code) -->
-	{ Code = empty },
-	code_info__cache_expression(Var, const(int_const(Int))).
+	unify_gen__cache_unification(Var, const(int_const(Int)), Code).
 unify_gen__generate_construction_2(float_constant(Float),
 		Var, _Args, _Modes, Code) -->
-	{ Code = empty },
-	code_info__cache_expression(Var, const(float_const(Float))).
-unify_gen__generate_construction_2(no_tag, Var, Args, Modes, Code) -->
+	unify_gen__cache_unification(Var, const(float_const(Float)), Code).
+unify_gen__generate_construction_2(no_tag,
+		Var, Args, Modes, Code) -->
 	( { Args = [Arg], Modes = [Mode] } ->
 		code_info__variable_type(Arg, Type),
 		unify_gen__generate_sub_unify(ref(Var), ref(Arg),
@@ -267,13 +270,16 @@
 	unify_gen__var_types(Args, ArgTypes),
 	{ unify_gen__generate_cons_args(Args, ArgTypes, Modes, InstTable,
 		ModuleInfo, RVals) },
-	{ Code = empty },
 	code_info__variable_type(Var, VarType),
 	{ unify_gen__var_type_msg(VarType, VarTypeMsg) },
 	% XXX Later we will need to worry about
 	% whether the cell must be unique or not.
 	{ Expr = create(SimpleTag, RVals, no, CellNo, VarTypeMsg) },
-	code_info__cache_expression(Var, Expr).
+	code_info__cache_expression(Var, Expr),
+	unify_gen__aliased_vars_set_location(Args, ArgTypes, Modes, InstTable,
+		ModuleInfo, Var, SimpleTag, 0, Code0),
+	unify_gen__maybe_place_refs(Var, Code1),
+	{ Code = tree(Code0, Code1) }.
 unify_gen__generate_construction_2(complicated_tag(Bits0, Num0),
 		Var, Args, Modes, Code) -->
 	code_info__get_module_info(ModuleInfo),
@@ -284,18 +290,20 @@
 		ModuleInfo, RVals0) },
 		% the first field holds the secondary tag
 	{ RVals = [yes(const(int_const(Num0))) | RVals0] },
-	{ Code = empty },
 	code_info__variable_type(Var, VarType),
 	{ unify_gen__var_type_msg(VarType, VarTypeMsg) },
 	% XXX Later we will need to worry about
 	% whether the cell must be unique or not.
 	{ Expr = create(Bits0, RVals, no, CellNo, VarTypeMsg) },
-	code_info__cache_expression(Var, Expr).
+	code_info__cache_expression(Var, Expr),
+	unify_gen__aliased_vars_set_location(Args, ArgTypes, Modes, InstTable,
+		ModuleInfo, Var, Bits0, 1, Code0),
+	unify_gen__maybe_place_refs(Var, Code1),
+	{ Code = tree(Code0, Code1) }.
 unify_gen__generate_construction_2(complicated_constant_tag(Bits1, Num1),
 		Var, _Args, _Modes, Code) -->
-	{ Code = empty },
-	code_info__cache_expression(Var,
-		mkword(Bits1, unop(mkbody, const(int_const(Num1))))).
+	unify_gen__cache_unification(Var,
+		mkword(Bits1, unop(mkbody, const(int_const(Num1)))), Code).
 unify_gen__generate_construction_2(base_type_info_constant(ModuleName,
 		TypeName, TypeArity), Var, Args, _Modes, Code) -->
 	( { Args = [] } ->
@@ -303,9 +311,8 @@
 	;
 		{ error("unify_gen: type-info constant has args") }
 	),
-	{ Code = empty },
-	code_info__cache_expression(Var, const(data_addr_const(data_addr(
-		ModuleName, base_type(info, TypeName, TypeArity))))).
+	unify_gen__cache_unification(Var, const(data_addr_const(data_addr(
+		ModuleName, base_type(info, TypeName, TypeArity)))), Code).
 unify_gen__generate_construction_2(base_typeclass_info_constant(ModuleName,
 		ClassId, Instance), Var, Args, _Modes, Code) -->
 	( { Args = [] } ->
@@ -313,9 +320,8 @@
 	;
 		{ error("unify_gen: typeclass-info constant has args") }
 	),
-	{ Code = empty },
-	code_info__cache_expression(Var, const(data_addr_const(data_addr(
-		ModuleName, base_typeclass_info(ClassId, Instance))))).
+	unify_gen__cache_unification(Var, const(data_addr_const(data_addr(
+		ModuleName, base_typeclass_info(ClassId, Instance)))), Code).
 unify_gen__generate_construction_2(code_addr_constant(PredId, ProcId),
 		Var, Args, _Modes, Code) -->
 	( { Args = [] } ->
@@ -323,12 +329,12 @@
 	;
 		{ error("unify_gen: address constant has args") }
 	),
-	{ Code = empty },
 	code_info__get_module_info(ModuleInfo),
 	code_info__make_entry_label(ModuleInfo, PredId, ProcId, no, CodeAddr),
-	code_info__cache_expression(Var, const(code_addr_const(CodeAddr))).
+	unify_gen__cache_unification(Var, const(code_addr_const(CodeAddr)),
+		Code).
 unify_gen__generate_construction_2(pred_closure_tag(PredId, ProcId),
-		Var, Args, _Modes, Code) -->
+		Var, Args, Modes, Code) -->
 	code_info__get_module_info(ModuleInfo),
 	{ module_info_preds(ModuleInfo, Preds) },
 	{ map__lookup(Preds, PredId, PredInfo) },
@@ -382,7 +388,7 @@
 	    ( { CallArgs = [] } ->
 		% if there are no new arguments, we can just use the old
 		% closure
-		code_info__produce_variable(CallPred, Code, Value)
+		code_info__produce_variable(CallPred, Code98, Value)
 	    ;
 		code_info__get_next_label(LoopEnd),
 		code_info__get_next_label(LoopStart),
@@ -430,11 +436,13 @@
 		code_info__release_reg(LoopCounter),
 		code_info__release_reg(NumOldArgs),
 		code_info__release_reg(NewClosure),
-		{ Code = tree(Code1, tree(Code2, Code3)) },
+		{ Code98 = tree(Code1, tree(Code2, Code3)) },
 		{ Value = lval(NewClosure) }
-	    )
+	    ),
+	    { list__length(ProcArgs, NumExtraProcArgs) },
+	    { SkipFirstArg = yes }
 	;
-		{ Code = empty },
+		{ Code98 = empty },
 		{ proc_info_arg_info(ProcInfo, ArgInfo) },
 		code_info__make_entry_label(ModuleInfo, PredId, ProcId, no,
 				CodeAddress),
@@ -443,9 +451,55 @@
 		{ unify_gen__generate_pred_args(Args, ArgInfo, PredArgs) },
 		{ Vector = [yes(const(int_const(NumArgs))),
 			yes(const(code_addr_const(CodeAddress))) | PredArgs] },
-		{ Value = create(0, Vector, no, CellNo, "closure") }
+		{ Value = create(0, Vector, no, CellNo, "closure") },
+		{ NumExtraProcArgs = 0 },
+		{ SkipFirstArg = no }
+	),
+	unify_gen__cache_unification(Var, Value, Code99),
+	code_info__get_inst_table(InstTable),
+	{ FirstField is NumExtraProcArgs + 2 },
+	( 
+		{ SkipFirstArg = yes },
+		(
+			{ Args = [_ | ArgsPrime] },
+			{ Modes = [_ | ModesPrime] }
+		->
+			unify_gen__var_types(ArgsPrime, ArgTypes),
+			unify_gen__aliased_vars_set_location(ArgsPrime,
+				ArgTypes, ModesPrime, InstTable, ModuleInfo,
+				Var, 0, FirstField, Code100)
+		;
+			{ Code100 = empty }
+		)
+	;
+		{ SkipFirstArg = no },
+		unify_gen__var_types(Args, ArgTypes),
+		unify_gen__aliased_vars_set_location(Args,
+			ArgTypes, Modes, InstTable, ModuleInfo, Var, 0,
+			FirstField, Code100)
 	),
-	code_info__cache_expression(Var, Value).
+	{ Code = tree(Code98, tree(Code99, Code100)) }.
+
+% Cache a unification.  If the mode of the LHS variable is ref_in then
+% produce code to place it's value in the required locations.
+
+:- pred unify_gen__cache_unification(var, rval, code_tree,
+	code_info, code_info).
+:- mode unify_gen__cache_unification(in, in, out, in, out) is det.
+
+unify_gen__cache_unification(Var, Rval, Code) -->
+	code_info__cache_expression(Var, Rval),
+	unify_gen__maybe_place_refs(Var, Code).
+
+:- pred unify_gen__maybe_place_refs(var, code_tree, code_info, code_info).
+:- mode unify_gen__maybe_place_refs(in, out, in, out) is det.
+
+unify_gen__maybe_place_refs(Var, Code) -->
+	( code_info__var_is_free_alias(Var) ->
+		code_info__produce_variable_in_references(Var, Code)
+	;
+		{ Code = empty }
+	).
 
 :- pred unify_gen__generate_extra_closure_args(list(var), lval, lval,
 					code_tree, code_info, code_info).
@@ -514,7 +568,8 @@
 unify_gen__generate_cons_args_2([Var|Vars], [Type|Types], [UniMode|UniModes],
 			InstTable, ModuleInfo, [Arg|RVals]) :-
 	UniMode = ((_LI - RI) -> (_LF - RF)),
-	( mode_to_arg_mode(InstTable, ModuleInfo, (RI -> RF), Type, top_in) ->
+	mode_to_arg_mode(InstTable, ModuleInfo, (RI -> RF), Type, ArgMode),
+	( ArgMode = top_in ->
 		Arg = yes(var(Var))
 	;
 		Arg = no
@@ -522,6 +577,53 @@
 	unify_gen__generate_cons_args_2(Vars, Types, UniModes, InstTable,
 		ModuleInfo, RVals).
 
+:- pred unify_gen__aliased_vars_set_location(list(var), list(type),
+		list(uni_mode), inst_table, module_info, var, tag, int,
+		code_tree, code_info, code_info).
+:- mode unify_gen__aliased_vars_set_location(in, in, in, in, in, in, in, in,
+		out, in, out) is det.
+
+unify_gen__aliased_vars_set_location(Args, Types, Modes, InstTable, ModuleInfo,
+		Var, Tag, FieldNum, Code) -->
+	( 
+		unify_gen__aliased_vars_set_location_2(Args, Types, Modes,
+			InstTable, ModuleInfo, Var, Tag, FieldNum, Code0)
+	->
+		{ Code = Code0 }
+	;
+		{ error("unify_gen__aliased_vars_set_location: length mismatch") }
+	).
+
+:- pred unify_gen__aliased_vars_set_location_2(list(var), list(type),
+		list(uni_mode), inst_table, module_info, var, tag,
+		int, code_tree, code_info, code_info).
+:- mode unify_gen__aliased_vars_set_location_2(in, in, in, in, in, in, in, in,
+		out, in, out) is semidet.
+
+unify_gen__aliased_vars_set_location_2([], [], [], _, _, _, _, _, empty) --> [].
+unify_gen__aliased_vars_set_location_2([Var | Vars], [Type | Types],
+		[Mode | Modes], InstTable, ModuleInfo, LHSVar, Tag, FieldNum,
+		Code) -->
+	{ Mode = ((_LI - RI) -> (_LF - RF)) },
+	( 
+		{ mode_to_arg_mode(InstTable, ModuleInfo, (RI -> RF), Type,
+			ref_out) }
+	->
+		code_info__acquire_reg_for_var(Var, Reg),
+		code_info__set_var_reference_location(Var, Reg),
+		code_info__produce_variable(LHSVar, Code0, RVal),
+		{ Code1 = node(
+			[assign(Reg, mem_addr(heap_ref(RVal, Tag, FieldNum))) -
+				"place reference in reg"]) },
+		{ Code2 = tree(Code0, Code1) }
+	;
+		{ Code2 = empty }
+	),
+	{ NextFieldNum is FieldNum + 1 },
+	unify_gen__aliased_vars_set_location_2(Vars, Types, Modes, InstTable,
+		ModuleInfo, LHSVar, Tag, NextFieldNum, Code3),
+	{ Code = tree(Code2, Code3) }.
+
 %---------------------------------------------------------------------------%
 
 :- pred unify_gen__var_types(list(var), list(type), code_info, code_info).
@@ -686,12 +788,12 @@
 	;
 			% Input - Output== assignment ->
 		{ LeftMode = top_in },
-		{ RightMode = top_out }
+		{ RightMode = top_out ; RightMode = ref_in }
 	->
 		unify_gen__generate_sub_assign(R, L, Code)
 	;
 			% Input - Output== assignment <-
-		{ LeftMode = top_out },
+		{ LeftMode = top_out ; LeftMode = ref_in },
 		{ RightMode = top_in }
 	->
 		unify_gen__generate_sub_assign(L, R, Code)
@@ -702,6 +804,11 @@
 		{ Code = empty } % free-free - ignore
 			% XXX I think this will have to change
 			% if we start to support aliasing
+	;	
+		{ LeftMode = ref_out },
+		{ RightMode = ref_out }
+	->
+		{ Code = empty }
 	;
 		{ error("unify_gen__generate_sub_unify: some strange unify") }
 	).
@@ -747,22 +854,24 @@
 		{ error("unify_gen__generate_sub_assign: lval vanished with ref") }
 	).
 	% assignment to a variable, so cache it.
-unify_gen__generate_sub_assign(ref(Var), lval(Rval), empty) -->
+unify_gen__generate_sub_assign(ref(Var), lval(Rval), Code) -->
 	(
 		code_info__variable_is_forward_live(Var)
 	->
-		code_info__cache_expression(Var, lval(Rval))
+		code_info__cache_expression(Var, lval(Rval)),
+		code_info__produce_variable_in_references(Var, Code)
 	;
-		{ true }
+		{ Code = empty }
 	).
 	% assignment to a variable, so cache it.
-unify_gen__generate_sub_assign(ref(Lvar), ref(Rvar), empty) -->
+unify_gen__generate_sub_assign(ref(Lvar), ref(Rvar), Code) -->
 	(
 		code_info__variable_is_forward_live(Lvar)
 	->
-		code_info__cache_expression(Lvar, var(Rvar))
+		code_info__cache_expression(Lvar, var(Rvar)),
+		code_info__produce_variable_in_references(Lvar, Code)
 	;
-		{ true }
+		{ Code = empty }
 	).
 
 %---------------------------------------------------------------------------%



More information about the developers mailing list