[m-dev.] diff: improve performance of type_util__type_is_not_tag_type

Simon Taylor stayl at cs.mu.OZ.AU
Thu Oct 26 17:06:10 AEDT 2000



Estimated hours taken: 1

Improve the efficiency of type_util__type_is_no_tag_type.
This change reduces the time taken by `mmc -C make_hlds' by
about 2%.

compiler/hlds_data.m:
compiler/hlds_module.m:
compiler/make_hlds.m:
	Add a field to the module_info to hold information about
	no-tag types to avoid searching the entire type table.

compiler/type_util.m:
	Look up the no-tag type table rather than the type table
	in type_is_no_tag_type.

	Minor efficiency improvements for type_to_type_id.	

	Avoid unnecessary calls to type_to_type_id.


Index: hlds_data.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_data.m,v
retrieving revision 1.48
diff -u -u -r1.48 hlds_data.m
--- hlds_data.m	2000/10/13 13:55:24	1.48
+++ hlds_data.m	2000/10/25 15:08:09
@@ -370,6 +370,21 @@
 
 :- type tag_bits	==	int.	% actually only 2 (or maybe 3) bits
 
+
+	% The type definitions for no_tag types have information
+	% mirrored in a separate table for faster lookups.
+	% mode_util__mode_to_arg_mode makes heavy use of
+	% type_util__type_is_no_tag_type.
+:- type no_tag_type
+	--->	no_tag_type(
+			list(type_param),	% Formal type parameters.
+			sym_name,		% Constructor name.
+			(type)			% Argument type.
+		).
+
+:- type no_tag_type_table == map(type_id, no_tag_type).
+
+
 :- implementation.
 
 :- type hlds_type_defn
Index: hlds_module.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_module.m,v
retrieving revision 1.61
diff -u -u -r1.61 hlds_module.m
--- hlds_module.m	2000/09/25 04:24:31	1.61
+++ hlds_module.m	2000/10/25 15:08:10
@@ -315,6 +315,13 @@
 		type_spec_info, module_info).
 :- mode module_info_set_type_spec_info(in, in, out) is det.
 
+:- pred module_info_no_tag_types(module_info, no_tag_type_table).
+:- mode module_info_no_tag_types(in, out) is det.
+
+:- pred module_info_set_no_tag_types(module_info,
+		no_tag_type_table, module_info).
+:- mode module_info_set_no_tag_types(in, in, out) is det.
+
 %-----------------------------------------------------------------------------%
 
 :- pred module_info_preds(module_info, pred_table).
@@ -498,9 +505,15 @@
 		do_aditi_compilation ::		do_aditi_compilation,
 					% are there any local Aditi predicates
 					% for which Aditi-RL must be produced.
-		type_spec_info ::		type_spec_info
+		type_spec_info ::		type_spec_info,
 					% data used for user-guided type
 					% specialization.
+		no_tag_type_table ::		no_tag_type_table
+					% Information about no tag
+					% types. This information is
+					% also in the type_table,
+					% but lookups in this table
+					% will be much faster.
 	).
 
 	% A predicate which creates an empty module
@@ -535,9 +548,11 @@
 	assertion_table_init(AssertionTable),
 	map__init(FieldNameTable),
 
+	map__init(NoTagTypes),
 	ModuleSubInfo = module_sub(Name, Globals, [], [], no, 0, 0, [], 
 		[], StratPreds, UnusedArgInfo, 0, ImportedModules,
-		IndirectlyImportedModules, no_aditi_compilation, TypeSpecInfo),
+		IndirectlyImportedModules, no_aditi_compilation,
+		TypeSpecInfo, NoTagTypes),
 	ModuleInfo = module(ModuleSubInfo, PredicateTable, Requests,
 		UnifyPredMap, QualifierInfo, Types, Insts, Modes, Ctors,
 		ClassTable, SuperClassTable, InstanceTable, AssertionTable,
@@ -606,9 +621,10 @@
 	MI ^ sub_info ^ imported_module_specifiers).
 module_info_get_indirectly_imported_module_specifiers(MI,
 	MI ^ sub_info ^ indirectly_imported_module_specifiers).
-module_info_type_spec_info(MI, MI ^ sub_info ^ type_spec_info).
 module_info_get_do_aditi_compilation(MI,
 	MI ^ sub_info ^ do_aditi_compilation).
+module_info_type_spec_info(MI, MI ^ sub_info ^ type_spec_info).
+module_info_no_tag_types(MI, MI ^ sub_info ^ no_tag_type_table).
 
 %-----------------------------------------------------------------------------%
 
@@ -647,10 +663,12 @@
 		set__insert_list(
 			MI ^ sub_info ^ indirectly_imported_module_specifiers,
 			Modules)).
-module_info_set_type_spec_info(MI, NewVal,
-	MI ^ sub_info ^ type_spec_info := NewVal).
 module_info_set_do_aditi_compilation(MI,
 	MI ^ sub_info ^ do_aditi_compilation := do_aditi_compilation).
+module_info_set_type_spec_info(MI, NewVal,
+	MI ^ sub_info ^ type_spec_info := NewVal).
+module_info_set_no_tag_types(MI, NewVal,
+	MI ^ sub_info ^ no_tag_type_table := NewVal).
 
 %-----------------------------------------------------------------------------%
 
Index: make_hlds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/make_hlds.m,v
retrieving revision 1.353
diff -u -u -r1.353 make_hlds.m
--- make_hlds.m	2000/10/13 13:55:33	1.353
+++ make_hlds.m	2000/10/25 15:08:11
@@ -1751,6 +1751,7 @@
 	globals__io_get_globals(Globals),
 	{ convert_type_defn(TypeDefn, Globals, Name, Args, Body) },
 	{ list__length(Args, Arity) },
+	{ TypeId = Name - Arity },
 	{ Body = abstract_type ->
 		make_status_abstract(Status0, Status1)
 	;
@@ -1759,18 +1760,19 @@
 	{ 
 		% the type is exported if *any* occurrence is exported,
 		% even a previous abstract occurrence
-		map__search(Types0, Name - Arity, OldDefn)
+		map__search(Types0, TypeId, OldDefn)
 	->
 		hlds_data__get_type_defn_status(OldDefn, OldStatus),
-		combine_status(Status1, OldStatus, Status)
+		combine_status(Status1, OldStatus, Status),
+		MaybeOldDefn = yes(OldDefn)
 	;
+		MaybeOldDefn = no,
 		Status = Status1 
 	},
 	{ hlds_data__set_type_defn(TVarSet, Args, Body, Status, Context, T) },
-	{ TypeId = Name - Arity },
 	(
 		% if there was an existing non-abstract definition for the type
-		{ map__search(Types0, TypeId, T2) },
+		{ MaybeOldDefn = yes(T2) },
 		{ hlds_data__get_type_defn_tvarset(T2, TVarSet_2) },
 		{ hlds_data__get_type_defn_tparams(T2, Params_2) },
 		{ hlds_data__get_type_defn_body(T2, Body_2) },
@@ -1820,7 +1822,26 @@
 				Ctors0, Ctors),
 			{ module_info_set_ctors(Module0, Ctors, Module1) },
 			{ module_info_set_ctor_field_table(Module1,
-				CtorFields, Module2) }
+				CtorFields, Module1a) },
+			globals__io_lookup_bool_option(unboxed_no_tag_types,
+				AllowNoTagTypes),
+
+			{
+				AllowNoTagTypes = yes,
+				type_constructors_are_no_tag_type(ConsList,
+					Name, CtorArgType)
+			->
+				NoTagType = no_tag_type(Args,
+					Name, CtorArgType),
+				module_info_no_tag_types(Module1a,
+					NoTagTypes0),
+				map__set(NoTagTypes0, TypeId, NoTagType,
+					NoTagTypes),
+				module_info_set_no_tag_types(Module1a,
+					NoTagTypes, Module2)
+			;
+				Module2 = Module1a
+			}
 		;
 			{ Module2 = Module0 }
 		),
Index: type_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/type_util.m,v
retrieving revision 1.91
diff -u -u -r1.91 type_util.m
--- type_util.m	2000/10/13 13:56:00	1.91
+++ type_util.m	2000/10/25 15:08:12
@@ -515,16 +515,13 @@
 		Type = term__functor(term__atom("="),
 			[FuncEvalAndArgs, FuncRetType], _)
 	->
-		get_lambda_eval_method(FuncEvalAndArgs, EvalMethod,
-			FuncAndArgs),
-		FuncAndArgs = term__functor(term__atom("func"),
-			FuncArgTypes, _),
+		get_lambda_eval_method_and_args("func", FuncEvalAndArgs,
+			EvalMethod, FuncArgTypes),
 		list__append(FuncArgTypes, [FuncRetType], PredArgTypes),
 		PredOrFunc = function
 	;
-		get_lambda_eval_method(Type, EvalMethod, PredAndArgs),
-		PredAndArgs = term__functor(term__atom("pred"),
-					PredArgTypes, _),
+		get_lambda_eval_method_and_args("pred",
+			Type, EvalMethod, PredArgTypes),
 		PredOrFunc = predicate
 	).
 
@@ -533,25 +530,25 @@
 	type_id_is_tuple(TypeId).
 
 	% From the type of a lambda expression, work out how it should
-	% be evaluated.
-:- pred get_lambda_eval_method((type), lambda_eval_method, (type)) is det.
-:- mode get_lambda_eval_method(in, out, out) is det.
-
-get_lambda_eval_method(Type0, EvalMethod, Type) :-
-	( Type0 = term__functor(term__atom(MethodStr), [Type1], _) ->
-		( MethodStr = "aditi_bottom_up" ->
-			EvalMethod = (aditi_bottom_up),
-			Type = Type1
-		; MethodStr = "aditi_top_down" ->
-			EvalMethod = (aditi_top_down),
-			Type = Type1
+	% be evaluated and extract the argument types.
+:- pred get_lambda_eval_method_and_args(string, (type),
+		lambda_eval_method, list(type)) is det.
+:- mode get_lambda_eval_method_and_args(in, in, out, out) is semidet.
+
+get_lambda_eval_method_and_args(PorFStr, Type0, EvalMethod, ArgTypes) :-
+	Type0 = term__functor(term__atom(Functor), Args, _),
+	( Functor = PorFStr ->
+		EvalMethod = normal,
+		ArgTypes = Args
+	;	
+		Args = [Type1],
+		Type1 = term__functor(term__atom(PorFStr), ArgTypes, _),
+		( Functor = "aditi_bottom_up" ->
+			EvalMethod = (aditi_bottom_up)
 		;
-			EvalMethod = normal,
-			Type = Type0
+			Functor = "aditi_top_down",
+			EvalMethod = (aditi_top_down)
 		)
-	;
-		EvalMethod = normal,
-		Type = Type0
 	).
 
 type_id_is_higher_order(SymName - _Arity, PredOrFunc, EvalMethod) :-
@@ -637,16 +634,8 @@
 	IsEnum = yes.
 
 type_to_type_id(Type, SymName - Arity, Args) :-
-	sym_name_and_args(Type, SymName0, Args1),
+	Type \= term__variable(_),
 
-	% `private_builtin:constraint' is introduced by polymorphism, and
-	% should only appear as the argument of a `typeclass:info/1' type.
-	% It behaves sort of like a type variable, so according to the
-	% specification of `type_to_type_id', it should cause failure.
-	% There isn't a definition in the type table.
-	mercury_private_builtin_module(PrivateBuiltin),
-	SymName \= qualified(PrivateBuiltin, "constraint"),
-
 	% higher order types may have representations where
 	% their arguments don't directly correspond to the
 	% arguments of the term.
@@ -672,14 +661,25 @@
 			EvalMethod = (aditi_top_down),
 			SymName = qualified(unqualified("aditi_top_down"),
 					PorFStr)
-			
 		;
 			EvalMethod = normal,
 			SymName = unqualified(PorFStr)
 		)
 	;
-		SymName = SymName0,
-		Args = Args1,
+		sym_name_and_args(Type, SymName, Args),
+
+		% `private_builtin:constraint' is introduced by polymorphism,
+		% and should only appear as the argument of a
+		% `typeclass:info/1' type.
+		% It behaves sort of like a type variable, so according to the
+		% specification of `type_to_type_id', it should cause failure.
+		% There isn't a definition in the type table.
+		\+ (
+			SymName = qualified(ModuleName, UnqualName),
+			UnqualName = "constraint",
+			mercury_private_builtin_module(PrivateBuiltin),
+			ModuleName = PrivateBuiltin	
+		),
 		list__length(Args, Arity)
 	).
 
@@ -749,16 +749,15 @@
 	% If the type is a du type, return the list of its constructors.
 
 type_constructors(Type, ModuleInfo, Constructors) :-
-	( type_is_tuple(Type, TupleArgTypes) ->
-		% tuples are never existentially typed.
+	type_to_type_id(Type, TypeId, TypeArgs),
+	( type_id_is_tuple(TypeId) ->
+		% Tuples are never existentially typed.
 		ExistQVars = [],	
 		ClassConstraints = [],
-		CtorArgs = list__map((func(ArgType) = no - ArgType),
-				TupleArgTypes),
+		CtorArgs = list__map((func(ArgType) = no - ArgType), TypeArgs),
 		Constructors = [ctor(ExistQVars, ClassConstraints,
 				unqualified("{}"), CtorArgs)]
 	;
-		type_to_type_id(Type, TypeId, TypeArgs),
 		module_info_types(ModuleInfo, TypeTable),
 		map__search(TypeTable, TypeId, TypeDefn),
 		hlds_data__get_type_defn_tparams(TypeDefn, TypeParams),
@@ -771,17 +770,17 @@
 %-----------------------------------------------------------------------------%
 
 type_util__switch_type_num_functors(ModuleInfo, Type, NumFunctors) :-
-	( Type = term__functor(term__atom("character"), [], _) ->
+	type_to_type_id(Type, TypeId, _),
+	( TypeId = unqualified("character") - 0 ->
 		% XXX the following code uses the source machine's character
 		% size, not the target's, so it won't work if cross-compiling
 		% to a machine with a different size character.
 		char__max_char_value(MaxChar),
 		char__min_char_value(MinChar),
 		NumFunctors is MaxChar - MinChar + 1
-	; type_is_tuple(Type, _) ->
+	; type_id_is_tuple(TypeId) ->
 		NumFunctors = 1
 	;
-		type_to_type_id(Type, TypeId, _),
 		module_info_types(ModuleInfo, TypeTable),
 		map__search(TypeTable, TypeId, TypeDefn),
 		hlds_data__get_type_defn_body(TypeDefn, TypeBody),
@@ -813,15 +812,17 @@
 
 type_util__get_cons_id_arg_types_2(EQVarAction, ModuleInfo, VarType, ConsId,
 		ArgTypes) :-
+    (
+	type_to_type_id(VarType, TypeId, TypeArgs)
+    ->
 	(
 		% The argument types of a tuple cons_id are the
 		% arguments of the tuple type.
-		type_is_tuple(VarType, TupleTypeArgs)
+		type_id_is_tuple(TypeId)
 	->
-		ArgTypes = TupleTypeArgs
+		ArgTypes = TypeArgs
 	;
-		type_to_type_id(VarType, _, TypeArgs),
-		type_util__do_get_type_and_cons_defn(ModuleInfo, VarType,
+		type_util__do_get_type_and_cons_defn(ModuleInfo, TypeId,
 			ConsId, TypeDefn, ConsDefn),
 		ConsDefn = hlds_cons_defn(ExistQVars0, _Constraints0,
 				Args, _, _),
@@ -848,7 +849,10 @@
 		term__apply_substitution_to_list(ArgTypes0, TSubst, ArgTypes)
 	;
 		ArgTypes = []
-	).
+	)
+    ;
+    	ArgTypes = []
+    ).
 
 type_util__cons_id_arg_types(ModuleInfo, VarType, ConsId, ArgTypes) :-
 	type_to_type_id(VarType, TypeId, TypeArgs),
@@ -907,8 +911,9 @@
 type_util__get_type_and_cons_defn(ModuleInfo, Type, ConsId,
 		TypeDefn, ConsDefn) :-
 	(
+		type_to_type_id(Type, TypeId, _),
 		type_util__do_get_type_and_cons_defn(ModuleInfo,
-			Type, ConsId, TypeDefn0, ConsDefn0)
+			TypeId, ConsId, TypeDefn0, ConsDefn0)
 	->
 		TypeDefn = TypeDefn0,
 		ConsDefn = ConsDefn0
@@ -917,12 +922,11 @@
 	).
 
 :- pred type_util__do_get_type_and_cons_defn(module_info::in,
-		(type)::in, cons_id::in, hlds_type_defn::out,
+		type_id::in, cons_id::in, hlds_type_defn::out,
 		hlds_cons_defn::out) is semidet.
 
-type_util__do_get_type_and_cons_defn(ModuleInfo, VarType, ConsId,
+type_util__do_get_type_and_cons_defn(ModuleInfo, TypeId, ConsId,
 		TypeDefn, ConsDefn) :-
-	type_to_type_id(VarType, TypeId, _TypeArgs),
 	type_util__get_cons_defn(ModuleInfo, TypeId, ConsId, ConsDefn),
 	module_info_types(ModuleInfo, Types),
 	map__lookup(Types, TypeId, TypeDefn).
@@ -942,12 +946,17 @@
 %-----------------------------------------------------------------------------%
 
 type_is_no_tag_type(ModuleInfo, Type, Ctor, ArgType) :-
-		% Make sure no_tag_types are allowed
-	module_info_globals(ModuleInfo, Globals),
-	globals__lookup_bool_option(Globals, unboxed_no_tag_types, yes),
-		% Check for a single ctor with a single arg
-	type_constructors(Type, ModuleInfo, Ctors),
-	type_constructors_are_no_tag_type(Ctors, Ctor, ArgType).
+	type_to_type_id(Type, TypeId, TypeArgs),
+	module_info_no_tag_types(ModuleInfo, NoTagTypes),
+	map__search(NoTagTypes, TypeId, NoTagType),
+	NoTagType = no_tag_type(TypeParams0, Ctor, ArgType0),
+	( TypeParams0 = [] ->
+		ArgType = ArgType0
+	;
+		term__term_list_to_var_list(TypeParams0, TypeParams),
+		map__from_corresponding_lists(TypeParams, TypeArgs, Subn),
+		term__apply_substitution(ArgType0, Subn, ArgType)
+	).
 
 	% The checks for type_info and type_ctor_info
 	% are needed because those types lie about their
--------------------------------------------------------------------------
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
--------------------------------------------------------------------------



More information about the developers mailing list