Tidy up the code for code_info__cons_id_to_tag.

code_info.nl: Tidy up the code for code_info__cons_id_to_tag. prog_io.nl, mode_util.nl, mercury_to_mercury.nl: Add new inst `free(Type)' and new inst_names `typed_ground(Type)' and `typed_inst(Type, Inst)' so that we can propagate type information through the mode system. Do some of the work necessary to propagate type info to modes. type_util.nl: Add an extra output argument to type_to_type_id so that it can return the type's arguments; also fix a determinism error in type_to_type_id. hlds.nl: Add a comment. list.nl: Fix the determinism annotation for same_length. map.nl: Add map__apply_to_list. mode_info.nl: Add mode_info__get_types_of_vars.
2026-04-16 01:43:35 +00:00 · 1994-07-04 12:34:51 +00:00
parent 00971231f0
commit 87e7e3bafa
9 changed files with 283 additions and 32 deletions
--- a/compiler/code_info.m
+++ b/compiler/code_info.m
@@ -1041,20 +1041,12 @@ code_info__cons_id_to_tag(_Var, float_const(X), float_constant(X)) --> [].
 code_info__cons_id_to_tag(_Var, string_const(X), string_constant(X)) --> [].
 code_info__cons_id_to_tag(Var, cons(Name, Arity), Tag) -->
 		%
-		% Use the variable to determine the type
+		% Use the variable to determine the type_id
 		%
 	code_info__get_proc_info(ProcInfo),
 	{ proc_info_vartypes(ProcInfo, VarTypes) },
 	{ map__lookup(VarTypes, Var, Type) },
-		%
-		% Given the type, determine the type_id
-		%
-	{ Type = term__functor(TypeName, TypeArgs, _Context) ->
-		list__length(TypeArgs, TypeArity),
-		make_type_id(TypeName, TypeArity, TypeId)
-	;
-		error("unification with polymorphically typed variable?")
-	},
+	{ type_to_type_id(Type, TypeId, _) },
 		%
 		% Given the type_id, lookup up the constructor tag
 		% table for that type
--- a/compiler/hlds.m
+++ b/compiler/hlds.m
@@ -1242,7 +1242,8 @@ proc_info_set_body(ProcInfo0, VarSet, VarTypes, HeadVars, Goal, ProcInfo) :-
 	ProcInfo0 = procedure(DeclaredDet, _, _, _, ArgModes, _, Context,
 		CallInfo, InferredDet, ArgInfo, Liveness, Follow),
 	ProcInfo = procedure(DeclaredDet, VarSet, VarTypes, HeadVars, ArgModes,
-		Goal, Context, CallInfo, InferredDet, ArgInfo, Liveness, Follow).
+		Goal, Context, CallInfo, InferredDet, ArgInfo, Liveness,
+		Follow).

 proc_info_set_inferred_determinism(ProcInfo0, Category, ProcInfo) :-
 	ProcInfo0 = procedure(A, B, C, D, E, F, G, H, _, J, K, L),
@@ -1264,10 +1265,10 @@ proc_info_set_follow_vars(ProcInfo0, L, ProcInfo) :-
 	ProcInfo0 = procedure(A, B, C, D, E, F, G, H, I, J, K, _),
 	ProcInfo = procedure(A, B, C, D, E, F, G, H, I, J, K, L).

-
 proc_info_get_initial_instmap(ProcInfo, ModuleInfo, reachable(InstMapping)) :-
 	proc_info_headvars(ProcInfo, HeadVars),
 	proc_info_argmodes(ProcInfo, ArgModes),
+		% XXX propagate type info!
 	mode_list_get_initial_insts(ArgModes, ModuleInfo, InitialInsts),
 	map__from_corresponding_lists(HeadVars, InitialInsts, InstMapping).

--- a/compiler/mercury_to_mercury.m
+++ b/compiler/mercury_to_mercury.m
@@ -263,6 +263,18 @@ mercury_output_inst_name(ground_inst(InstName), VarSet) -->
 	io__write_string("$ground("),
 	mercury_output_inst_name(InstName, VarSet),
 	io__write_string(")").
+mercury_output_inst_name(typed_ground(Type), _VarSet) -->
+	io__write_string("$typed_ground("),
+	{ varset__init(TypeVarSet) },
+	mercury_output_term(Type, TypeVarSet),
+	io__write_string(")").
+mercury_output_inst_name(typed_inst(Type, InstName), VarSet) -->
+	io__write_string("$typed_inst("),
+	{ varset__init(TypeVarSet) },
+	mercury_output_term(Type, TypeVarSet),
+	io__write_string(", "),
+	mercury_output_inst_name(InstName, VarSet),
+	io__write_string(")").

 :- pred mercury_output_bound_insts(list(bound_inst), varset, io__state,
 		io__state).
--- a/compiler/mode_info.m
+++ b/compiler/mode_info.m
@@ -141,6 +141,9 @@
 :- pred mode_info_get_var_types(mode_info, map(var,type)).
 :- mode mode_info_get_var_types(mode_info_ui, out) is det.

+:- pred mode_info_get_types_of_vars(mode_info, list(var), list(type)).
+:- mode mode_info_get_types_of_vars(mode_info_ui, in, out) is det.
+
 :- pred mode_info_lock_vars(set(var), mode_info, mode_info).
 :- mode mode_info_lock_vars(in, mode_info_di, mode_info_uo) is det.

@@ -453,6 +456,10 @@ mode_info_get_var_types(ModeInfo, VarTypes) :-
 	map__lookup(Procs, ProcId, ProcInfo),
 	proc_info_vartypes(ProcInfo, VarTypes).

+mode_info_get_types_of_vars(ModeInfo, Vars, TypesOfVars) :-
+	mode_info_get_var_types(ModeInfo, VarTypes),
+	map__apply_to_list(Vars, VarTypes, TypesOfVars).
+
 %-----------------------------------------------------------------------------%
 %-----------------------------------------------------------------------------%

--- a/compiler/mode_util.m
+++ b/compiler/mode_util.m
@@ -86,11 +86,26 @@
 :- pred instmapping_lookup_var(instmapping, var, inst).
 :- mode instmapping_lookup_var(in, in, out) is det.

+	% Given corresponding lists of types and modes, produce a new
+	% list of modes which includes the information provided by the
+	% corresponding types.
+
+:- pred propagate_type_info_mode_list(list(type), module_info, list(mode),
+				list(mode)).
+:- mode propagate_type_info_mode_list(in, in, in, out) is det.
+
+	% Given a type and an inst, produce a new inst which includes
+	% the information provided by the type.
+
+:- pred propagate_type_info_inst(type, module_info, inst, inst).
+:- mode propagate_type_info_inst(in, in, in, out) is det.
+
 %-----------------------------------------------------------------------------%
 %-----------------------------------------------------------------------------%

 :- implementation.
 :- import_module require, map, set, term, std_util.
+:- import_module prog_util, type_util.

 mode_list_get_final_insts([], _ModuleInfo, []).
 mode_list_get_final_insts([Mode | Modes], ModuleInfo, [Inst | Insts]) :-
@@ -248,14 +263,16 @@ inst_list_is_free([Inst | Insts], ModuleInfo) :-
 	inst_is_free(ModuleInfo, Inst),
 	inst_list_is_free(Insts, ModuleInfo).

-inst_lookup(ModuleInfo, InstName, Inst) :-
-	module_info_insts(ModuleInfo, InstTable),
-	inst_lookup_2(InstName, InstTable, Inst).
+%-----------------------------------------------------------------------------%

-:- pred inst_lookup_2(inst_name, inst_table, inst).
+inst_lookup(ModuleInfo, InstName, Inst) :-
+	inst_lookup_2(InstName, ModuleInfo, Inst).
+
+:- pred inst_lookup_2(inst_name, module_info, inst).
 :- mode inst_lookup_2(in, in, out) is det.

-inst_lookup_2(unify_inst(Live, A, B), InstTable, Inst) :-
+inst_lookup_2(unify_inst(Live, A, B), ModuleInfo, Inst) :-
+	module_info_insts(ModuleInfo, InstTable),
 	inst_table_get_unify_insts(InstTable, UnifyInstTable),
 	map__lookup(UnifyInstTable, unify_inst_pair(Live, A, B), MaybeInst),
 	( MaybeInst = known(Inst0) ->
@@ -263,7 +280,8 @@ inst_lookup_2(unify_inst(Live, A, B), InstTable, Inst) :-
 	;
 		Inst = defined_inst(unify_inst(Live, A, B))
 	).
-inst_lookup_2(merge_inst(A, B), InstTable, Inst) :-
+inst_lookup_2(merge_inst(A, B), ModuleInfo, Inst) :-
+	module_info_insts(ModuleInfo, InstTable),
 	inst_table_get_merge_insts(InstTable, MergeInstTable),
 	map__lookup(MergeInstTable, A - B, MaybeInst),
 	( MaybeInst = known(Inst0) ->
@@ -271,7 +289,8 @@ inst_lookup_2(merge_inst(A, B), InstTable, Inst) :-
 	;
 		Inst = defined_inst(merge_inst(A, B))
 	).
-inst_lookup_2(ground_inst(A), InstTable, Inst) :-
+inst_lookup_2(ground_inst(A), ModuleInfo, Inst) :-
+	module_info_insts(ModuleInfo, InstTable),
 	inst_table_get_ground_insts(InstTable, GroundInstTable),
 	map__lookup(GroundInstTable, A, MaybeInst),
 	( MaybeInst = known(Inst0) ->
@@ -279,7 +298,8 @@ inst_lookup_2(ground_inst(A), InstTable, Inst) :-
 	;
 		Inst = defined_inst(ground_inst(A))
 	).
-inst_lookup_2(user_inst(Name, Args), InstTable, Inst) :-
+inst_lookup_2(user_inst(Name, Args), ModuleInfo, Inst) :-
+	module_info_insts(ModuleInfo, InstTable),
 	inst_table_get_user_insts(InstTable, UserInstTable),
 	list__length(Args, Arity),
 	( map__search(UserInstTable, Name - Arity, InstDefn) ->
@@ -288,6 +308,211 @@ inst_lookup_2(user_inst(Name, Args), InstTable, Inst) :-
 	;
 		Inst = abstract_inst(Name, Args)
 	).
+inst_lookup_2(typed_ground(Type), ModuleInfo, Inst) :-
+	propagate_type_info_inst(Type, ModuleInfo, ground, Inst).
+inst_lookup_2(typed_inst(Type, InstName), ModuleInfo, Inst) :-
+	inst_lookup_2(InstName, ModuleInfo, Inst0),
+	propagate_type_info_inst(Type, ModuleInfo, Inst0, Inst).
+
+%-----------------------------------------------------------------------------%
+
+	% Given corresponding lists of types and modes, produce a new
+	% list of modes which includes the information provided by the
+	% corresponding types.
+
+propagate_type_info_mode_list([], _, [], []).
+propagate_type_info_mode_list([Type | Types], ModuleInfo, [Mode0 | Modes0],
+		[Mode | Modes]) :-
+	propagate_type_info_mode(Type, ModuleInfo, Mode0, Mode),
+	propagate_type_info_mode_list(Types, ModuleInfo, Modes0, Modes).
+
+	% Given a type and a mode, produce a new mode which includes
+	% the information provided by the type.
+
+:- pred propagate_type_info_mode(type, module_info, mode, mode).
+:- mode propagate_type_info_mode(in, in, in, out) is det.
+
+propagate_type_info_mode(Type, ModuleInfo, Mode0, Mode) :-
+	mode_get_insts(ModuleInfo, Mode0, InitialInst0, FinalInst0),
+	ex_propagate_type_info_inst(Type, ModuleInfo, InitialInst0,
+		InitialInst),
+	ex_propagate_type_info_inst(Type, ModuleInfo, FinalInst0, FinalInst),
+	Mode = (InitialInst -> FinalInst).
+
+	% Given a type and an inst, produce a new inst which includes
+	% the information provided by the type.
+
+propagate_type_info_inst(Type, ModuleInfo, Inst0, Inst) :-
+	( Type = term__variable(_) ->
+		% A type variable doesn't provide any extra information
+		Inst = Inst0
+	;
+		module_info_types(ModuleInfo, TypeTable),
+		type_to_type_id(Type, TypeId, TypeArgs),
+		(
+			map__search(TypeTable, TypeId, TypeDefn),
+			TypeDefn = hlds__type_defn(_, TypeParams, TypeBody,
+							_, _),
+			TypeBody = du_type(Constructors0, _, _)
+		->
+			substitute_type_args(TypeParams, TypeArgs,
+				Constructors0, Constructors),
+			propagate_ctor_info(Inst0, Type, Constructors,
+				ModuleInfo, Inst)
+		;
+			Inst = Inst0
+		)
+	).
+
+	% Given a type and an inst, produce a new inst which includes
+	% the information provided by the type.
+
+:- pred ex_propagate_type_info_inst(type, module_info, inst, inst).
+:- mode ex_propagate_type_info_inst(in, in, in, out) is det.
+
+ex_propagate_type_info_inst(Type, ModuleInfo, Inst0, Inst) :-
+	( Type = term__variable(_) ->
+		% A type variable doesn't provide any extra information
+		Inst = Inst0
+	;
+		module_info_types(ModuleInfo, TypeTable),
+		type_to_type_id(Type, TypeId, TypeArgs),
+		(
+			map__search(TypeTable, TypeId, TypeDefn),
+			TypeDefn = hlds__type_defn(_, TypeParams, TypeBody,
+							_, _),
+			TypeBody = du_type(Constructors0, _, _)
+		->
+			substitute_type_args(TypeParams, TypeArgs,
+				Constructors0, Constructors),
+			ex_propagate_ctor_info(Inst0, Type, Constructors,
+				ModuleInfo, Inst)
+		;
+			Inst = Inst0
+		)
+	).
+
+%-----------------------------------------------------------------------------%
+
+	% Substitute the actual values of the type parameters
+	% in list of constructors, for a particular instance of
+	% a polymorphic type.
+
+:- pred substitute_type_args(list(type_param), list(type),
+				list(constructor), list(constructor)).
+:- mode substitute_type_args(in, in, in, out) is det.
+
+substitute_type_args(TypeParams0, TypeArgs, Constructors0, Constructors) :-
+	( TypeParams0 = [] ->
+		Constructors = Constructors0
+	;
+		term__term_list_to_var_list(TypeParams0, TypeParams),
+		substitute_type_args_2(Constructors0, TypeParams, TypeArgs,
+			Constructors)
+	).
+
+:- pred substitute_type_args_2(list(constructor), list(var), list(type),
+				list(constructor)).
+:- mode substitute_type_args_2(in, in, in, out) is det.
+
+substitute_type_args_2([], _TypeParams, _TypeArgs, []).
+substitute_type_args_2([Name - Args0 | Ctors0], TypeParams, TypeArgs,
+		[Name - Args | Ctors]) :-
+	term__substitute_corresponding_list(TypeParams, TypeArgs, Args0, Args),
+	substitute_type_args_2(Ctors0, TypeParams, TypeArgs, Ctors).
+
+%-----------------------------------------------------------------------------%
+
+:- pred propagate_ctor_info(inst, type, list(constructor), module_info, inst).
+:- mode propagate_ctor_info(in, in, in, in, out) is det.
+
+% propagate_ctor_info(free, Type, _, _, free(Type)).	% temporarily disabled
+propagate_ctor_info(free, _Type, _, _, free).	% XXX temporary hack
+
+propagate_ctor_info(free(_), _, _, _, _) :-
+	error("propagate_ctor_info: type info already present").
+propagate_ctor_info(bound(BoundInsts0), _Type, Constructors, ModuleInfo,
+		Inst) :-
+	propagate_ctor_info_2(BoundInsts0, Constructors, ModuleInfo,
+		BoundInsts),
+	( BoundInsts = [] ->
+		Inst = not_reached
+	;
+		% XXX do we need to sort the BoundInsts?
+		Inst = bound(BoundInsts)
+	).
+propagate_ctor_info(ground, _Type, Constructors, ModuleInfo, Inst) :-
+	constructors_to_bound_insts(Constructors, ModuleInfo, BoundInsts0),
+	list__sort(BoundInsts0, BoundInsts),
+	Inst = bound(BoundInsts).
+propagate_ctor_info(not_reached, _Type, _Constructors, _ModuleInfo,
+		not_reached).
+propagate_ctor_info(inst_var(_), _, _, _, _) :-
+	error("propagate_ctor_info: unbound inst var").
+propagate_ctor_info(abstract_inst(Name, Args), _, _, _,
+		abstract_inst(Name, Args)).	% XXX loses info
+propagate_ctor_info(defined_inst(InstName), Type, Ctors, ModuleInfo, Inst) :-
+	inst_lookup(ModuleInfo, InstName, Inst0),
+	propagate_ctor_info(Inst0, Type, Ctors, ModuleInfo, Inst).
+
+:- pred ex_propagate_ctor_info(inst, type, list(constructor), module_info, inst).
+:- mode ex_propagate_ctor_info(in, in, in, in, out) is det.
+
+% ex_propagate_ctor_info(free, Type, _, _, free(Type)).	% temporarily disabled
+ex_propagate_ctor_info(free, _Type, _, _, free).	% XXX temporary hack
+
+ex_propagate_ctor_info(free(_), _, _, _, _) :-
+	error("ex_propagate_ctor_info: type info already present").
+ex_propagate_ctor_info(bound(BoundInsts0), _Type, Constructors, ModuleInfo,
+		Inst) :-
+	propagate_ctor_info_2(BoundInsts0, Constructors, ModuleInfo,
+		BoundInsts),
+	( BoundInsts = [] ->
+		Inst = not_reached
+	;
+		% XXX do we need to sort the BoundInsts?
+		Inst = bound(BoundInsts)
+	).
+ex_propagate_ctor_info(ground, Type, _, _, Inst) :-
+	Inst = defined_inst(typed_ground(Type)).
+ex_propagate_ctor_info(not_reached, _Type, _Constructors, _ModuleInfo,
+		not_reached).
+ex_propagate_ctor_info(inst_var(_), _, _, _, _) :-
+	error("propagate_ctor_info: unbound inst var").
+ex_propagate_ctor_info(abstract_inst(Name, Args), _, _, _,
+		abstract_inst(Name, Args)).	% XXX loses info
+ex_propagate_ctor_info(defined_inst(InstName), Type, _, _,
+		defined_inst(typed_inst(Type, InstName))).
+
+:- pred constructors_to_bound_insts(list(constructor), module_info,
+				list(bound_inst)).
+:- mode constructors_to_bound_insts(in, in, out) is det.
+
+constructors_to_bound_insts([], _, []).
+constructors_to_bound_insts([Ctor | Ctors], ModuleInfo,
+		[BoundInst | BoundInsts]) :-
+	Ctor = Name0 - Args,
+	type_list_to_inst_list(Args, Insts),
+	unqualify_name(Name0, Name),
+	BoundInst = functor(term__atom(Name), Insts),
+	constructors_to_bound_insts(Ctors, ModuleInfo, BoundInsts).
+
+:- pred type_list_to_inst_list(list(type), list(inst)).
+:- mode type_list_to_inst_list(in, out) is det.
+
+type_list_to_inst_list([], []).
+type_list_to_inst_list([Type | Types], [Inst | Insts]) :-
+	Inst = defined_inst(typed_ground(Type)),
+	type_list_to_inst_list(Types, Insts).
+
+:- pred propagate_ctor_info_2(list(bound_inst), list(constructor),
+		module_info, list(bound_inst)).
+:- mode propagate_ctor_info_2(in, in, in, out) is det.
+
+propagate_ctor_info_2(BoundInsts0, _Constructors, _ModuleInfo, BoundInsts) :-
+	BoundInsts = BoundInsts0.	% XXX Stub only!!
+
+%-----------------------------------------------------------------------------%

 :- pred inst_lookup_subst_args(hlds__inst_body, list(inst_param), sym_name,
 			list(inst), inst).
@@ -298,6 +523,7 @@ inst_lookup_subst_args(eqv_inst(Inst0), Params, _Name, Args, Inst) :-
 inst_lookup_subst_args(abstract_inst, _Params, Name, Args,
 		abstract_inst(Name, Args)).

+%-----------------------------------------------------------------------------%
 	% mode_get_insts returns the initial instantiatedness and
 	% the final instantiatedness for a given mode.

--- a/compiler/prog_io.m
+++ b/compiler/prog_io.m
@@ -176,11 +176,11 @@
 :- type inst_param	==	term.

 :- type (inst)		--->	free
+			;	free(type)
 			;	bound(list(bound_inst))
 					% The list must be sorted
 			;	ground
 			;	not_reached
-
 			;	inst_var(var)
 			;	defined_inst(inst_name)
 				% An abstract inst is a defined inst which
@@ -193,7 +193,9 @@
 :- type inst_name	--->	user_inst(sym_name, list(inst))
 			;	merge_inst(inst, inst)
 			;	unify_inst(is_live, inst, inst)
-			;	ground_inst(inst_name).
+			;	ground_inst(inst_name)
+			;	typed_ground(type)
+			;	typed_inst(type, inst_name).

 :- type is_live		--->	live ; dead.

--- a/compiler/type_util.m
+++ b/compiler/type_util.m
@@ -8,8 +8,6 @@
 % It is used by various stages of the compilation after type-checking,
 % include the mode checker and the code generator.

-% XXX TODO: implement type_is_enumeration.
-
 %-----------------------------------------------------------------------------%
 %-----------------------------------------------------------------------------%

@@ -41,6 +39,11 @@

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

+	% Given a non-variable type, return it's type-id and argument types.
+
+:- pred type_to_type_id(type, type_id, list(type)).
+:- mode type_to_type_id(in, out, out) is det.
+
 	% Given a constant and an arity, return a type_id.

 :- pred make_type_id(const, int, type_id).
@@ -87,17 +90,17 @@ classify_type(VarType, ModuleInfo, Type) :-
 :- mode type_is_enumeration(in, in) is semidet.

 type_is_enumeration(Type, ModuleInfo) :-
-	type_to_type_id(Type, TypeId),
+	Type = term__functor(_, _, _),
+	type_to_type_id(Type, TypeId, _),
 	module_info_types(ModuleInfo, TypeDefnTable),
 	map__lookup(TypeDefnTable, TypeId, TypeDefn),
 	TypeDefn = hlds__type_defn(_, _, TypeBody, _, _),
 	TypeBody = du_type(_, _, IsEnum),
 	IsEnum = yes.

-:- pred type_to_type_id(type, type_id).
-:- mode type_to_type_id(in, out) is det.
-
-type_to_type_id(term__functor(Name, Args, _), TypeId) :-
+type_to_type_id(term__variable(_), _, _) :-
+	error("cannot make type_id for a type variable").
+type_to_type_id(term__functor(Name, Args, _), TypeId, Args) :-
 	list__length(Args, Arity),
 	make_type_id(Name, Arity, TypeId).

--- a/library/list.m
+++ b/library/list.m
@@ -65,7 +65,7 @@
 ****/
 :- mode list__same_length(in, output_list_skel) is det.
 :- mode list__same_length(output_list_skel, in) is det.
-:- mode list__same_length(in, in) is det.
+:- mode list__same_length(in, in) is semidet.

 	% list__split_list(Len, List, Start, End):
 	%	splits `List' into a prefix `Start' of length `Len',
--- a/library/map.m
+++ b/library/map.m
@@ -94,7 +94,6 @@

 	% For map__merge(MapA, MapB, Map), MapA and MapB must
 	% not both contain the same key.
-
 :- pred map__merge(map(K, V), map(K, V), map(K, V)).
 :- mode map__merge(in, in, out) is det.

@@ -102,10 +101,12 @@
 	% contain the same key, then Map will map that key to
 	% the value from MapB.  In otherwords, MapB takes precedence
 	% over MapA.
-
 :- pred map__overlay(map(K,V), map(K,V), map(K,V)).
 :- mode map__overlay(in, in, out) is det.

+:- pred map__apply_to_list(list(K), map(K, V), list(V)).
+:- mode map__apply_to_list(in, in, out) is det.
+
 :- pred map__optimize(map(K, V), map(K, V)).
 :- mode map__optimize(in, out) is det.

@@ -231,5 +232,12 @@ map__overlay_2([K - V | AssocList], Map0, Map) :-
 	map__set(Map0, K, V, Map1),
 	map__overlay_2(AssocList, Map1, Map).
 	
+%-----------------------------------------------------------------------------%
+
+map__apply_to_list([], _, []).
+map__apply_to_list([K | Ks], Map, [V | Vs]) :-
+	map__lookup(Map, K, V),
+	map__apply_to_list(Ks, Map, Vs).
+
 %-----------------------------------------------------------------------------%
 %-----------------------------------------------------------------------------%