[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