for review: type specialisation round 2
Simon Taylor
stayl at cs.mu.OZ.AU
Tue Sep 8 11:08:19 AEST 1998
Hi Fergus,
I ran into some problems with typeclasses and some of the type
specialisation changes - here's a relative diff (and log) for
the affected modules.
compiler/higher_order.m:
compiler/type_util.m:
Make sure the typeclass_info_varmap is updated.
compiler/polymorphism.m:
Don't update the type_info_varmap after extracting a type_info
from a typeclass_info - the typeinfo won't be in that location
in other branches.
compiler/polymorphism.m:
compiler/type_util.m:
Make sure the dummy `constraint' type used to encode
class constraints is module qualified so it can't be
confused with user types.
compiler/base_type_layout.m:
Don't generate references to the typeinfo for
`private_builtin:constraint' - it doesn't exist.
runtime/mercury_ho_call.c:
Semidet and nondet class_method_calls where
(0 < num_arg_typeclass_infos < 4) were aborting at runtime
because arguments were being placed starting at r1 rather
than at r(1 + num_arg_typeclass_infos).
Simon.
Estimated hours taken: 50
Rework the handling of types in higher_order.m.
- Fix bugs in higher_order.m that stopped it working with --typeinfo-liveness.
- Perform type and typeclass specialisation.
compiler/polymorphism.m:
Previously the type of typeclass_infos variables did not contain
any information about the constraint about which the variable contains
information. Now the type of a typeclass_info is
`private_builtin:typeclass_info(
private_builtin:constraint([ClassName, ConstrainedTypes]))'.
This allows predicates such as type_list_subsumes to check that
the class constraints match.
Note that `private_builtin:constraint' has no declaration, so
a lookup in the type definition map will fail. That's OK, because
type_to_type_id will fail on it, so it will be treated as a type
variable by any code which doesn't manipulate types directly.
Added polymorphism__typeclass_info_class_constraint to get the
class_constraint from a typeclass_info's type. This isn't used yet.
Also, fix a bug in extract_type_info: an entry in the typeinfo_var_map
was being overwritten using an entry from a dummy typevarset. Actually
the optimization to overwrite the location of the type_info after
extracting it from a typeclass_info was wrong because the type_info
won't be in that location in other branches.
compiler/higher_order.m:
Rework the handling of type substitutions. Now the types of the
called procedure are `inlined' into the calling procedure, rather
than building up the types of the specialised version using the
higher-order arguments. The advantage of this is that the code is
a bit simpler and handles extra type_infos properly. The disadvantage
is that the argument types for specialised versions may be more
specific than they need to be, so in some cases more specialised
versions will be created than before.
Also, don't actually rebuild the higher-order terms in the specialised
versions - just pass the terms through in case they are needed.
Handle the extra typeinfos required for --typeinfo-liveness.
Specialize calls to unify/2, index/2 and compare/3.
Specialize class_method_calls.
Specialize calls to the predicates in private_builtin.m which
manipulate typeclass_infos.
compiler/type_util.m:
type_to_type_id now fails on the dummy `constraint' type.
Remove typeinfos for non-variable types from the typeinfo_varmap
after inlining and higher-order specialisation.
Added a predicate `pred apply_substitutions_to_typeclass_var_map'
to apply type and variable renamings and a type substitution to
the typeclass_info_varmap for a specialised version.
compiler/inlining.m:
Factor out some common code to handle type substitutions
for use by higher_order.m.
compiler/hlds_pred.m:
Return the list of extra type_info variables added to the
argument list.
compiler/goal_util.m:
Take a set of non-locals as an argument to
goal_util__extra_nonlocal_typeinfos rather than extracting
them from a goal.
compiler/special_pred.m:
Handle unmangled unify/compare/index in special_pred_get_type.
compiler/base_type_layout.m:
Don't generate references to the typeinfo for
`private_builtin:constraint' - it doesn't exist.
compiler/unused_args.m:
Don't barf on specialised unification predicate names.
compiler/options.m:
Added options:
`--type-specialization' (default off).
`--higher-order-size-limit' - restrict the size of specialized
versions produced by higher_order.m.
`--disable-opt-for-trace' (default on) - where possible don't
change the options to make the trace match the source code.
compiler/handle_options.m:
Don't disable higher_order.m when --typeinfo-liveness is set.
Handle `--disable-opt-for-trace'.
compiler/hlds_data.m:
compiler/*.m:
Add the instance number to `base_typeclass_info_const' cons_ids,
so that higher_order.m can easily index into the list of instances
for a class to find the methods.
compiler/hlds_out.m:
Use the correct varset when printing out the constraint proofs.
Write the typeclass_info_varmap for each procedure.
compiler/mercury_to_mercury.m:
Print type variables with variable numbers.
library/private_builtin.m:
Add the argument to the typeclass_info type to hold the representation
of the constraint.
runtime/mercury_ho_call.c:
Semidet and nondet class_method_calls where
(0 < num_arg_typeclass_infos < 4) were aborting at runtime
because arguments were being placed starting at r1 rather
than at r(1 + num_arg_typeclass_infos).
doc/user_guide.texi
Document the new options.
compiler/notes/compiler_design.html:
Update the role of higher_order.m.
tests/hard_coded/typeclasses/extra_typeinfo.m:
Test case for the mercury_ho_call.c bug and the polymorphism.m
extract_typeinfo bug and for updating the typeclass_info_varmap
for specialised versions.
Index: base_type_layout.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/base_type_layout.m,v
retrieving revision 1.33
diff -u -t -u -r1.33 base_type_layout.m
--- base_type_layout.m 1998/09/03 11:13:24 1.33
+++ base_type_layout.m 1998/09/07 03:05:27
@@ -1086,8 +1086,21 @@
base_type_layout__construct_pseudo_type_info(Type, Pseudo, CNum0, CNum) :-
(
- type_to_type_id(Type, TypeId, TypeArgs)
+ type_to_type_id(Type, TypeId, TypeArgs0)
->
+ (
+ % The argument to typeclass_info types is not
+ % a type - it encodes the class constraint.
+ mercury_private_builtin_module(PrivateBuiltin),
+ TypeId = qualified(PrivateBuiltin, TName) - _,
+ ( TName = "typeclass_info"
+ ; TName = "base_typeclass_info"
+ )
+ ->
+ TypeArgs = []
+ ;
+ TypeArgs = TypeArgs0
+ ),
(
% For higher order types: they all refer to the
% defined pred_0 base_type_info, have an extra
Index: handle_options.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/handle_options.m,v
retrieving revision 1.60
diff -u -t -u -r1.60 handle_options.m
--- handle_options.m 1998/07/27 01:04:38 1.60
+++ handle_options.m 1998/09/07 23:54:04
@@ -291,13 +291,16 @@
),
% Execution tracing requires
+ % - enabling stack layouts
+ % - enabling typeinfo liveness
+ %
+ % Also if `--disable-opt-for-trace' is set (by default it is)
% - disabling optimizations that would change
% the trace being generated
% - enabling some low level optimizations to ensure consistent
% paths across optimization levels
- % - enabling stack layouts
- % - enabling typeinfo liveness
- ( { trace_level_trace_interface(TraceLevel, yes) } ->
+ globals__io_lookup_bool_option(disable_opt_for_trace, DisableOpt),
+ ( { trace_level_trace_interface(TraceLevel, yes), DisableOpt = yes } ->
% The following options modify the structure
% of the program, which makes it difficult to
% relate the trace to the source code (although
@@ -307,11 +310,11 @@
globals__io_set_option(inline_compound_threshold, int(0)),
globals__io_set_option(optimize_unused_args, bool(no)),
globals__io_set_option(optimize_higher_order, bool(no)),
+ globals__io_set_option(type_specialization, bool(no)),
globals__io_set_option(deforestation, bool(no)),
globals__io_set_option(optimize_duplicate_calls, bool(no)),
globals__io_set_option(optimize_constructor_last_call,
bool(no)),
-
% The following option prevents useless variables
% from cluttering the trace. Its explicit setting
% removes a source of variability in the goal paths
@@ -320,7 +323,12 @@
% The explicit setting of the following option
% removes a source of variability in the goal paths
% reported by tracing.
- globals__io_set_option(follow_code, bool(yes)),
+ globals__io_set_option(follow_code, bool(yes))
+ ;
+ []
+ ),
+
+ ( { trace_level_trace_interface(TraceLevel, yes) } ->
% The following option selects a special-case
% code generator that cannot (yet) implement tracing.
globals__io_set_option(middle_rec, bool(no)),
@@ -363,12 +371,6 @@
% `procid' and `agc' stack layouts need `basic' stack layouts
option_implies(procid_stack_layout, basic_stack_layout, bool(yes)),
option_implies(agc_stack_layout, basic_stack_layout, bool(yes)),
-
- % XXX higher_order.m does not update the typeinfo_varmap
- % for specialised versions.
- % This causes the compiler to abort in unused_args.m when compiling
- % tests/valid/agc_ho_pred.m with `-O3 --intermodule-optimization'.
- option_implies(typeinfo_liveness, optimize_higher_order, bool(no)),
% XXX deforestation does not perform folding on polymorphic
% predicates correctly with --typeinfo-liveness.
===================================================================
--- higher_order.m 1998/08/31 02:10:53 1.3
+++ higher_order.m 1998/09/08 00:26:27
@@ -29,6 +29,8 @@
:- import_module bool, io.
% specialize_higher_order(DoHigherOrder, DoTypeInfos, Module0, Module).
+ % DoHigherOrder is the value of `--optimize-higher-order'.
+ % DoTypeInfos is the value of `--type-specialization'
:- pred specialize_higher_order(bool::in, bool::in,
module_info::in, module_info::out,
io__state::di, io__state::uo) is det.
@@ -320,7 +322,7 @@
Info0 = info(_, B, NewPreds0, PredProcId, E, F, G, H, I),
NewPreds0 = new_preds(_, PredVarMap),
% Lookup the initial known bindings of the variables if this
- % procedure is a specialised version..
+ % procedure is a specialised version.
( map__search(PredVarMap, PredProcId, PredVars) ->
Info1 = info(PredVars, B, NewPreds0, PredProcId, E, F, G, H, I)
;
@@ -639,7 +641,7 @@
).
% Process a call to see if it could possibly be specialized.
-:- pred maybe_specialize_call( hlds_goal::in, hlds_goal::out,
+:- pred maybe_specialize_call(hlds_goal::in, hlds_goal::out,
higher_order_info::in, higher_order_info::out) is det.
maybe_specialize_call(Goal0 - GoalInfo, Goal - GoalInfo, Info0, Info) :-
@@ -657,7 +659,7 @@
(
% Look for calls to unify/2 and compare/3 which can
% be specialized.
- specialize_builtin(Info0, CalledPred, CalledProc,
+ specialize_special_pred(Info0, CalledPred, CalledProc,
Args0, MaybeContext, Goal1)
->
Goal = Goal1,
@@ -989,7 +991,8 @@
% Interpret a call to `type_info_from_typeclass_info' or
% `superclass_from_typeclass_info'. Currently they both have
% the same definition. This should be kept in sync with
- % compiler/polymorphism.m and runtime/mercury_type_info.h.
+ % compiler/polymorphism.m, library/private_builtin.m and
+ % runtime/mercury_type_info.h.
:- pred interpret_typeclass_info_manipulator(typeclass_info_manipulator::in,
list(var)::in, hlds_goal_expr::in, hlds_goal_expr::out,
higher_order_info::in, higher_order_info::out) is det.
@@ -1034,11 +1037,11 @@
% Succeed if the called pred is "unify", "compare" or "index" and
% is specializable, returning a specialized goal.
-:- pred specialize_builtin(higher_order_info::in, pred_id::in, proc_id::in,
- list(var)::in, maybe(call_unify_context)::in,
+:- pred specialize_special_pred(higher_order_info::in, pred_id::in,
+ proc_id::in, list(var)::in, maybe(call_unify_context)::in,
hlds_goal_expr::out) is semidet.
-specialize_builtin(Info0, CalledPred, _CalledProc, Args,
+specialize_special_pred(Info0, CalledPred, _CalledProc, Args,
MaybeContext, Goal) :-
Info0 = info(PredVars, _, _, _, _, ProcInfo, ModuleInfo, _, _),
proc_info_vartypes(ProcInfo, VarTypes),
@@ -1203,7 +1206,7 @@
pred_info_module(PredInfo0, PredModule),
globals__io_lookup_bool_option(very_verbose, VeryVerbose,
IOState0, IOState1),
- pred_info_arg_types(PredInfo0, Tvars, ExistQVars, Types),
+ pred_info_arg_types(PredInfo0, ArgTVarSet, ExistQVars, Types),
string__int_to_string(Arity, ArStr),
(
VeryVerbose = yes
@@ -1223,13 +1226,10 @@
string__int_to_string(NextHOid0, IdStr),
NextHOid is NextHOid0 + 1,
string__append_list([Name0, "__ho", IdStr], PredName),
- pred_info_typevarset(PredInfo0, TypeVars),
+ pred_info_typevarset(PredInfo0, TypeVarSet),
pred_info_context(PredInfo0, Context),
pred_info_get_markers(PredInfo0, MarkerList),
pred_info_get_goal_type(PredInfo0, GoalType),
- % When we start specialising class method calls, this
- % context will need to be updated -dgj?
- % XXX Is this needed by anything after here? -stayl
pred_info_get_class_context(PredInfo0, ClassContext),
Name = qualified(PredModule, PredName),
varset__init(EmptyVarSet),
@@ -1240,10 +1240,10 @@
% hlds dumps if it's filled in.
ClausesInfo = clauses_info(EmptyVarSet, EmptyVarTypes,
EmptyVarTypes, [], []),
- pred_info_init(PredModule, Name, Arity, Tvars, ExistQVars,
+ pred_info_init(PredModule, Name, Arity, ArgTVarSet, ExistQVars,
Types, true, Context, ClausesInfo, local, MarkerList, GoalType,
PredOrFunc, ClassContext, EmptyProofs, PredInfo1),
- pred_info_set_typevarset(PredInfo1, TypeVars, PredInfo2),
+ pred_info_set_typevarset(PredInfo1, TypeVarSet, PredInfo2),
pred_info_procedures(PredInfo2, Procs0),
next_mode_id(Procs0, no, NewProcId),
predicate_table_insert(PredTable0, PredInfo2, NewPredId, PredTable),
@@ -1324,7 +1324,7 @@
ModuleInfo0, ModuleInfo) :-
NewPred = new_pred(NewPredProcId, OldPredProcId, Caller, _Name,
HOArgs0, CallArgs, ExtraTypeInfoArgs, CallerArgTypes0,
- ExtraTypeInfoTypes, _),
+ ExtraTypeInfoTypes0, _),
OldPredProcId = proc(OldPredId, OldProcId),
module_info_pred_proc_info(ModuleInfo0, OldPredId, OldProcId,
@@ -1337,7 +1337,8 @@
pred_info_procedures(NewPredInfo0, NewProcs0),
proc_info_headvars(NewProcInfo0, HeadVars0),
proc_info_argmodes(NewProcInfo0, ArgModes0),
- pred_info_arg_types(NewPredInfo0, TypeVarSet0, ExistQVars0, _),
+ pred_info_arg_types(NewPredInfo0, _, ExistQVars0, _),
+ pred_info_typevarset(NewPredInfo0, TypeVarSet0),
Caller = proc(CallerPredId, CallerProcId),
module_info_pred_proc_info(ModuleInfo0, CallerPredId, CallerProcId,
@@ -1365,12 +1366,15 @@
apply_rec_substitution_to_type_map(VarTypes1, TypeSubn, VarTypes2),
( ( ExistQVars = [] ; map__is_empty(TypeSubn) ) ->
- HOArgs = HOArgs0
+ HOArgs = HOArgs0,
+ ExtraTypeInfoTypes = ExtraTypeInfoTypes0
;
% If there are existentially quantified variables in the
% callee we may need to bind type variables in the caller.
list__map(substitute_higher_order_arg(TypeSubn),
- HOArgs0, HOArgs)
+ HOArgs0, HOArgs),
+ term__apply_rec_substitution_to_list(ExtraTypeInfoTypes0,
+ TypeSubn, ExtraTypeInfoTypes)
),
proc_info_set_vartypes(NewProcInfo0, VarTypes2, NewProcInfo1),
@@ -1394,38 +1398,40 @@
map__det_insert(PredVarMap0, NewPredProcId, PredVars, PredVarMap),
NewPredMap1 = new_preds(A, PredVarMap),
- % Fix up the typeinfo_varmap.
+ %
+ % Fix up the typeinfo_varmap.
+ %
proc_info_typeinfo_varmap(NewProcInfo3, TypeInfoVarMap0),
- ( map__is_empty(CallerTypeInfoVarMap0) ->
- % Optimize for a non-polymorphic caller.
- TypeInfoVarMap = TypeInfoVarMap0
- ;
- % Restrict the caller's typeinfo_varmap
- % down onto the arguments of the call.
- map__to_assoc_list(CallerTypeInfoVarMap0, TypeInfoAL0),
- list__filter(lambda([TVarAndLocn::in] is semidet, (
- TVarAndLocn = _ - Locn,
- type_info_locn_var(Locn, LocnVar),
- map__contains(VarRenaming, LocnVar)
- )), TypeInfoAL0, TypeInfoAL),
- map__from_assoc_list(TypeInfoAL, CallerTypeInfoVarMap1),
-
- % The type renaming doesn't rename type
- % variables in the caller.
- map__init(EmptyTypeRenaming),
- apply_substitutions_to_var_map(CallerTypeInfoVarMap1,
- EmptyTypeRenaming, TypeSubn, VarRenaming,
- CallerTypeInfoVarMap),
- % The variable renaming doesn't rename variables in the callee.
- map__init(EmptyVarRenaming),
- apply_substitutions_to_var_map(TypeInfoVarMap0, TypeRenaming,
- TypeSubn, EmptyVarRenaming, TypeInfoVarMap1),
- map__merge(TypeInfoVarMap1, CallerTypeInfoVarMap,
- TypeInfoVarMap)
- ),
+
+ % Restrict the caller's typeinfo_varmap
+ % down onto the arguments of the call.
+ map__to_assoc_list(CallerTypeInfoVarMap0, TypeInfoAL0),
+ list__filter(lambda([TVarAndLocn::in] is semidet, (
+ TVarAndLocn = _ - Locn,
+ type_info_locn_var(Locn, LocnVar),
+ map__contains(VarRenaming, LocnVar)
+ )), TypeInfoAL0, TypeInfoAL),
+ map__from_assoc_list(TypeInfoAL, CallerTypeInfoVarMap1),
+
+ % The type renaming doesn't rename type variables in the caller.
+ map__init(EmptyTypeRenaming),
+ apply_substitutions_to_var_map(CallerTypeInfoVarMap1,
+ EmptyTypeRenaming, TypeSubn, VarRenaming,
+ CallerTypeInfoVarMap),
+ % The variable renaming doesn't rename variables in the callee.
+ map__init(EmptyVarRenaming),
+ apply_substitutions_to_var_map(TypeInfoVarMap0, TypeRenaming,
+ TypeSubn, EmptyVarRenaming, TypeInfoVarMap1),
+ map__merge(TypeInfoVarMap1, CallerTypeInfoVarMap,
+ TypeInfoVarMap),
+
proc_info_set_typeinfo_varmap(NewProcInfo3,
TypeInfoVarMap, NewProcInfo4),
+ %
+ % Fix up the argument vars, types and modes.
+ %
+
in_mode(InMode),
list__length(ExtraTypeInfoVars, NumTypeInfos),
list__duplicate(NumTypeInfos, InMode, ExtraTypeInfoModes),
@@ -1440,7 +1446,31 @@
ExistQVars, ArgTypes, NewPredInfo1),
pred_info_set_typevarset(NewPredInfo1, TypeVarSet, NewPredInfo2),
- proc_info_goal(NewProcInfo6, Goal1),
+ %
+ % Fix up the typeclass_info_varmap. Apply the substitutions
+ % to the types in the original typeclass_info_varmap, then add in
+ % the extra typeclass_info variables required by --typeinfo-liveness.
+ %
+ proc_info_typeclass_info_varmap(NewProcInfo6, TCVarMap0),
+ apply_substitutions_to_typeclass_var_map(TCVarMap0, TypeRenaming,
+ TypeSubn, EmptyVarRenaming, TCVarMap1),
+ add_extra_typeclass_infos(HeadVars, ArgTypes, TCVarMap1, TCVarMap),
+ proc_info_set_typeclass_info_varmap(NewProcInfo6,
+ TCVarMap, NewProcInfo7),
+
+ %
+ % Find the new class context by searching the argument types
+ % for typeclass_infos (the corresponding constraint is encoded
+ % in the type of a typeclass_info).
+ %
+ find_class_context(ModuleInfo0, ArgTypes, ArgModes,
+ [], [], ClassContext),
+ pred_info_set_class_context(NewPredInfo2, ClassContext, NewPredInfo3),
+
+ %
+ % Run traverse_goal to specialize based on the new information.
+ %
+ proc_info_goal(NewProcInfo7, Goal1),
HOInfo0 = info(PredVars, Requests0, NewPredMap1, NewPredProcId,
NewPredInfo2, NewProcInfo6, ModuleInfo0, Params, unchanged),
traverse_goal_0(Goal1, Goal2, HOInfo0,
@@ -1448,17 +1478,22 @@
goal_size(Goal2, GoalSize),
map__set(GoalSizes0, NewPredId, GoalSize, GoalSizes1),
- proc_info_varset(NewProcInfo6, Varset6),
- implicitly_quantify_clause_body(HeadVars, Goal2, Varset6, VarTypes6,
+ %
+ % Requantify and recompute instmap deltas.
+ %
+ proc_info_varset(NewProcInfo7, Varset7),
+ proc_info_vartypes(NewProcInfo7, VarTypes7),
+ implicitly_quantify_clause_body(HeadVars, Goal2, Varset7, VarTypes7,
Goal3, Varset, VarTypes, _),
proc_info_get_initial_instmap(NewProcInfo3, ModuleInfo0, InstMap0),
recompute_instmap_delta(no, Goal3, Goal4, InstMap0,
ModuleInfo0, ModuleInfo1),
- proc_info_set_vartypes(NewProcInfo6, VarTypes, NewProcInfo7),
+
proc_info_set_goal(NewProcInfo7, Goal4, NewProcInfo8),
- proc_info_set_varset(NewProcInfo8, Varset, NewProcInfo),
+ proc_info_set_varset(NewProcInfo8, Varset, NewProcInfo9),
+ proc_info_set_vartypes(NewProcInfo9, VarTypes, NewProcInfo),
map__det_insert(NewProcs0, NewProcId, NewProcInfo, NewProcs),
- pred_info_set_procedures(NewPredInfo2, NewProcs, NewPredInfo),
+ pred_info_set_procedures(NewPredInfo3, NewProcs, NewPredInfo),
map__det_update(Preds0, NewPredId, NewPredInfo, Preds),
predicate_table_set_preds(PredTable0, Preds, PredTable),
module_info_set_predicate_table(ModuleInfo1, PredTable, ModuleInfo2),
@@ -1548,7 +1583,7 @@
%-----------------------------------------------------------------------------%
% Substitute the types in a higher_order_arg.
-:- pred substitute_higher_order_arg(substitution::in, higher_order_arg::in,
+:- pred substitute_higher_order_arg(tsubst::in, higher_order_arg::in,
higher_order_arg::out) is det.
substitute_higher_order_arg(Subn, HOArg0, HOArg) :-
@@ -1560,6 +1595,102 @@
CurriedHOArgs0, CurriedHOArgs),
HOArg = higher_order_arg(A, B, C, D,
CurriedArgTypes, CurriedHOArgs).
+
+%-----------------------------------------------------------------------------%
+
+ % Collect the list class_constraints from the list of argument types.
+ % The typeclass_info for universal constraints is input, output for
+ % existential constraints.
+:- pred find_class_context(module_info::in, list(type)::in, list(mode)::in,
+ list(class_constraint)::in, list(class_constraint)::in,
+ class_constraints::out) is det.
+
+find_class_context(_, [], [], Univ0, Exist0, Constraints) :-
+ list__reverse(Univ0, Univ),
+ list__reverse(Exist0, Exist),
+ Constraints = constraints(Univ, Exist).
+find_class_context(_, [], [_|_], _, _, _) :-
+ error("higher_order:find_class_context").
+find_class_context(_, [_|_], [], _, _, _) :-
+ error("higher_order:find_class_context").
+find_class_context(ModuleInfo, [Type | Types], [Mode | Modes],
+ Univ0, Exist0, Constraints) :-
+ ( polymorphism__typeclass_info_class_constraint(Type, Constraint) ->
+ ( mode_is_input(ModuleInfo, Mode) ->
+ maybe_add_constraint(Univ0, Constraint, Univ),
+ Exist = Exist0
+ ;
+ maybe_add_constraint(Exist0, Constraint, Exist),
+ Univ = Univ0
+ )
+ ;
+ Univ = Univ0,
+ Exist = Exist0
+ ),
+ find_class_context(ModuleInfo, Types, Modes, Univ, Exist, Constraints).
+
+:- pred maybe_add_constraint(list(class_constraint)::in,
+ class_constraint::in, list(class_constraint)::out) is det.
+
+maybe_add_constraint(Constraints0, Constraint0, Constraints) :-
+ Constraint0 = constraint(ClassName, Types0),
+ strip_term_contexts(Types0, Types),
+ Constraint = constraint(ClassName, Types),
+ (
+ % Remove duplicates
+ \+ list__member(Constraint, Constraints0),
+
+ % A constraint says nothing if the types are all ground.
+ list__member(Type, Types),
+ \+ term__is_ground(Type)
+ ->
+ Constraints = [Constraint | Constraints0]
+ ;
+ Constraints = Constraints0
+ ).
+
+%-----------------------------------------------------------------------------%
+
+ % Make sure that the typeclass_infos required by `--typeinfo-liveness'
+ % are in the typeclass_info_varmap.
+:- pred add_extra_typeclass_infos(list(var)::in, list(type)::in,
+ map(class_constraint, var)::in,
+ map(class_constraint, var)::out) is det.
+
+add_extra_typeclass_infos(Vars, Types, TCVarMap0, TCVarMap) :-
+ ( add_extra_typeclass_infos_2(Vars, Types, TCVarMap0, TCVarMap1) ->
+ TCVarMap = TCVarMap1
+ ;
+ error("higher_order:add_extra_typeclass_infos")
+ ).
+
+:- pred add_extra_typeclass_infos_2(list(var)::in, list(type)::in,
+ map(class_constraint, var)::in,
+ map(class_constraint, var)::out) is semidet.
+
+add_extra_typeclass_infos_2([], [], TCVarMap, TCVarMap).
+add_extra_typeclass_infos_2([Var | Vars], [Type0 | Types],
+ TCVarMap0, TCVarMap) :-
+ strip_term_context(Type0, Type),
+ (
+ polymorphism__typeclass_info_class_constraint(Type,
+ Constraint),
+ Constraint = constraint(_, ConstrainedTypes),
+
+ (
+ list__member(ConstrainedType, ConstrainedTypes),
+ \+ term__is_ground(ConstrainedType)
+ ->
+ true
+ ;
+ fail
+ )
+ ->
+ map__set(TCVarMap0, Constraint, Var, TCVarMap1)
+ ;
+ TCVarMap1 = TCVarMap0
+ ),
+ add_extra_typeclass_infos(Vars, Types, TCVarMap1, TCVarMap).
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
Index: options.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/options.m,v
retrieving revision 1.239
diff -u -t -u -r1.239 options.m
--- options.m 1998/08/10 06:56:41 1.239
+++ options.m 1998/09/08 00:04:16
@@ -203,6 +203,7 @@
; use_trans_opt_files
; transitive_optimization
; split_c_files
+ ; disable_opt_for_trace
% - HLDS
; inlining
; inline_simple
@@ -217,6 +218,8 @@
; optimize_unused_args
; intermod_unused_args
; optimize_higher_order
+ ; type_specialization
+ ; higher_order_size_limit
; optimize_constructor_last_call
; optimize_duplicate_calls
; constant_propagation
@@ -500,7 +503,8 @@
termination_norm - string("total"),
termination_error_limit - int(3),
termination_path_limit - int(256),
- split_c_files - bool(no)
+ split_c_files - bool(no),
+ disable_opt_for_trace - bool(yes)
]).
option_defaults_2(optimization_option, [
% Optimization options
@@ -533,6 +537,8 @@
optimize_unused_args - bool(no),
intermod_unused_args - bool(no),
optimize_higher_order - bool(no),
+ type_specialization - bool(no),
+ higher_order_size_limit - int(20),
optimize_constructor_last_call - bool(no),
optimize_dead_procs - bool(no),
deforestation - bool(no),
@@ -808,6 +814,7 @@
long_option("transitive-intermodule-optimisation",
transitive_optimization).
long_option("trans-intermod-opt", transitive_optimization).
+long_option("disable-opt-for-trace", disable_opt_for_trace).
% HLDS->HLDS optimizations
long_option("inlining", inlining).
@@ -835,6 +842,9 @@
long_option("intermod-unused-args", intermod_unused_args).
long_option("optimize-higher-order", optimize_higher_order).
long_option("optimise-higher-order", optimize_higher_order).
+long_option("type-specialization", type_specialization).
+long_option("type-specialisation", type_specialization).
+long_option("higher-order-size-limit", higher_order_size_limit).
long_option("optimise-constructor-last-call", optimize_constructor_last_call).
long_option("optimize-constructor-last-call", optimize_constructor_last_call).
long_option("optimize-dead-procs", optimize_dead_procs).
@@ -1144,7 +1154,7 @@
optimize_saved_vars - bool(yes),
optimize_unused_args - bool(yes),
optimize_higher_order - bool(yes),
- %deforestation - bool(yes), % causes an abort
+ deforestation - bool(yes),
constant_propagation - bool(yes),
optimize_repeat - int(4)
]).
@@ -1737,7 +1747,11 @@
"\tlink time, and intermediate disk space requirements,",
"\tbut in return reduces the size of the final",
"\texecutable, typically by about 10-20%.",
- "\tThis option is only useful with `--procs-per-c-function 1'."
+ "\tThis option is only useful with `--procs-per-c-function 1'.",
+ "--no-disable-opt-for-trace",
+ "\tEnabling tracing usually disables optimizations which could",
+ "\tmake it difficult to relate the trace to the source code.",
+ "\tThis option is useful when debugging those optimizations."
]).
:- pred options_help_hlds_hlds_optimization(io__state::di, io__state::uo)
@@ -1798,7 +1812,14 @@
"\t`--intermodule-optimization'.",
"--optimize-higher-order",
- "\tEnable specialization higher-order predicates.",
+ "\tEnable specialization of higher-order predicates.",
+ "--type-specialization",
+ "\tEnable specialization of polymorphic predicates.",
+ "--higher-order-size-limit",
+ "\tSet the maximum goal size of specialized versions created by",
+ "\t`--optimize-higher-order' and `--type-specialization'.",
+ "\tGoal size is measured as the number of calls, unifications",
+ "\tand branched goals.",
"--optimize-constructor-last-call",
"\tEnable the optimization of ""last"" calls that are followed by",
"\tconstructor application.",
===================================================================
--- polymorphism.m 1998/09/04 03:28:20 1.4
+++ polymorphism.m 1998/09/07 02:15:23
@@ -2675,9 +2675,9 @@
:- mode extract_type_info_2(in, in, in, in, in, out, out, in, in, in, out, out,
out) is det.
-extract_type_info_2(Type, TypeVar, TypeClassInfoVar, Index, ModuleInfo, Goals,
+extract_type_info_2(Type, _TypeVar, TypeClassInfoVar, Index, ModuleInfo, Goals,
TypeInfoVar, VarSet0, VarTypes0, TypeInfoLocns0,
- VarSet, VarTypes, TypeInfoLocns) :-
+ VarSet, VarTypes, TypeInfoLocns0) :-
% We need a tvarset to pass to get_pred_id_and_proc_id
varset__init(DummyTVarSet0),
@@ -2721,12 +2721,7 @@
[TypeClassInfoVar, IndexVar, TypeInfoVar],
not_builtin, no, ExtractTypeInfo) - GoalInfo,
- Goals = [IndexGoal, Call],
-
- % Update the location of the type_info so that we don't go to
- % the bother of re-extracting it.
- map__det_update(TypeInfoLocns0, TypeVar, type_info(TypeInfoVar),
- TypeInfoLocns).
+ Goals = [IndexGoal, Call].
%-----------------------------------------------------------------------------%
@@ -2852,10 +2847,10 @@
% class constraint about which a typeclass_info holds information.
% `type_util:type_to_type_id' treats it as a type variable.
construct_qualified_term(SymName, [], ClassNameTerm),
- construct_qualified_term(unqualified("constraint"),
+ mercury_private_builtin_module(PrivateBuiltin),
+ construct_qualified_term(qualified(PrivateBuiltin, "constraint"),
[ClassNameTerm | ArgTypes], ConstraintTerm),
- mercury_private_builtin_module(PrivateBuiltin),
construct_type(qualified(PrivateBuiltin, "typeclass_info") - 1,
[ConstraintTerm], DictionaryType).
@@ -2869,7 +2864,9 @@
% type_to_type_id fails on `constraint/n', so we use
% `sym_name_and_args' instead.
- sym_name_and_args(ConstraintTerm, unqualified("constraint"),
+ mercury_private_builtin_module(PrivateBuiltin),
+ sym_name_and_args(ConstraintTerm,
+ qualified(PrivateBuiltin, "constraint"),
[ClassNameTerm | ArgTypes]),
sym_name_and_args(ClassNameTerm, ClassName, []),
Constraint = constraint(ClassName, ArgTypes).
Index: type_util.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/type_util.m,v
retrieving revision 1.57
diff -u -t -u -r1.57 type_util.m
--- type_util.m 1998/08/04 02:14:13 1.57
+++ type_util.m 1998/09/08 00:32:52
@@ -157,15 +157,27 @@
map(var, type)).
:- mode apply_rec_substitution_to_type_map(in, in, out) is det.
- % Update a map from tvar to type_info_locn, using the type substititon
- % to rename tvars and a variable substition to rename vars.
+ % Update a map from tvar to type_info_locn, using the type renaming
+ % and substitution to rename tvars and a variable substition to
+ % rename vars.
%
% If tvar maps to a another type variable, we keep the new
% variable, if it maps to a type, we remove it from the map.
:- pred apply_substitutions_to_var_map(map(tvar, type_info_locn), tsubst,
- map(var, var), map(tvar, type_info_locn)).
-:- mode apply_substitutions_to_var_map(in, in, in, out) is det.
+ map(tvar, type), map(var, var), map(tvar, type_info_locn)).
+:- mode apply_substitutions_to_var_map(in, in, in, in, out) is det.
+
+ % Update a map from class_constraint to var, using the type renaming
+ % and substitution to rename tvars and a variable substition to
+ % rename vars.
+ %
+ % If the constraint no longer constraints any type variables,
+ % we remove it from the map.
+
+:- pred apply_substitutions_to_typeclass_var_map(map(class_constraint, var),
+ tsubst, map(tvar, type), map(var, var), map(class_constraint, var)).
+:- mode apply_substitutions_to_typeclass_var_map(in, in, in, in, out) is det.
:- pred apply_rec_subst_to_constraints(substitution, class_constraints,
class_constraints).
@@ -318,6 +317,14 @@
type_to_type_id(Type, SymName - Arity, Args) :-
sym_name_and_args(Type, SymName, Args1),
+ % `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.
@@ -702,54 +709,112 @@
%-----------------------------------------------------------------------------%
-apply_substitutions_to_var_map(VarMap0, TSubst, Subst, VarMap) :-
+apply_substitutions_to_var_map(VarMap0, TRenaming, TSubst, Subst, VarMap) :-
% optimize the common case of empty substitutions
- ( map__is_empty(Subst), map__is_empty(TSubst) ->
+ (
+ map__is_empty(Subst),
+ map__is_empty(TSubst),
+ map__is_empty(TRenaming)
+ ->
VarMap = VarMap0
;
map__keys(VarMap0, TVars),
map__init(NewVarMap),
- apply_substitutions_to_var_map_2(TVars, VarMap0, TSubst,
- Subst, NewVarMap, VarMap)
+ apply_substitutions_to_var_map_2(TVars, VarMap0,
+ TRenaming, TSubst, Subst, NewVarMap, VarMap)
).
:- pred apply_substitutions_to_var_map_2(list(var)::in, map(tvar,
- type_info_locn)::in, tsubst::in, map(var, var)::in,
- map(tvar, type_info_locn)::in,
+ type_info_locn)::in, tsubst::in, map(tvar, type)::in,
+ map(var, var)::in, map(tvar, type_info_locn)::in,
map(tvar, type_info_locn)::out) is det.
-apply_substitutions_to_var_map_2([], _VarMap0, _, _, NewVarMap, NewVarMap).
-apply_substitutions_to_var_map_2([TVar | TVars], VarMap0, TSubst, Subst,
- NewVarMap0, NewVarMap) :-
+apply_substitutions_to_var_map_2([], _VarMap0, _, _, _, NewVarMap, NewVarMap).
+apply_substitutions_to_var_map_2([TVar | TVars], VarMap0, TRenaming,
+ TSubst, VarSubst, NewVarMap0, NewVarMap) :-
map__lookup(VarMap0, TVar, Locn),
type_info_locn_var(Locn, Var),
-
- % find the new tvar, if there is one, otherwise just
- % create the old var as a type variable.
- ( map__search(TSubst, TVar, NewTerm0) ->
- NewTerm = NewTerm0
- ;
- type_util__var(NewTerm, TVar)
- ),
-
+
% find the new var, if there is one
- ( map__search(Subst, Var, NewVar0) ->
+ ( map__search(VarSubst, Var, NewVar0) ->
NewVar = NewVar0
;
NewVar = Var
),
type_info_locn_set_var(Locn, NewVar, NewLocn),
+ % find the new tvar, if there is one, otherwise just
+ % create the old var as a type variable.
+ (
+ map__search(TRenaming, TVar, NewTVar0)
+ ->
+ ( NewTVar0 = term__variable(NewTVar1) ->
+ NewTVar2 = NewTVar1
+ ;
+ % varset__merge_subst only returns var->var mappings,
+ % never var->term.
+ error(
+ "apply_substitution_to_var_map_2: weird type renaming")
+ )
+ ;
+ % The variable wasn't renamed.
+ NewTVar2 = TVar
+ ),
+
+ term__apply_rec_substitution(term__variable(NewTVar2),
+ TSubst, NewType),
+
% if the tvar is still a variable, insert it into the
% map with the new var.
- ( type_util__var(NewTerm, NewTVar) ->
- map__det_insert(NewVarMap0, NewTVar, NewLocn, NewVarMap1)
+ ( type_util__var(NewType, NewTVar) ->
+ % Don't abort if two old type variables
+ % map to the same new type variable.
+ map__set(NewVarMap0, NewTVar, NewLocn, NewVarMap1)
;
NewVarMap1 = NewVarMap0
),
- apply_substitutions_to_var_map_2(TVars, VarMap0, TSubst, Subst,
- NewVarMap1, NewVarMap).
+ apply_substitutions_to_var_map_2(TVars, VarMap0, TRenaming,
+ TSubst, VarSubst, NewVarMap1, NewVarMap).
+
+%-----------------------------------------------------------------------------%
+
+apply_substitutions_to_typeclass_var_map(VarMap0,
+ TRenaming, TSubst, Subst, VarMap) :-
+ map__to_assoc_list(VarMap0, VarAL0),
+ list__filter_map(
+ apply_substitutions_to_typeclass_var_map_2(TRenaming,
+ TSubst, Subst),
+ VarAL0, VarAL),
+ map__from_assoc_list(VarAL, VarMap).
+
+:- pred apply_substitutions_to_typeclass_var_map_2(tsubst, map(tvar, type),
+ map(var, var), pair(class_constraint, var),
+ pair(class_constraint, var)).
+:- mode apply_substitutions_to_typeclass_var_map_2(in, in,
+ in, in, out) is semidet.
+
+apply_substitutions_to_typeclass_var_map_2(TRenaming, TSubst, VarRenaming,
+ Constraint0 - Var0, Constraint - Var) :-
+ apply_subst_to_constraint(TRenaming, Constraint0, Constraint1),
+ apply_rec_subst_to_constraint(TSubst, Constraint1, Constraint),
+
+ % Check that the constraint still constrains some type variables.
+ Constraint = constraint(_, Types),
+ (
+ list__member(Type, Types),
+ \+ term__is_ground(Type)
+ ->
+ true
+ ;
+ fail
+ ),
+
+ ( map__search(VarRenaming, Var0, Var1) ->
+ Var = Var1
+ ;
+ Var = Var0
+ ).
%-----------------------------------------------------------------------------%
Index: runtime/mercury_ho_call.c
===================================================================
RCS file: /home/staff/zs/imp/mercury/runtime/mercury_ho_call.c,v
retrieving revision 1.11
diff -u -t -u -r1.11 mercury_ho_call.c
--- mercury_ho_call.c 1998/08/11 06:23:06 1.11
+++ mercury_ho_call.c 1998/09/07 07:07:33
@@ -262,7 +262,7 @@
if (num_arg_typeclass_infos < MR_CLASS_METHOD_CALL_INPUTS) {
/* copy to the left, from the left */
for (i = 1; i <= num_in_args; i++) {
- virtual_reg(i) =
+ virtual_reg(i + num_arg_typeclass_infos) =
virtual_reg(i + MR_CLASS_METHOD_CALL_INPUTS);
}
} else if (num_arg_typeclass_infos > MR_CLASS_METHOD_CALL_INPUTS) {
@@ -301,7 +301,7 @@
if (num_arg_typeclass_infos < MR_CLASS_METHOD_CALL_INPUTS) {
/* copy to the left, from the left */
for (i = 1; i <= num_in_args; i++) {
- virtual_reg(i) =
+ virtual_reg(i + num_arg_typeclass_infos) =
virtual_reg(i + MR_CLASS_METHOD_CALL_INPUTS);
}
} else if (num_arg_typeclass_infos > MR_CLASS_METHOD_CALL_INPUTS) {
Index: user_guide.texi
===================================================================
RCS file: /home/staff/zs/imp/mercury/doc/user_guide.texi,v
retrieving revision 1.133
diff -u -t -u -r1.133 user_guide.texi
--- user_guide.texi 1998/08/10 07:17:09 1.133
+++ user_guide.texi 1998/09/08 00:03:18
@@ -2390,6 +2390,12 @@
@samp{@var{MODULE}.split} target, i.e. type @samp{mmake foo.split}
rather than @samp{mmake foo}.
+ at sp 1
+ at item --no-disable-opt-for-trace
+Enabling tracing usually disables optimizations which could
+make it difficult to relate the trace to the source code.
+This option is useful when debugging those optimizations.
+
@end table
%-----------------------------------------------------------------------------%
% This tests four things:
%
% 1) Inclusion and ordering of extra typeinfos by higher_order.m
% with --typeinfo-liveness.
%
% 2) Updating of the typeclass_info_varmap for specialised version by
% higher_order.m.
%
% 3) Handling of semidet class_method_calls with argument typeclass_infos.
% The runtime of 7/9/1998 contained a bug where the arguments were not
% set up properly for this case.
% Symptom: runtime segfault.
%
% 4) Bugs in the introduction of type_info_from_typeclass_info - the
% typeinfo_varmap was being erroneously updated.
% Symptom: code generator abort.
%
% Unfortunately you really need to look at the HLDS dump to check 1) and 2).
% Compile this with options:
% --typeinfo-liveness --optimize-higher-order --no-type-specialization
% The --no-type-specialization is required to ensure that call_foldl
% remains polymorphic.
%
%-----------------------------------------------------------------------------%
:- module extra_typeinfo.
:- interface.
:- import_module io.
:- typeclass foo(T) where [
pred foo_pred(T::in) is semidet
].
:- pred call_foldl(list(list(T)),
list(list(U)), list(list(U))) <= foo(T).
:- mode call_foldl(in, in, out) is semidet.
:- pred main(io__state::di, io__state::uo) is det.
:- implementation.
:- import_module list, std_util.
main -->
{ L1 = [[1,2,3], [4,5,6]] },
io__write(L1),
{ L2 = [[7,8,9], [10,11,12]] },
io__write(L2),
( { call_foldl(L1, L2, L) } ->
io__write(L),
io__nl
;
io__write_string("failed\n")
).
% This calls foldl so that the original type variables in foldl
% get mapped to non-variable types, so higher_order.m needs to add
% extra argument type_infos for the type variables in the types
% of the specialised arguments.
call_foldl(In, Out0, Out) :-
Pred = lambda([Int::in] is semidet, Int = 2),
list_foldl(Pred, [2], In, _, Out0, Out).
:- pred list_foldl(pred(V), list(V), T, T, U, U) <= foo(T).
:- mode list_foldl((pred(in) is semidet), in, in, out, in, out) is semidet.
list_foldl(_P, [], T, T, U, U).
list_foldl(P, [V | Vs], T0, T, U0, U) :-
call(P, V),
foo_pred(T),
list_foldl(P, Vs, T0, T, U0, U).
:- instance foo(int) where [
pred(foo_pred/1) is nothing
].
:- instance foo(list(T)) <= foo(T) where [
pred(foo_pred/1) is test_first_foo
].
:- pred test_first_foo(list(T)) <= foo(T).
:- mode test_first_foo(in) is semidet.
test_first_foo([A | _]) :-
foo_pred(A).
:- pred nothing(int::in) is semidet.
nothing(_) :- semidet_succeed.
%-----------------------------------------------------------------------------%
More information about the developers
mailing list