[m-dev.] for review: fix tests/debugger/implied_instance
Simon Taylor
stayl at cs.mu.OZ.AU
Mon Apr 26 14:41:57 AEST 1999
Hi,
This is an addition to the diff Zoltan posted earlier
to avoid internal errors in tests/debugger/implied_instance.m.
This fixes the problem even if `--trace-optimized' is on.
Simon.
Estimated hours taken: 2
Fix a problem where type specialization resulted in type_info variables
in the generated code without a `TypeInfo_For...' prefix. This avoids
a segfault in the debugger when the simple name check on the variable
doesn't identify it as a type_info.
compiler/higher_order.m:
Check whether `--user-guided-type-specialization' is set
before performing some optimizations.
compiler/polymorphism.m:
Export predicates to make type_info and typeclass_info variables,
for use by hlds_pred.m.
Check for `type_ctor_info' as well as `type_info' in
`polymorphism__type_info_type', and return which was found.
compiler/hlds_pred.m:
Add use polymorphism__new_type{class}_info_var to create
type_info and typeclass_info variables with the correct
names in proc_info_create_var_from_type.
Remove some code duplication.
compiler/handle_options.m:
Tracing implies `--no-user-guided-type-specialization'.
Index: handle_options.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/handle_options.m,v
retrieving revision 1.73
diff -u -u -r1.73 handle_options.m
--- handle_options.m 1999/04/23 01:02:39 1.73
+++ handle_options.m 1999/04/26 02:13:51
@@ -335,6 +335,8 @@
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(user_guided_type_specialization,
+ bool(no)),
globals__io_set_option(deforestation, bool(no)),
globals__io_set_option(optimize_duplicate_calls,
bool(no)),
Index: higher_order.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/higher_order.m,v
retrieving revision 1.51
diff -u -u -r1.51 higher_order.m
--- higher_order.m 1999/04/23 01:02:40 1.51
+++ higher_order.m 1999/04/26 00:56:13
@@ -696,6 +696,9 @@
% which instance declarations are visible in the imported
% module, so we don't know which class constraints are
% redundant after type specialization.
+
+ Params = ho_params(_, _, UserTypeSpec, _, _),
+ UserTypeSpec = yes,
MaybeMethod = yes(Method),
proc_info_vartypes(CallerProcInfo0, VarTypes),
@@ -807,13 +810,15 @@
[InstanceConstraint | InstanceConstraints],
ConstraintNum, [ConstraintNumGoal, CallGoal | Goals],
[ArgTypeClassInfoVar | Vars], ProcInfo0, ProcInfo) :-
- polymorphism__build_typeclass_info_type(InstanceConstraint,
- ArgTypeClassInfoType),
- proc_info_create_var_from_type(ProcInfo0, ArgTypeClassInfoType,
- ArgTypeClassInfoVar, ProcInfo1),
- MaybeContext = no,
+ proc_info_varset(ProcInfo0, VarSet0),
+ proc_info_vartypes(ProcInfo0, VarTypes0),
+ polymorphism__new_typeclass_info_var(InstanceConstraint,
+ ArgTypeClassInfoVar, VarSet0, VarTypes0, VarSet1, VarTypes1),
+ proc_info_set_varset(ProcInfo0, VarSet1, ProcInfo1),
+ proc_info_set_vartypes(ProcInfo1, VarTypes1, ProcInfo2),
+
make_int_const_construction(ConstraintNum, ConstraintNumGoal,
- ConstraintNumVar, ProcInfo1, ProcInfo2),
+ ConstraintNumVar, ProcInfo2, ProcInfo3),
Args = [TypeClassInfoVar, ConstraintNumVar, ArgTypeClassInfoVar],
set__list_to_set(Args, NonLocals),
@@ -821,11 +826,12 @@
instmap_delta_insert(InstMapDelta0, ArgTypeClassInfoVar,
ground(shared, no), InstMapDelta),
goal_info_init(NonLocals, InstMapDelta, det, GoalInfo),
+ MaybeContext = no,
CallGoal = call(PredId, ProcId, Args, not_builtin,
MaybeContext, SymName) - GoalInfo,
get_arg_typeclass_infos(TypeClassInfoVar, PredId, ProcId, SymName,
InstanceConstraints, ConstraintNum + 1, Goals,
- Vars, ProcInfo2, ProcInfo).
+ Vars, ProcInfo3, ProcInfo).
:- pred construct_specialized_higher_order_call(module_info::in,
pred_id::in, proc_id::in, list(prog_var)::in, hlds_goal_info::in,
@@ -923,6 +929,7 @@
% Check whether any typeclass constraints
% now match an instance.
+ UserTypeSpec = yes,
pred_info_get_class_context(CalleePredInfo,
CalleeClassContext),
CalleeClassContext =
Index: hlds_pred.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/hlds_pred.m,v
retrieving revision 1.57
diff -u -u -r1.57 hlds_pred.m
--- hlds_pred.m 1998/12/06 23:43:21 1.57
+++ hlds_pred.m 1999/04/26 02:51:48
@@ -20,7 +20,7 @@
:- implementation.
:- import_module code_aux, goal_util, make_hlds, prog_util.
-:- import_module mode_util, type_util, options.
+:- import_module mode_util, type_util, options, polymorphism.
:- import_module int, string, require, assoc_list.
%-----------------------------------------------------------------------------%
@@ -1794,20 +1794,28 @@
proc_info_create_var_from_type(ProcInfo0, Type, NewVar, ProcInfo) :-
proc_info_varset(ProcInfo0, VarSet0),
proc_info_vartypes(ProcInfo0, VarTypes0),
- varset__new_var(VarSet0, NewVar, VarSet),
- map__det_insert(VarTypes0, NewVar, Type, VarTypes),
+
+ % Make sure `type_info' and `typeclass_info' variables
+ % are named correctly so the debugger doesn't get confused.
+ ( polymorphism__type_info_type(Type, TypeInfoType, TheType) ->
+ polymorphism__new_type_info_var(TheType, TypeInfoType, NewVar,
+ VarSet0, VarTypes0, VarSet, VarTypes)
+ ; polymorphism__typeclass_info_class_constraint(Type, Constraint) ->
+ polymorphism__new_typeclass_info_var(Constraint, NewVar,
+ VarSet0, VarTypes0, VarSet, VarTypes)
+ ;
+ varset__new_var(VarSet0, NewVar, VarSet),
+ map__det_insert(VarTypes0, NewVar, Type, VarTypes)
+ ),
+
proc_info_set_varset(ProcInfo0, VarSet, ProcInfo1),
proc_info_set_vartypes(ProcInfo1, VarTypes, ProcInfo).
proc_info_create_vars_from_types(ProcInfo0, Types, NewVars, ProcInfo) :-
- list__length(Types, NumVars),
- proc_info_varset(ProcInfo0, VarSet0),
- proc_info_vartypes(ProcInfo0, VarTypes0),
- varset__new_vars(VarSet0, NumVars, NewVars, VarSet),
- map__det_insert_from_corresponding_lists(VarTypes0,
- NewVars, Types, VarTypes),
- proc_info_set_varset(ProcInfo0, VarSet, ProcInfo1),
- proc_info_set_vartypes(ProcInfo1, VarTypes, ProcInfo).
+ list__map_foldl(
+ (pred(Type::in, Var::out, PInfo0::in, PInfo::out) is det :-
+ proc_info_create_var_from_type(PInfo0, Type, Var, PInfo)
+ ), Types, NewVars, ProcInfo0, ProcInfo).
%-----------------------------------------------------------------------------%
Index: polymorphism.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/polymorphism.m,v
retrieving revision 1.163
diff -u -u -r1.163 polymorphism.m
--- polymorphism.m 1999/04/23 01:02:57 1.163
+++ polymorphism.m 1999/04/26 04:37:55
@@ -308,7 +308,7 @@
:- interface.
:- import_module hlds_goal, hlds_module, hlds_pred, prog_data, special_pred.
-:- import_module io, list, term.
+:- import_module io, map, list, term.
:- pred polymorphism__process_module(module_info, module_info,
io__state, io__state).
@@ -323,6 +323,17 @@
term__context, list(prog_var), list(hlds_goal), poly_info, poly_info).
:- mode polymorphism__make_type_info_vars(in, in, in, out, out, in, out) is det.
+% Given a class constraint, create a variable to hold the typeclass_info
+% for that constraint.
+:- pred polymorphism__new_typeclass_info_var(class_constraint, prog_var,
+ prog_varset, map(prog_var, type), prog_varset, map(prog_var, type)).
+:- mode polymorphism__new_typeclass_info_var(in, out, in, in, out, out) is det.
+
+% Given a type create a variable for the type_info for that type.
+:- pred polymorphism__new_type_info_var(type, type_info_type, prog_var,
+ prog_varset, map(prog_var, type), prog_varset, map(prog_var, type)).
+:- mode polymorphism__new_type_info_var(in, in, out, in, in, out, out) is det.
+
:- type poly_info.
% Extract some fields from a pred_info and proc_info for use
@@ -359,11 +370,16 @@
class_constraint).
:- mode polymorphism__typeclass_info_class_constraint(in, out) is semidet.
+:- type type_info_type
+ ---> type_info
+ ; type_ctor_info
+ .
+
% From the type of a type_info variable find the type about which
% the type_info carries information, failing if the type is not a
% valid type_info type.
-:- pred polymorphism__type_info_type((type), (type)).
-:- mode polymorphism__type_info_type(in, out) is semidet.
+:- pred polymorphism__type_info_type((type), type_info_type, (type)).
+:- mode polymorphism__type_info_type(in, out, out) is semidet.
% Succeed if the predicate is one of the predicates defined in
% library/private_builtin.m to extract type_infos or typeclass_infos
@@ -1870,10 +1886,8 @@
% First create a variable to hold the new
% typeclass_info
- unqualify_name(ClassName, ClassNameString),
- polymorphism__new_typeclass_info_var(VarSet0,
- VarTypes0, Constraint, ClassNameString,
- Var, VarSet1, VarTypes1),
+ polymorphism__new_typeclass_info_var(Constraint, Var,
+ VarSet0, VarTypes0, VarSet1, VarTypes1),
MaybeVar = yes(Var),
@@ -2006,11 +2020,8 @@
list__append(ArgTypeClassInfoVars, ArgSuperClassVars, ArgVars0),
list__append(ArgVars0, ArgTypeInfoVars, ArgVars),
- ClassId = class_id(ClassName, _Arity),
-
- unqualify_name(ClassName, ClassNameString),
- polymorphism__new_typeclass_info_var(VarSet0, VarTypes0,
- Constraint, ClassNameString, BaseVar, VarSet1, VarTypes1),
+ polymorphism__new_typeclass_info_var(Constraint, BaseVar,
+ VarSet0, VarTypes0, VarSet1, VarTypes1),
% XXX I don't think we actually need to carry the module name
% around.
@@ -2046,8 +2057,8 @@
TypeClassInfoTerm = functor(NewConsId, NewArgVars),
% introduce a new variable
- polymorphism__new_typeclass_info_var(VarSet1, VarTypes1,
- Constraint, ClassNameString, NewVar, VarSet, VarTypes),
+ polymorphism__new_typeclass_info_var(Constraint, NewVar,
+ VarSet1, VarTypes1, VarSet, VarTypes),
% create the construction unification to initialize the
% variable
@@ -2194,7 +2205,7 @@
Var = HeadVar,
Info = Info0
;
- polymorphism__new_type_info_var(Type, "type_info",
+ polymorphism__new_type_info_var(Type, type_info,
Var, Info0, Info1),
map__det_insert(TypeInfoMap0, TVar, type_info(Var),
TypeInfoMap),
@@ -2382,7 +2393,7 @@
VarSet1 = VarSet0
),
polymorphism__init_type_info_var(Type,
- TypeInfoArgVars, "type_info",
+ TypeInfoArgVars, type_info,
VarSet1, VarTypes1, Var, TypeInfoGoal,
VarSet, VarTypes),
list__append(TypeInfoArgGoals, [TypeInfoGoal], ExtraGoals1),
@@ -2504,22 +2515,24 @@
% These unifications WILL lead to the creation of cells on the
% heap at runtime.
-:- pred polymorphism__init_type_info_var(type, list(prog_var), string,
+:- pred polymorphism__init_type_info_var(type, list(prog_var), type_info_type,
prog_varset, map(prog_var, type), prog_var, hlds_goal, prog_varset,
map(prog_var, type)).
:- mode polymorphism__init_type_info_var(in, in, in, in, in, out, out, out, out)
is det.
-polymorphism__init_type_info_var(Type, ArgVars, Symbol, VarSet0, VarTypes0,
- TypeInfoVar, TypeInfoGoal, VarSet, VarTypes) :-
+polymorphism__init_type_info_var(Type, ArgVars, TypeInfoType,
+ VarSet0, VarTypes0, TypeInfoVar, TypeInfoGoal,
+ VarSet, VarTypes) :-
mercury_private_builtin_module(PrivateBuiltin),
+ polymorphism__type_info_type_name(TypeInfoType, Symbol),
ConsId = cons(qualified(PrivateBuiltin, Symbol), 1),
TypeInfoTerm = functor(ConsId, ArgVars),
% introduce a new variable
- polymorphism__new_type_info_var(Type, Symbol, VarSet0, VarTypes0,
- TypeInfoVar, VarSet, VarTypes),
+ polymorphism__new_type_info_var(Type, TypeInfoType, TypeInfoVar,
+ VarSet0, VarTypes0, VarSet, VarTypes),
% create the construction unification to initialize the variable
UniMode = (free - ground(shared, no) ->
@@ -2575,8 +2588,8 @@
TypeInfoTerm = functor(ConsId, []),
% introduce a new variable
- polymorphism__new_type_info_var(Type, "type_ctor_info",
- VarSet0, VarTypes0, TypeCtorInfoVar, VarSet, VarTypes),
+ polymorphism__new_type_info_var(Type, type_ctor_info,
+ TypeCtorInfoVar, VarSet0, VarTypes0, VarSet, VarTypes),
% create the construction unification to initialize the variable
Unification = construct(TypeCtorInfoVar, ConsId, [], []),
@@ -2604,7 +2617,7 @@
polymorphism__make_head_vars([], _, []) --> [].
polymorphism__make_head_vars([TypeVar|TypeVars], TypeVarSet, TypeInfoVars) -->
{ Type = term__variable(TypeVar) },
- polymorphism__new_type_info_var(Type, "type_info", Var),
+ polymorphism__new_type_info_var(Type, type_info, Var),
( { varset__search_name(TypeVarSet, TypeVar, TypeVarName) } ->
=(Info0),
{ poly_info_get_varset(Info0, VarSet0) },
@@ -2617,26 +2630,19 @@
{ TypeInfoVars = [Var | TypeInfoVars1] },
polymorphism__make_head_vars(TypeVars, TypeVarSet, TypeInfoVars1).
-
-:- pred polymorphism__new_type_info_var(type, string, prog_var,
+:- pred polymorphism__new_type_info_var(type, type_info_type, prog_var,
poly_info, poly_info).
:- mode polymorphism__new_type_info_var(in, in, out, in, out) is det.
polymorphism__new_type_info_var(Type, Symbol, Var, Info0, Info) :-
poly_info_get_varset(Info0, VarSet0),
poly_info_get_var_types(Info0, VarTypes0),
- polymorphism__new_type_info_var(Type, Symbol, VarSet0, VarTypes0,
- Var, VarSet, VarTypes),
+ polymorphism__new_type_info_var(Type, Symbol, Var, VarSet0, VarTypes0,
+ VarSet, VarTypes),
poly_info_set_varset_and_types(VarSet, VarTypes, Info0, Info).
-
-:- pred polymorphism__new_type_info_var(type, string, prog_varset,
- map(prog_var, type), prog_var, prog_varset,
- map(prog_var, type)).
-:- mode polymorphism__new_type_info_var(in, in, in, in, out, out, out) is det.
-
-polymorphism__new_type_info_var(Type, Symbol, VarSet0, VarTypes0,
- Var, VarSet, VarTypes) :-
+polymorphism__new_type_info_var(Type, TypeInfoType, Var, VarSet0, VarTypes0,
+ VarSet, VarTypes) :-
% introduce new variable
varset__new_var(VarSet0, Var, VarSet1),
term__var_to_int(Var, VarNum),
@@ -2644,9 +2650,17 @@
string__append("TypeInfo_", VarNumStr, Name),
varset__name_var(VarSet1, Var, Name, VarSet),
mercury_private_builtin_module(PrivateBuiltin),
+ polymorphism__type_info_type_name(TypeInfoType, Symbol),
construct_type(qualified(PrivateBuiltin, Symbol) - 1, [Type],
- UnifyPredType),
- map__set(VarTypes0, Var, UnifyPredType, VarTypes).
+ TypeInfoVarType),
+ map__set(VarTypes0, Var, TypeInfoVarType, VarTypes).
+
+:- pred polymorphism__type_info_type_name(type_info_type, string).
+:- mode polymorphism__type_info_type_name(in, out) is det.
+:- mode polymorphism__type_info_type_name(out, in) is semidet.
+
+polymorphism__type_info_type_name(type_info, "type_info").
+polymorphism__type_info_type_name(type_ctor_info, "type_ctor_info").
%---------------------------------------------------------------------------%
@@ -2703,8 +2717,8 @@
polymorphism__make_count_var(Index, VarSet0, VarTypes0, IndexVar,
IndexGoal, VarSet1, VarTypes1),
- polymorphism__new_type_info_var(Type, "type_info", VarSet1, VarTypes1,
- TypeInfoVar, VarSet, VarTypes),
+ polymorphism__new_type_info_var(Type, type_info, TypeInfoVar,
+ VarSet1, VarTypes1, VarSet, VarTypes),
% Make the goal info for the call.
% `type_info_from_typeclass_info' does not require an extra
@@ -2762,12 +2776,10 @@
ClassDefn = hlds_class_defn(SuperClasses, _, _, _, _),
list__length(SuperClasses, NumSuperClasses),
- unqualify_name(ClassName0, ClassName),
-
% Make a new variable to contain the dictionary for this
% typeclass constraint
- polymorphism__new_typeclass_info_var(VarSet0, VarTypes0, C,
- ClassName, Var, VarSet1, VarTypes1),
+ polymorphism__new_typeclass_info_var(C, Var,
+ VarSet0, VarTypes0, VarSet1, VarTypes1),
ExtraHeadVars1 = [Var | ExtraHeadVars0],
% Find all the type variables in the constraint, and remember
@@ -2819,17 +2831,14 @@
:- pred is_pair(pair(_, _)::in) is det.
is_pair(_).
-:- pred polymorphism__new_typeclass_info_var(prog_varset, map(prog_var, type),
- class_constraint, string, prog_var,
- prog_varset, map(prog_var, type)).
-:- mode polymorphism__new_typeclass_info_var(in, in,
- in, in, out, out, out) is det.
+polymorphism__new_typeclass_info_var(Constraint, Var, VarSet0, VarTypes0,
+ VarSet, VarTypes) :-
+ Constraint = constraint(ClassName0, _),
+ unqualify_name(ClassName0, ClassName),
-polymorphism__new_typeclass_info_var(VarSet0, VarTypes0, Constraint,
- ClassString, Var, VarSet, VarTypes) :-
% introduce new variable
varset__new_var(VarSet0, Var, VarSet1),
- string__append("TypeClassInfo_for_", ClassString, Name),
+ string__append("TypeClassInfo_for_", ClassName, Name),
varset__name_var(VarSet1, Var, Name, VarSet),
polymorphism__build_typeclass_info_type(Constraint, DictionaryType),
@@ -2866,11 +2875,12 @@
sym_name_and_args(ClassNameTerm, ClassName, []),
Constraint = constraint(ClassName, ArgTypes).
-polymorphism__type_info_type(TypeInfoType, Type) :-
+polymorphism__type_info_type(TypeInfoVarType, TypeInfoType, Type) :-
mercury_private_builtin_module(PrivateBuiltin),
- type_to_type_id(TypeInfoType,
- qualified(PrivateBuiltin, "type_info") - 1,
- [Type]).
+ type_to_type_id(TypeInfoVarType,
+ qualified(PrivateBuiltin, TypeInfoTypeName) - 1,
+ [Type]),
+ polymorphism__type_info_type_name(TypeInfoType, TypeInfoTypeName).
%---------------------------------------------------------------------------%
--------------------------------------------------------------------------
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