for review: making the debugger work on typeclasses
Zoltan Somogyi
zs at cs.mu.OZ.AU
Sat Oct 17 20:11:16 AEST 1998
This is for Tyson.
Estimated hours taken: 40
Extend the layout scheme to handle typeinfos inside typeclass infos,
and thus enable the debugger (and later native gc) to work with programs
that use type classes and existential types.
compiler/llds.m:
Change the data structure that holds information about the locations
of the typeinfo variables of the tvars active at call return sites
from set(pair(tvar, lval)) to map(tvar, set(layout_locn)).
The change from set to map avoids the possibility of inadvertently
duplicating the info for a give type variable.
The change to explicitly keep a set of locations in which the typeinfo
var may be found allows us to use set intersection on those sets if
(a) the program point may be reached via more than one path, and
(b) not all paths have the same sets. Both of these can happen in
programs that use type classes.
The change from lval to layout_locn (which encodes either an lval,
or an lval representing a typeclass info and an (indirect) offset
inside that typeclass info) is necessary support programs with
type classes.
compiler/continuation_info.m:
Change the data structure that holds information about the locations
of the typeinfo variables of the tvars active at a particular program
point the same way and for the same reasons as in llds.m.
Take set intersections of typeinfo var locations whenever we find
multiple live variable info records for the same label.
compiler/call_gen.m:
Delay the construction of the return live variable information
until the code generator state has been updated to reflect where
things will be on return, instead of trying to cobble up this
info into the code generator state that reflects the point just
before the call. Apart from being cleaner, this is necessary
to avoid compiler aborts for programs that use existential types.
The old compiler could not find the typeinfos of any existentially
quantified type vars, since they do not exist before the call.
compiler/code_info.m:
Rewrite and generalize the code for generating live value information.
compiler/trace.m:
Remove the specialized code for generating live value information;
call code_info instead.
compiler/stack_layout.m:
Pick one of several possible locations for a typeinfo var.
Generate the new indirect layout location descriptions.
Reduce the number of tag bits used to describe different kinds of
lvals, to leave more room for the indirect information.
compiler/*.m:
Conform to the above data structure changes.
compiler/hlds_pred.m:
Clarify the documentation of type_info_locn.
compiler/llds_out.m:
Use map (and thus tree234) instead of bintree_set to represent
the set of things declared so far. With --trace deep, the binary
trees of items were almost always sticks. This change reduces
the time spent in writing out typecheck.c with --trace deep
from 70 seconds to 18 seconds (on cyclone).
runtime/mercury_stack_layout.h:
Update the section that deals with MR_Live_Lval to take
indirect typeinfo locations into account.
runtime/mercury_layout_util.c:
Handle indirect typeinfo locations when interpreting layout structures.
runtime/mercury_layout_util.c:
trace/mercury_trace_internal.c:
Ignore variables whose names start with TypeClassInfo.
runtime/mercury_accurate_gc.c:
runtime/mercury_agc_debug.c:
Add markers to remind Tyson to handle indirect typeinfo locations.
library/map.m:
Add new predicates map__intersect and map__union for use by the
new code in the compiler, and by others.
tests/debugger/implied_instance.{m,inp,exp}:
tests/debugger/multi_paramster.{m,inp,exp}:
tests/debugger/existential_type_classes.{m,inp,exp}:
Copies of the tests in tests/hard_coded/typeclasses, modified to
avoid or delay I/O, so that the calls to I/O preds that may or may
not be traced to do not affect the output.
tests/debugger/Mmakefile:
Add the new test cases.
Remove references to the *_lib variants of the old test cases.
They are not necessary if I/O is delayed until after the last
reported trace event.
tests/hard_coded/typeclasses/Mmakefile:
Remove --trace deep from existential_type_classes, since that
aspect of the test case is now covered in the debugger directory.
Zoltan.
cvs diff: Diffing .
cvs diff: Diffing bindist
cvs diff: Diffing boehm_gc
cvs diff: Diffing boehm_gc/Mac_files
cvs diff: Diffing boehm_gc/cord
cvs diff: Diffing boehm_gc/cord/private
cvs diff: Diffing boehm_gc/include
cvs diff: Diffing boehm_gc/include/private
cvs diff: Diffing browser
cvs diff: Diffing bytecode
cvs diff: Diffing bytecode/test
cvs diff: Diffing compiler
Index: compiler/call_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/call_gen.m,v
retrieving revision 1.124
diff -u -u -r1.124 call_gen.m
--- call_gen.m 1998/10/16 06:16:53 1.124
+++ call_gen.m 1998/10/16 10:17:38
@@ -72,41 +72,47 @@
call_gen__generate_call(CodeModel, PredId, ModeId, Arguments, GoalInfo, Code)
-->
- % find out which arguments are input and which are output
+ % Find out which arguments are input and which are output.
code_info__get_pred_proc_arginfo(PredId, ModeId, ArgInfo),
{ assoc_list__from_corresponding_lists(Arguments, ArgInfo, ArgsInfos) },
- % save the known variables on the stack, except those
- % generated by this call
+ % Save the known variables on the stack, except those
+ % generated by this call.
{ call_gen__select_out_args(ArgsInfos, OutArgs) },
call_gen__save_variables(OutArgs, SaveCode),
- % save possibly unknown variables on the stack as well
+ % Save possibly unknown variables on the stack as well
% if they may be needed on backtracking, and figure out the
- % call model
+ % call model.
call_gen__prepare_for_call(CodeModel, FlushCode, CallModel, _, _),
- % move the input arguments to their registers
+ % Move the input arguments to their registers.
code_info__setup_call(ArgsInfos, caller, SetupCode),
trace__prepare_for_call(TraceCode),
- % figure out what locations are live at the call point,
- % for use by the value numbering optimization
+ % Figure out what locations are live at the call point,
+ % for use by the value numbering optimization.
{ call_gen__input_args(ArgInfo, InputArguments) },
call_gen__generate_call_livevals(OutArgs, InputArguments, LiveCode),
- % figure out what variables will be live at the return point,
- % and where, for use in the accurate garbage collector
+ % Figure out what variables will be live at the return point,
+ % and where, for use in the accurate garbage collector, and
+ % in the debugger.
code_info__get_instmap(InstMap),
{ goal_info_get_instmap_delta(GoalInfo, InstMapDelta) },
{ instmap__apply_instmap_delta(InstMap, InstMapDelta,
AfterCallInstMap) },
{ call_gen__output_arg_locs(ArgsInfos, OutputArguments) },
+ % We must update the code generator state to reflect
+ % the situation after the call before building
+ % the return liveness info. No later code in this
+ % predicate depends on the old state.
+ call_gen__rebuild_registers(ArgsInfos),
call_gen__generate_return_livevals(OutArgs, OutputArguments,
AfterCallInstMap, OutLiveVals),
- % make the call
+ % Make the call.
code_info__get_module_info(ModuleInfo),
code_info__make_entry_label(ModuleInfo, PredId, ModeId, yes, Address),
code_info__get_next_label(ReturnLabel),
@@ -118,7 +124,6 @@
- "continuation label"
]) },
- call_gen__rebuild_registers(ArgsInfos),
call_gen__handle_failure(CodeModel, FailHandlingCode),
{ Code =
@@ -183,8 +188,6 @@
{ goal_info_get_instmap_delta(GoalInfo, InstMapDelta) },
{ instmap__apply_instmap_delta(InstMap, InstMapDelta,
AfterCallInstMap) },
- call_gen__generate_return_livevals(OutArgs, OutLocs, AfterCallInstMap,
- OutLiveVals),
code_info__produce_variable(PredVar, PredVarCode, PredRVal),
(
@@ -207,6 +210,15 @@
]) },
trace__prepare_for_call(TraceCode),
+
+ % We must update the code generator state to reflect
+ % the situation after the call before building
+ % the return liveness info. No later code in this
+ % predicate depends on the old state.
+ call_gen__rebuild_registers(OutArguments),
+ call_gen__generate_return_livevals(OutArgs, OutLocs, AfterCallInstMap,
+ OutLiveVals),
+
code_info__get_next_label(ReturnLabel),
{ CallCode = node([
livevals(LiveVals)
@@ -217,7 +229,6 @@
- "Continuation label"
]) },
- call_gen__rebuild_registers(OutArguments),
call_gen__handle_failure(CodeModel, FailHandlingCode),
{ Code =
@@ -284,8 +295,6 @@
{ goal_info_get_instmap_delta(GoalInfo, InstMapDelta) },
{ instmap__apply_instmap_delta(InstMap, InstMapDelta,
AfterCallInstMap) },
- call_gen__generate_return_livevals(OutArgs, OutLocs, AfterCallInstMap,
- OutLiveVals),
code_info__produce_variable(TCVar, TCVarCode, TCVarRVal),
(
@@ -310,6 +319,15 @@
]) },
trace__prepare_for_call(TraceCode),
+
+ % We must update the code generator state to reflect
+ % the situation after the call before building
+ % the return liveness info. No later code in this
+ % predicate depends on the old state.
+ call_gen__rebuild_registers(OutArguments),
+ call_gen__generate_return_livevals(OutArgs, OutLocs, AfterCallInstMap,
+ OutLiveVals),
+
code_info__get_next_label(ReturnLabel),
{ CallCode = node([
livevals(LiveVals)
@@ -320,7 +338,6 @@
- "Continuation label"
]) },
- call_gen__rebuild_registers(OutArguments),
call_gen__handle_failure(CodeModel, FailHandlingCode),
{ Code =
@@ -649,6 +666,7 @@
AfterCallInstMap, LiveVals0, LiveVals) -->
code_info__get_varset(VarSet),
{ varset__lookup_name(VarSet, Var, Name) },
+ { code_util__arg_loc_to_register(L, R) },
(
{ WantReturnLayout = yes }
->
@@ -656,13 +674,13 @@
code_info__variable_type(Var, Type),
{ type_util__vars(Type, TypeVars) },
- code_info__find_type_infos(TypeVars, TypeParams),
+ code_info__find_typeinfos_for_tvars(TypeVars, TypeParams),
{ VarInfo = var(Var, Name, Type, Inst) },
- { LiveVal = live_lvalue(R, VarInfo, TypeParams) }
+ { LiveVal = live_lvalue(direct(R), VarInfo, TypeParams) }
;
- { LiveVal = live_lvalue(R, unwanted, []) }
+ { map__init(Empty) },
+ { LiveVal = live_lvalue(direct(R), unwanted, Empty) }
),
- { code_util__arg_loc_to_register(L, R) },
call_gen__insert_arg_livelvals(As, WantReturnLayout, AfterCallInstMap,
[LiveVal | LiveVals0], LiveVals).
Index: compiler/code_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/code_gen.m,v
retrieving revision 1.56
diff -u -u -r1.56 code_gen.m
--- code_gen.m 1998/10/16 06:16:56 1.56
+++ code_gen.m 1998/10/16 06:37:26
@@ -655,7 +655,17 @@
( { MaybeTraceInfo = yes(TraceInfo) } ->
trace__generate_external_event_code(exit, TraceInfo,
_, TypeInfoDatas, TraceExitCode),
- { assoc_list__values(TypeInfoDatas, TypeInfoLvals) }
+ { map__values(TypeInfoDatas, TypeInfoLocnSets) },
+ { FindBaseLvals = lambda([Lval::out] is nondet, (
+ list__member(LocnSet, TypeInfoLocnSets),
+ set__member(Locn, LocnSet),
+ (
+ Locn = direct(Lval)
+ ;
+ Locn = indirect(Lval, _)
+ )
+ )) },
+ { solutions(FindBaseLvals, TypeInfoLvals) }
;
{ TraceExitCode = empty },
{ TypeInfoLvals = [] }
@@ -886,8 +896,10 @@
;
Instrn0 = call(Target, ReturnLabel, LiveVals0, CM)
->
+ map__init(Empty),
Instrn = call(Target, ReturnLabel,
- [live_lvalue(stackvar(StackLoc), succip, []) |
+ [live_lvalue(direct(stackvar(StackLoc)),
+ succip, Empty) |
LiveVals0], CM)
;
Instrn = Instrn0
Index: compiler/code_info.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/code_info.m,v
retrieving revision 1.229
diff -u -u -r1.229 code_info.m
--- code_info.m 1998/10/16 06:16:59 1.229
+++ code_info.m 1998/10/17 07:56:27
@@ -544,11 +544,11 @@
code_info, code_info).
:- mode code_info__lookup_type_defn(in, out, in, out) is det.
- % Given a list of type variables, find the lvals where the
- % corresponding type_infos and typeclass_infos are being stored.
-:- pred code_info__find_type_infos(list(var), assoc_list(var, lval),
- code_info, code_info).
-:- mode code_info__find_type_infos(in, out, in, out) is det.
+ % For each type variable in the given list, find out where the
+ % typeinfo var for that type variable is.
+:- pred code_info__find_typeinfos_for_tvars(list(tvar),
+ map(tvar, set(layout_locn)), code_info, code_info).
+:- mode code_info__find_typeinfos_for_tvars(in, out, in, out) is det.
% Given a constructor id, and a variable (so that we can work out the
% type of the constructor), determine correct tag (representation)
@@ -706,29 +706,42 @@
{ module_info_types(ModuleInfo, TypeTable) },
{ map__lookup(TypeTable, TypeId, TypeDefn) }.
-code_info__find_type_infos([], []) --> [].
-code_info__find_type_infos([TVar | TVars], [TVar - Lval | Lvals]) -->
+code_info__find_typeinfos_for_tvars(TypeVars, TypeInfoDataMap) -->
+ code_info__variable_locations(VarLocs),
+ code_info__get_varset(VarSet),
code_info__get_proc_info(ProcInfo),
{ proc_info_typeinfo_varmap(ProcInfo, TypeInfoMap) },
- {
- map__search(TypeInfoMap, TVar, Locn)
- ->
- type_info_locn_var(Locn, Var)
- ;
- error("cannot find var for type variable")
- },
- { proc_info_stack_slots(ProcInfo, StackSlots) },
- (
- { map__search(StackSlots, Var, Lval0) }
- ->
- { Lval = Lval0 }
- ;
- code_info__variable_to_string(Var, VarString),
- { string__format("code_info__find_type_infos: can't find lval for type_info var %s",
- [s(VarString)], ErrStr) },
- { error(ErrStr) }
- ),
- code_info__find_type_infos(TVars, Lvals).
+ { map__apply_to_list(TypeVars, TypeInfoMap, TypeInfoLocns) },
+ { FindLocn = lambda([TypeInfoLocn::in, Locns::out] is det, (
+ type_info_locn_var(TypeInfoLocn, TypeInfoVar),
+ (
+ map__search(VarLocs, TypeInfoVar, TypeInfoRvalSet)
+ ->
+ ConvertRval = lambda([Locn::out] is nondet, (
+ set__member(Rval, TypeInfoRvalSet),
+ Rval = lval(Lval),
+ (
+ TypeInfoLocn = typeclass_info(_,
+ FieldNum),
+ Locn = indirect(Lval, FieldNum)
+ ;
+ TypeInfoLocn = type_info(_),
+ Locn = direct(Lval)
+ )
+ )),
+ solutions_set(ConvertRval, Locns)
+ ;
+ varset__lookup_name(VarSet, TypeInfoVar, VarString),
+ string__format("%s: %s %s",
+ [s("code_info__find_typeinfos_for_tvars"),
+ s("can't find lval for type_info var"),
+ s(VarString)], ErrStr),
+ error(ErrStr)
+ )
+ )) },
+ { list__map(FindLocn, TypeInfoLocns, TypeInfoVarLocns) },
+ { map__from_corresponding_lists(TypeVars, TypeInfoVarLocns,
+ TypeInfoDataMap) }.
code_info__cons_id_to_tag(Var, ConsId, ConsTag) -->
code_info__variable_type(Var, Type),
@@ -3107,7 +3120,9 @@
code_info__generate_temp_livelvals([], LiveInfo, LiveInfo).
code_info__generate_temp_livelvals([Slot - StoredLval | Slots], LiveInfo0,
- [live_lvalue(Slot, LiveValueType, []) | LiveInfo1]) :-
+ [live_lvalue(direct(Slot), LiveValueType, Empty) | LiveInfo1])
+ :-
+ map__init(Empty),
code_info__get_live_value_type(StoredLval, LiveValueType),
code_info__generate_temp_livelvals(Slots, LiveInfo0, LiveInfo1).
@@ -3119,19 +3134,20 @@
code_info__livevals_to_livelvals([Lval - Var | Ls], WantReturnLayout,
AfterCallInstMap, [LiveLval | Lives]) -->
code_info__get_varset(VarSet),
- { varset__lookup_name(VarSet, Var, Name) },
(
{ WantReturnLayout = yes }
->
{ instmap__lookup_var(AfterCallInstMap, Var, Inst) },
+ { varset__lookup_name(VarSet, Var, Name) },
code_info__variable_type(Var, Type),
{ type_util__vars(Type, TypeVars) },
- code_info__find_type_infos(TypeVars, TypeParams),
- { LiveLval = live_lvalue(Lval, var(Var, Name, Type, Inst),
- TypeParams) }
+ code_info__find_typeinfos_for_tvars(TypeVars, TypeParams),
+ { LiveLval = live_lvalue(direct(Lval),
+ var(Var, Name, Type, Inst), TypeParams) }
;
- { LiveLval = live_lvalue(Lval, unwanted, []) }
+ { map__init(Empty) },
+ { LiveLval = live_lvalue(direct(Lval), unwanted, Empty) }
),
code_info__livevals_to_livelvals(Ls, WantReturnLayout,
AfterCallInstMap, Lives).
Index: compiler/continuation_info.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/continuation_info.m,v
retrieving revision 1.15
diff -u -u -r1.15 continuation_info.m
--- continuation_info.m 1998/10/16 06:17:06 1.15
+++ continuation_info.m 1998/10/16 06:43:00
@@ -157,13 +157,13 @@
---> layout_label_info(
set(var_info),
% live vars and their locations/names
- set(pair(tvar, lval))
+ map(tvar, set(layout_locn))
% locations of polymorphic type vars
).
:- type var_info
---> var_info(
- lval, % the location of the variable
+ layout_locn, % the location of the variable
live_value_type % info about the variable
).
@@ -298,11 +298,11 @@
),
( WantReturnInfo = yes ->
continuation_info__convert_return_data(LiveInfoList,
- VarInfoSet, TypeInfoSet),
+ VarInfoSet, TypeInfoMap),
(
Return0 = no,
Return = yes(layout_label_info(VarInfoSet,
- TypeInfoSet))
+ TypeInfoMap))
;
% If a var is known to be dead
% on return from one call, it
@@ -311,7 +311,7 @@
% the same return address either.
Return0 = yes(layout_label_info(LV0, TV0)),
set__intersect(LV0, VarInfoSet, LV),
- set__intersect(TV0, TypeInfoSet, TV),
+ map__intersect(set__intersect, TV0, TypeInfoMap, TV),
Return = yes(layout_label_info(LV, TV))
)
;
@@ -321,21 +321,22 @@
map__set(Internals0, Label, Internal, Internals).
:- pred continuation_info__convert_return_data(list(liveinfo)::in,
- set(var_info)::out, set(pair(tvar, lval))::out) is det.
+ set(var_info)::out, map(tvar, set(layout_locn))::out) is det.
-continuation_info__convert_return_data(LiveInfos, VarInfoSet, TypeInfoSet) :-
+continuation_info__convert_return_data(LiveInfos, VarInfoSet, TypeInfoMap) :-
GetVarInfo = lambda([LiveLval::in, VarInfo::out] is det, (
LiveLval = live_lvalue(Lval, LiveValueType, _),
VarInfo = var_info(Lval, LiveValueType)
)),
list__map(GetVarInfo, LiveInfos, VarInfoList),
- GetTypeInfo = lambda([LiveLval::in, TypeInfos::out] is det, (
- LiveLval = live_lvalue(_, _, TypeInfos)
+ GetTypeInfo = lambda([LiveLval::in, LiveTypeInfoMap::out] is det, (
+ LiveLval = live_lvalue(_, _, LiveTypeInfoMap)
)),
- list__map(GetTypeInfo, LiveInfos, TypeInfoListList),
- list__condense(TypeInfoListList, TypeInfoList),
- list__sort_and_remove_dups(TypeInfoList, SortedTypeInfoList),
- set__sorted_list_to_set(SortedTypeInfoList, TypeInfoSet),
+ list__map(GetTypeInfo, LiveInfos, TypeInfoMapList),
+ map__init(Empty),
+ list__foldl(lambda([TIM1::in, TIM2::in, TIM::out] is det,
+ map__union(set__intersect, TIM1, TIM2, TIM)),
+ TypeInfoMapList, Empty, TypeInfoMap),
set__list_to_set(VarInfoList, VarInfoSet).
:- pred continuation_info__filter_named_vars(list(liveinfo)::in,
Index: compiler/hlds_pred.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_pred.m,v
retrieving revision 1.53
diff -u -u -r1.53 hlds_pred.m
--- hlds_pred.m 1998/09/24 09:44:26 1.53
+++ hlds_pred.m 1998/10/07 05:17:23
@@ -250,11 +250,23 @@
.
:- type type_info_locn
- ---> type_info(var) % it is a normal type info
- % (ie. the type is not constrained)
+ ---> type_info(var)
+ % It is a normal type info, i.e. the type
+ % is not constrained.
+
; typeclass_info(var, int).
- % it is packed inside a typeclass_info,
- % and is at the given offset
+ % The typeinfo is packed inside a
+ % typeclass_info. If the int is N, it is
+ % the Nth typeinfo inside the typeclass_info,
+ % but there may be several superclass pointers
+ % before the block of typeinfos, so it won't
+ % be the Nth word of the typeclass_info.
+ %
+ % To find the typeinfo inside the
+ % typeclass_info, use the predicate
+ % type_info_from_typeclass_info from Mercury
+ % code; from C code use the macro
+ % MR_typeclass_info_superclass_info.
% type_info_locn_var(TypeInfoLocn, Var):
% Var is the variable corresponding to the TypeInfoLocn. Note
Index: compiler/llds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/llds.m,v
retrieving revision 1.229
diff -u -u -r1.229 llds.m
--- llds.m 1998/10/16 06:17:28 1.229
+++ llds.m 1998/10/16 10:45:47
@@ -17,7 +17,7 @@
:- interface.
:- import_module hlds_pred, hlds_data, tree, prog_data, (inst).
-:- import_module assoc_list, bool, list, set, term, std_util.
+:- import_module bool, list, set, map, term, std_util.
%-----------------------------------------------------------------------------%
@@ -421,19 +421,33 @@
% the non-conservative garbage collector.
:- type liveinfo
---> live_lvalue(
- lval,
- % What stackslot/reg does
- % this lifeinfo structure
+ layout_locn,
+ % What location does this lifeinfo structure
% refer to?
live_value_type,
% What is the type of this live value?
- assoc_list(tvar, lval)
+ map(tvar, set(layout_locn))
% Where are the typeinfos that determine the
% types of the actual parameters of the type
% parameters of this type (if it is
% polymorphic), and the type variable
% for each one.
).
+
+ % Most of the time, a layout specifies a location as an lval.
+ % However, a type_info variable may be hidden inside a typeclass_info,
+ % In this case, accessing the type_info requires indirection.
+ % The address of the typeclass_info is given as an lval, and
+ % the location of the typeinfo within the typeclass_info as an index;
+ % private_builtin:type_info_from_typeclass_info interprets the index.
+ %
+ % This one level of indirection is sufficient, since type_infos
+ % cannot be nested inside typeclass_infos any deeper than this.
+ % A more general representation that would allow more indirection
+ % would be much harder to fit into one machine word.
+:- type layout_locn
+ ---> direct(lval)
+ ; indirect(lval, int).
% live_value_type describes the different sorts of data that
% can be considered live.
Index: compiler/llds_out.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/llds_out.m,v
retrieving revision 1.89
diff -u -u -r1.89 llds_out.m
--- llds_out.m 1998/10/16 06:17:31 1.89
+++ llds_out.m 1998/10/17 06:01:05
@@ -131,7 +131,7 @@
:- import_module export, mercury_to_mercury, modules.
:- import_module int, list, char, string, std_util, term, varset.
-:- import_module set, bintree_set, assoc_list, require.
+:- import_module map, set, bintree_set, assoc_list, require.
:- import_module library. % for the version number.
%-----------------------------------------------------------------------------%
@@ -140,14 +140,29 @@
% set of symbols we've already declared. That way, we avoid generating
% the same symbol twice, which would cause an error in the C code.
-:- type decl_set == bintree_set(decl_id).
-
:- type decl_id ---> create_label(int)
; float_label(string)
; code_addr(code_addr)
; data_addr(data_addr)
; pragma_c_struct(string).
+:- type decl_set == map(decl_id, unit).
+
+:- pred decl_set_init(decl_set::out) is det.
+
+decl_set_init(DeclSet) :-
+ map__init(DeclSet).
+
+:- pred decl_set_insert(decl_set::in, decl_id::in, decl_set::out) is det.
+
+decl_set_insert(DeclSet0, DeclId, DeclSet) :-
+ map__set(DeclSet0, DeclId, unit, DeclSet).
+
+:- pred decl_set_is_member(decl_id::in, decl_set::in) is semidet.
+
+decl_set_is_member(DeclId, DeclSet) :-
+ map__search(DeclSet, DeclId, _).
+
output_c_file(C_File, StackLayoutLabels) -->
globals__io_lookup_bool_option(split_c_files, SplitFiles),
( { SplitFiles = yes } ->
@@ -278,7 +293,7 @@
output_c_header_include_lines(C_HeaderLines),
io__write_string("\n"),
{ gather_c_file_labels(Modules, Labels) },
- { bintree_set__init(DeclSet0) },
+ { decl_set_init(DeclSet0) },
output_c_label_decl_list(Labels, DeclSet0, DeclSet),
output_c_module_list(Modules, StackLayoutLabels, DeclSet),
( { SplitFiles = yes(_) } ->
@@ -525,7 +540,7 @@
),
output_const_term_decl(ArgVals, DataAddr, ExportedFromFile, "", "",
0, _),
- { bintree_set__insert(DeclSet1, DataAddr, DeclSet) }.
+ { decl_set_insert(DeclSet1, DataAddr, DeclSet) }.
output_c_module(c_code(C_Code, Context), _, DeclSet, DeclSet) -->
globals__io_lookup_bool_option(auto_comments, PrintComments),
@@ -621,7 +636,7 @@
{ Label = local(_, _) },
io__write_string("Declare_label(")
),
- { bintree_set__insert(DeclSet0, code_addr(label(Label)), DeclSet) },
+ { decl_set_insert(DeclSet0, code_addr(label(Label)), DeclSet) },
output_label(Label),
io__write_string(");\n").
@@ -884,7 +899,7 @@
MaybeStructFieldsContext) }
->
{
- bintree_set__is_member(pragma_c_struct(StructName),
+ decl_set_is_member(pragma_c_struct(StructName),
DeclSet0)
->
string__append_list(["struct ", StructName,
@@ -904,7 +919,7 @@
io__write_string(StructFields)
),
io__write_string("\n};\n"),
- { bintree_set__insert(DeclSet0, pragma_c_struct(StructName),
+ { decl_set_insert(DeclSet0, pragma_c_struct(StructName),
DeclSet1) }
;
{ DeclSet1 = DeclSet0 }
@@ -1518,28 +1533,59 @@
output_gc_livevals_2([]) --> [].
output_gc_livevals_2([LiveInfo | LiveInfos]) -->
- { LiveInfo = live_lvalue(Lval, LiveValueType, TypeParams) },
+ { LiveInfo = live_lvalue(Locn, LiveValueType, TypeParams) },
io__write_string(" *\t"),
- output_lval(Lval),
+ output_layout_locn(Locn),
io__write_string("\t"),
output_live_value_type(LiveValueType),
io__write_string("\t"),
- output_gc_livevals_params(TypeParams),
+ { map__to_assoc_list(TypeParams, TypeParamList) },
+ output_gc_livevals_params(TypeParamList),
io__write_string("\n"),
output_gc_livevals_2(LiveInfos).
-:- pred output_gc_livevals_params(assoc_list(var, lval), io__state, io__state).
+:- pred output_gc_livevals_params(assoc_list(var, set(layout_locn)),
+ io__state, io__state).
:- mode output_gc_livevals_params(in, di, uo) is det.
output_gc_livevals_params([]) --> [].
-output_gc_livevals_params([Var - Lval | Lvals]) -->
+output_gc_livevals_params([Var - LocnSet | Locns]) -->
{ term__var_to_int(Var, VarInt) },
io__write_int(VarInt),
io__write_string(" - "),
- output_lval(Lval),
+ { set__to_sorted_list(LocnSet, LocnList) },
+ output_layout_locns(LocnList),
io__write_string(" "),
- output_gc_livevals_params(Lvals).
+ output_gc_livevals_params(Locns).
+
+:- pred output_layout_locns(list(layout_locn), io__state, io__state).
+:- mode output_layout_locns(in, di, uo) is det.
+output_layout_locns([]) --> [].
+output_layout_locns([Locn | Locns]) -->
+ output_layout_locn(Locn),
+ ( { Locns = [] } ->
+ []
+ ;
+ io__write_string(" and "),
+ output_layout_locns(Locns)
+ ).
+
+:- pred output_layout_locn(layout_locn, io__state, io__state).
+:- mode output_layout_locn(in, di, uo) is det.
+
+output_layout_locn(Locn) -->
+ (
+ { Locn = direct(Lval) },
+ output_lval(Lval)
+ ;
+ { Locn = indirect(Lval, Offset) },
+ io__write_string("offset "),
+ io__write_int(Offset),
+ io__write_string(" from "),
+ output_lval(Lval)
+ ).
+
:- pred output_live_value_type(live_value_type, io__state, io__state).
:- mode output_live_value_type(in, di, uo) is det.
@@ -1550,8 +1596,11 @@
output_live_value_type(redoip) --> io__write_string("MR_redoip").
output_live_value_type(hp) --> io__write_string("MR_hp").
output_live_value_type(unwanted) --> io__write_string("unwanted").
-output_live_value_type(var(_, Name, Type, Inst)) -->
+output_live_value_type(var(Var, Name, Type, Inst)) -->
io__write_string("var("),
+ { term__var_to_int(Var, VarInt) },
+ io__write_int(VarInt),
+ io__write_string(", "),
io__write_string(Name),
io__write_string(", "),
{ varset__init(NewVarset) },
@@ -1613,11 +1662,12 @@
output_code_addr_decls(CodeAddress, FirstIndent, LaterIndent,
N0, N, DeclSet0, DeclSet)
; { Const = data_addr_const(DataAddr) } ->
- ( { bintree_set__is_member(data_addr(DataAddr), DeclSet0) } ->
+ ( { decl_set_is_member(data_addr(DataAddr), DeclSet0) } ->
{ N = N0 },
{ DeclSet = DeclSet0 }
;
- { bintree_set__insert(DeclSet0, data_addr(DataAddr), DeclSet) },
+ { decl_set_insert(DeclSet0, data_addr(DataAddr),
+ DeclSet) },
output_data_addr_decls(DataAddr,
FirstIndent, LaterIndent, N0, N)
)
@@ -1634,11 +1684,12 @@
( { UnboxedFloat = no, StaticGroundTerms = yes } ->
{ llds_out__float_literal_name(FloatVal, FloatName) },
{ FloatLabel = float_label(FloatName) },
- ( { bintree_set__is_member(FloatLabel, DeclSet0) } ->
+ ( { decl_set_is_member(FloatLabel, DeclSet0) } ->
{ N = N0 },
{ DeclSet = DeclSet0 }
;
- { bintree_set__insert(DeclSet0, FloatLabel, DeclSet) },
+ { decl_set_insert(DeclSet0, FloatLabel,
+ DeclSet) },
{ string__float_to_string(FloatVal,
FloatString) },
output_indent(FirstIndent, LaterIndent, N0),
@@ -1683,11 +1734,11 @@
FloatName) }
->
{ FloatLabel = float_label(FloatName) },
- ( { bintree_set__is_member(FloatLabel, DeclSet2) } ->
+ ( { decl_set_is_member(FloatLabel, DeclSet2) } ->
{ N = N2 },
{ DeclSet = DeclSet2 }
;
- { bintree_set__insert(DeclSet2, FloatLabel, DeclSet) },
+ { decl_set_insert(DeclSet2, FloatLabel, DeclSet) },
output_indent(FirstIndent, LaterIndent, N2),
{ N is N2 + 1 },
io__write_string(
@@ -1718,11 +1769,11 @@
output_rval_decls(create(_Tag, ArgVals, _, Label, _), FirstIndent, LaterIndent,
N0, N, DeclSet0, DeclSet) -->
{ CreateLabel = create_label(Label) },
- ( { bintree_set__is_member(CreateLabel, DeclSet0) } ->
+ ( { decl_set_is_member(CreateLabel, DeclSet0) } ->
{ N = N0 },
{ DeclSet = DeclSet0 }
;
- { bintree_set__insert(DeclSet0, CreateLabel, DeclSet1) },
+ { decl_set_insert(DeclSet0, CreateLabel, DeclSet1) },
output_cons_arg_decls(ArgVals, FirstIndent, LaterIndent, N0, N1,
DeclSet1, DeclSet),
output_const_term_decl(ArgVals, CreateLabel, no, FirstIndent,
@@ -2026,11 +2077,12 @@
output_code_addr_decls(CodeAddress, FirstIndent, LaterIndent, N0, N,
DeclSet0, DeclSet) -->
- ( { bintree_set__is_member(code_addr(CodeAddress), DeclSet0) } ->
+ ( { decl_set_is_member(code_addr(CodeAddress), DeclSet0) } ->
{ N = N0 },
{ DeclSet = DeclSet0 }
;
- { bintree_set__insert(DeclSet0, code_addr(CodeAddress), DeclSet) },
+ { decl_set_insert(DeclSet0, code_addr(CodeAddress),
+ DeclSet) },
need_code_addr_decls(CodeAddress, NeedDecl),
( { NeedDecl = yes } ->
output_indent(FirstIndent, LaterIndent, N0),
Index: compiler/stack_layout.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/stack_layout.m,v
retrieving revision 1.19
diff -u -u -r1.19 stack_layout.m
--- stack_layout.m 1998/10/16 06:17:53 1.19
+++ stack_layout.m 1998/10/16 10:59:12
@@ -287,7 +287,7 @@
;
SuccipLval = stackvar(Location)
},
- { stack_layout__represent_lval(SuccipLval, SuccipRval) },
+ { stack_layout__represent_locn(direct(SuccipLval), SuccipRval) },
{ StackSlotsRval = const(int_const(StackSlots)) },
{ CodeAddrRval = const(code_addr_const(label(EntryLabel))) },
@@ -429,32 +429,32 @@
{
Port = no,
set__init(PortLiveVarSet),
- set__init(PortTypeVarSet)
+ map__init(PortTypeVarMap)
;
- Port = yes(layout_label_info(PortLiveVarSet, PortTypeVarSet))
+ Port = yes(layout_label_info(PortLiveVarSet, PortTypeVarMap))
},
stack_layout__get_agc_stack_layout(AgcStackLayout),
{
Return = no,
set__init(ReturnLiveVarSet),
- set__init(ReturnTypeVarSet)
+ map__init(ReturnTypeVarMap)
;
Return = yes(layout_label_info(ReturnLiveVarSet0,
- ReturnTypeVarSet0)),
+ ReturnTypeVarMap0)),
( AgcStackLayout = yes ->
ReturnLiveVarSet = ReturnLiveVarSet0,
- ReturnTypeVarSet0 = ReturnTypeVarSet
+ ReturnTypeVarMap = ReturnTypeVarMap0
;
% This set of variables must be for uplevel printing
% in execution tracing, so we are interested only
% in (a) variables, not temporaries, (b) only named
% variables, and (c) only those on the stack, not
- % the return valies.
+ % the return values.
set__to_sorted_list(ReturnLiveVarSet0,
ReturnLiveVarList0),
stack_layout__select_trace_return(
- ReturnLiveVarList0, ReturnTypeVarSet0,
- ReturnLiveVarList, ReturnTypeVarSet),
+ ReturnLiveVarList0, ReturnTypeVarMap0,
+ ReturnLiveVarList, ReturnTypeVarMap),
set__list_to_set(ReturnLiveVarList, ReturnLiveVarSet)
)
},
@@ -468,19 +468,21 @@
% which may not be true.)
{ RvalList = [yes(const(int_const(-1)))] }
;
+ % XXX ignore differences in insts inside var_infos
{ set__union(PortLiveVarSet, ReturnLiveVarSet, LiveVarSet) },
- { set__union(PortTypeVarSet, ReturnTypeVarSet, TypeVarSet) },
- stack_layout__construct_livelval_rvals(LiveVarSet, TypeVarSet,
- RvalList)
+ { map__union(set__intersect, PortTypeVarMap, ReturnTypeVarMap,
+ TypeVarMap) },
+ stack_layout__construct_livelval_rvals(LiveVarSet,
+ TypeVarMap, RvalList)
).
%---------------------------------------------------------------------------%
:- pred stack_layout__construct_livelval_rvals(set(var_info)::in,
- set(pair(tvar, lval))::in, list(maybe(rval))::out,
+ map(tvar, set(layout_locn))::in, list(maybe(rval))::out,
stack_layout_info::in, stack_layout_info::out) is det.
-stack_layout__construct_livelval_rvals(LiveLvalSet, TVarLocnSet, RvalList) -->
+stack_layout__construct_livelval_rvals(LiveLvalSet, TVarLocnMap, RvalList) -->
{ set__to_sorted_list(LiveLvalSet, LiveLvals) },
{ list__length(LiveLvals, Length) },
{ VarLengthRval = const(int_const(Length)) },
@@ -489,7 +491,7 @@
stack_layout__construct_liveval_pairs(SortedLiveLvals,
LiveValRval, NamesRval),
- { set__to_sorted_list(TVarLocnSet, TVarLocns) },
+ { map__to_assoc_list(TVarLocnMap, TVarLocns) },
( { TVarLocns = [] } ->
{ TypeParamRval = const(int_const(0)) }
;
@@ -518,14 +520,15 @@
% the selected var_infos.
:- pred stack_layout__select_trace_return(
- list(var_info)::in, set(pair(tvar, lval))::in,
- list(var_info)::out, set(pair(tvar, lval))::out) is det.
+ list(var_info)::in, map(tvar, set(layout_locn))::in,
+ list(var_info)::out, map(tvar, set(layout_locn))::out) is det.
stack_layout__select_trace_return(Infos, TVars, TraceReturnInfos, TVars) :-
- IsNamedReturnVar = lambda([LvalInfo::in] is semidet, (
- LvalInfo = var_info(Lval, LvalType),
+ IsNamedReturnVar = lambda([LocnInfo::in] is semidet, (
+ LocnInfo = var_info(Locn, LvalType),
LvalType = var(_, Name, _, _),
Name \= "",
+ ( Locn = direct(Lval) ; Locn = indirect(Lval, _)),
( Lval = stackvar(_) ; Lval = framevar(_) )
)),
list__filter(IsNamedReturnVar, Infos, TraceReturnInfos).
@@ -584,16 +587,22 @@
% slot to fill is given by the second argument.
:- pred stack_layout__construct_type_param_locn_vector(
- assoc_list(tvar, lval)::in, int::in, list(maybe(rval))::out,
+ assoc_list(tvar, set(layout_locn))::in,
+ int::in, list(maybe(rval))::out,
stack_layout_info::in, stack_layout_info::out) is det.
stack_layout__construct_type_param_locn_vector([], _, []) --> [].
-stack_layout__construct_type_param_locn_vector([TVar - Locn | TVarLocns],
+stack_layout__construct_type_param_locn_vector([TVar - Locns | TVarLocns],
CurSlot, Vector) -->
{ term__var_to_int(TVar, TVarNum) },
{ NextSlot is CurSlot + 1 },
( { TVarNum = CurSlot } ->
- { stack_layout__represent_lval(Locn, Rval) },
+ { set__remove_least(Locns, LeastLocn, _) ->
+ Locn = LeastLocn
+ ;
+ error("tvar has empty set of locations")
+ },
+ { stack_layout__represent_locn(Locn, Rval) },
stack_layout__construct_type_param_locn_vector(TVarLocns,
NextSlot, VectorTail),
{ Vector = [yes(Rval) | VectorTail] }
@@ -607,7 +616,7 @@
{ error("unsorted tvars in construct_type_param_locn_vector") }
).
- % Construct a vector of (lval, live_value_type) pairs,
+ % Construct a vector of (locn, live_value_type) pairs,
% and a corresponding vector of variable names.
:- pred stack_layout__construct_liveval_pairs(list(var_info)::in,
@@ -627,15 +636,15 @@
{ NameVector = create(0, Names, no, CNum2,
"stack_layout_name_vector") }.
- % Construct a pair of (lval, live_value_type) representations.
+ % Construct a pair of (locn, live_value_type) representations.
:- pred stack_layout__construct_liveval_pair(var_info::in,
list(maybe(rval))::out, stack_layout_info::in, stack_layout_info::out)
is det.
-stack_layout__construct_liveval_pair(var_info(Lval, LiveValueType),
+stack_layout__construct_liveval_pair(var_info(Locn, LiveValueType),
MaybeRvals) -->
- { stack_layout__represent_lval(Lval, Rval0) },
+ { stack_layout__represent_locn(Locn, Rval0) },
stack_layout__represent_live_value_type(LiveValueType, Rval1),
{ MaybeRvals = [yes(Rval0), yes(Rval1)] }.
@@ -707,31 +716,48 @@
{ Rval = create(0, [yes(Rval0), yes(Rval1)], no, CNum2,
"stack_layout_pair") }.
+ % Construct a representation of a variable location.
+
+:- pred stack_layout__represent_locn(layout_locn, rval).
+:- mode stack_layout__represent_locn(in, out) is det.
+
+stack_layout__represent_locn(direct(Lval), Rval) :-
+ stack_layout__represent_lval(Lval, Word),
+ Rval = const(int_const(Word)).
+stack_layout__represent_locn(indirect(Lval, Offset), Rval) :-
+ stack_layout__represent_lval(Lval, BaseWord),
+ stack_layout__offset_bits(OffsetBits),
+ require((1 << OffsetBits) > Offset,
+ "stack_layout__represent_locn: offset too large to be represented"),
+ BaseAndOffset is (BaseWord << OffsetBits) + Offset,
+ stack_layout__make_tagged_word(lval_indirect, BaseAndOffset, Word),
+ Rval = const(int_const(Word)).
+
% Construct a representation of an lval.
-:- pred stack_layout__represent_lval(lval, rval).
+:- pred stack_layout__represent_lval(lval, int).
:- mode stack_layout__represent_lval(in, out) is det.
-stack_layout__represent_lval(reg(r, Num), Rval) :-
- stack_layout__make_tagged_rval(0, Num, Rval).
-stack_layout__represent_lval(reg(f, Num), Rval) :-
- stack_layout__make_tagged_rval(1, Num, Rval).
-
-stack_layout__represent_lval(stackvar(Num), Rval) :-
- stack_layout__make_tagged_rval(2, Num, Rval).
-stack_layout__represent_lval(framevar(Num), Rval) :-
- stack_layout__make_tagged_rval(3, Num, Rval).
-
-stack_layout__represent_lval(succip, Rval) :-
- stack_layout__make_tagged_rval(4, 0, Rval).
-stack_layout__represent_lval(maxfr, Rval) :-
- stack_layout__make_tagged_rval(5, 0, Rval).
-stack_layout__represent_lval(curfr, Rval) :-
- stack_layout__make_tagged_rval(6, 0, Rval).
-stack_layout__represent_lval(hp, Rval) :-
- stack_layout__make_tagged_rval(7, 0, Rval).
-stack_layout__represent_lval(sp, Rval) :-
- stack_layout__make_tagged_rval(8, 0, Rval).
+stack_layout__represent_lval(reg(r, Num), Word) :-
+ stack_layout__make_tagged_word(lval_r_reg, Num, Word).
+stack_layout__represent_lval(reg(f, Num), Word) :-
+ stack_layout__make_tagged_word(lval_f_reg, Num, Word).
+
+stack_layout__represent_lval(stackvar(Num), Word) :-
+ stack_layout__make_tagged_word(lval_stackvar, Num, Word).
+stack_layout__represent_lval(framevar(Num), Word) :-
+ stack_layout__make_tagged_word(lval_framevar, Num, Word).
+
+stack_layout__represent_lval(succip, Word) :-
+ stack_layout__make_tagged_word(lval_succip, 0, Word).
+stack_layout__represent_lval(maxfr, Word) :-
+ stack_layout__make_tagged_word(lval_maxfr, 0, Word).
+stack_layout__represent_lval(curfr, Word) :-
+ stack_layout__make_tagged_word(lval_curfr, 0, Word).
+stack_layout__represent_lval(hp, Word) :-
+ stack_layout__make_tagged_word(lval_hp, 0, Word).
+stack_layout__represent_lval(sp, Word) :-
+ stack_layout__make_tagged_word(lval_sp, 0, Word).
stack_layout__represent_lval(temp(_, _), _) :-
error("stack_layout: continuation live value stored in temp register").
@@ -761,21 +787,51 @@
% This allows us to use more than the usual 2 or 3 bits, but
% we have to use low tags and cannot tag pointers this way.
-:- pred stack_layout__make_tagged_rval(int::in, int::in, rval::out) is det.
+:- pred stack_layout__make_tagged_word(locn_type::in, int::in, int::out) is det.
-stack_layout__make_tagged_rval(Tag, Value, Rval) :-
- stack_layout__make_tagged_word(Tag, Value, TaggedValue),
- Rval = const(int_const(TaggedValue)).
+stack_layout__make_tagged_word(Locn, Value, TaggedValue) :-
+ stack_layout__locn_type_code(Locn, Tag),
+ stack_layout__tag_bits(TagBits),
+ TaggedValue is (Value << TagBits) + Tag.
+
+:- type locn_type
+ ---> lval_r_reg
+ ; lval_f_reg
+ ; lval_stackvar
+ ; lval_framevar
+ ; lval_succip
+ ; lval_maxfr
+ ; lval_curfr
+ ; lval_hp
+ ; lval_sp
+ ; lval_indirect.
+
+:- pred stack_layout__locn_type_code(locn_type::in, int::out) is det.
+
+stack_layout__locn_type_code(lval_r_reg, 0).
+stack_layout__locn_type_code(lval_f_reg, 1).
+stack_layout__locn_type_code(lval_stackvar, 2).
+stack_layout__locn_type_code(lval_framevar, 3).
+stack_layout__locn_type_code(lval_succip, 4).
+stack_layout__locn_type_code(lval_maxfr, 5).
+stack_layout__locn_type_code(lval_curfr, 6).
+stack_layout__locn_type_code(lval_hp, 7).
+stack_layout__locn_type_code(lval_sp, 8).
+stack_layout__locn_type_code(lval_indirect, 9).
-:- pred stack_layout__make_tagged_word(int::in, int::in, int::out) is det.
+:- pred stack_layout__tag_bits(int::out) is det.
-stack_layout__make_tagged_word(Tag, Value, TaggedValue) :-
- stack_layout__tag_bits(Bits),
- TaggedValue = (Value << Bits) + Tag.
+% This number of tag bits must be able to encode all values of
+% stack_layout__locn_type_code.
-:- pred stack_layout__tag_bits(int::out) is det.
+stack_layout__tag_bits(4).
+
+% This number of tag bits must be able to encode the largest offset
+% of a type_info within a typeclass_info.
+
+:- pred stack_layout__offset_bits(int::out) is det.
-stack_layout__tag_bits(8).
+stack_layout__offset_bits(6).
%---------------------------------------------------------------------------%
Index: compiler/trace.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/trace.m,v
retrieving revision 1.12
diff -u -u -r1.12 trace.m
--- trace.m 1998/10/16 06:17:59 1.12
+++ trace.m 1998/10/16 06:52:14
@@ -47,7 +47,7 @@
:- import_module hlds_goal, hlds_pred, hlds_module.
:- import_module globals, prog_data, llds, code_info.
-:- import_module std_util, assoc_list, set, term.
+:- import_module map, std_util, set, term.
% The kinds of external ports for which the code we generate will
% call MR_trace. The redo port is not on this list, because for that
@@ -116,8 +116,8 @@
% liveness information, since some of our callers also need this
% information.
:- pred trace__generate_external_event_code(external_trace_port::in,
- trace_info::in, label::out, assoc_list(tvar, lval)::out, code_tree::out,
- code_info::in, code_info::out) is det.
+ trace_info::in, label::out, map(tvar, set(layout_locn))::out,
+ code_tree::out, code_info::in, code_info::out) is det.
% If the trace level calls for redo events, generate code that pushes
% a temporary nondet stack frame whose redoip slot contains the
@@ -396,16 +396,16 @@
).
trace__generate_external_event_code(ExternalPort, TraceInfo,
- Label, TvarDataList, Code) -->
+ Label, TvarDataMap, Code) -->
{ trace__convert_external_port_type(ExternalPort, Port) },
trace__generate_event_code(Port, external, TraceInfo,
- Label, TvarDataList, Code).
+ Label, TvarDataMap, Code).
:- pred trace__generate_event_code(trace_port::in, trace_port_info::in,
- trace_info::in, label::out, assoc_list(tvar, lval)::out,
+ trace_info::in, label::out, map(tvar, set(layout_locn))::out,
code_tree::out, code_info::in, code_info::out) is det.
-trace__generate_event_code(Port, PortInfo, TraceInfo, Label, TvarDataList,
+trace__generate_event_code(Port, PortInfo, TraceInfo, Label, TvarDataMap,
Code) -->
(
{ Port = fail },
@@ -448,16 +448,11 @@
trace__produce_vars(LiveVars, VarSet, InstMap, TvarSet0, TvarSet,
VarInfoList, ProduceCode),
{ set__to_sorted_list(TvarSet, TvarList) },
- code_info__variable_locations(VarLocs),
- code_info__get_proc_info(ProcInfo),
- { proc_info_typeinfo_varmap(ProcInfo, TypeInfoMap) },
- { trace__find_typeinfos_for_tvars(TvarList, VarLocs, TypeInfoMap,
- TvarDataList) },
+ code_info__find_typeinfos_for_tvars(TvarList, TvarDataMap),
code_info__max_reg_in_use(MaxReg),
{
set__list_to_set(VarInfoList, VarInfoSet),
- set__list_to_set(TvarDataList, TvarDataSet),
- LayoutLabelInfo = layout_label_info(VarInfoSet, TvarDataSet),
+ LayoutLabelInfo = layout_label_info(VarInfoSet, TvarDataMap),
llds_out__get_label(Label, yes, LabelStr),
Quote = """",
Comma = ", ",
@@ -529,39 +524,12 @@
varset__lookup_name(VarSet, Var, "V_", Name),
instmap__lookup_var(InstMap, Var, Inst),
LiveType = var(Var, Name, Type, Inst),
- VarInfo = var_info(Lval, LiveType),
+ VarInfo = var_info(direct(Lval), LiveType),
type_util__vars(Type, TypeVars),
set__insert_list(Tvars0, TypeVars, Tvars1)
},
trace__produce_vars(Vars, VarSet, InstMap, Tvars1, Tvars,
VarInfos, VarsCode).
-
- % For each type variable in the given list, find out where the
- % typeinfo var for that type variable is.
-
-:- pred trace__find_typeinfos_for_tvars(list(tvar)::in,
- map(var, set(rval))::in, map(tvar, type_info_locn)::in,
- assoc_list(tvar, lval)::out) is det.
-
-trace__find_typeinfos_for_tvars(TypeVars, VarLocs, TypeInfoMap, TypeInfoDatas)
- :-
- map__apply_to_list(TypeVars, TypeInfoMap, TypeInfoLocns),
- list__map(type_info_locn_var, TypeInfoLocns, TypeInfoVars),
-
- map__apply_to_list(TypeInfoVars, VarLocs, TypeInfoLvalSets),
- FindSingleLval = lambda([Set::in, Lval::out] is det, (
- (
- set__remove_least(Set, Value, _),
- Value = lval(Lval0)
- ->
- Lval = Lval0
- ;
- error("trace__find_typeinfos_for_tvars: typeinfo var not available")
- ))
- ),
- list__map(FindSingleLval, TypeInfoLvalSets, TypeInfoLvals),
- assoc_list__from_corresponding_lists(TypeVars, TypeInfoLvals,
- TypeInfoDatas).
%-----------------------------------------------------------------------------%
cvs diff: Diffing compiler/notes
cvs diff: Diffing doc
cvs diff: Diffing extras
cvs diff: Diffing extras/cgi
cvs diff: Diffing extras/complex_numbers
cvs diff: Diffing extras/complex_numbers/samples
cvs diff: Diffing extras/complex_numbers/tests
cvs diff: Diffing extras/exceptions
cvs diff: Diffing extras/graphics
cvs diff: Diffing extras/graphics/mercury_opengl
cvs diff: Diffing extras/graphics/mercury_tcltk
cvs diff: Diffing extras/graphics/samples
cvs diff: Diffing extras/graphics/samples/calc
cvs diff: Diffing extras/graphics/samples/maze
cvs diff: Diffing extras/graphics/samples/pent
cvs diff: Diffing extras/odbc
cvs diff: Diffing extras/references
cvs diff: Diffing extras/references/samples
cvs diff: Diffing extras/references/tests
cvs diff: Diffing extras/trailed_update
cvs diff: Diffing extras/trailed_update/samples
cvs diff: Diffing extras/trailed_update/tests
cvs diff: Diffing library
Index: library/map.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/map.m,v
retrieving revision 1.65
diff -u -u -r1.65 map.m
--- map.m 1998/08/26 05:45:27 1.65
+++ map.m 1998/10/06 09:43:37
@@ -188,6 +188,36 @@
:- mode map__map_values(pred(in, in, out) is det, in, out) is det.
:- mode map__map_values(pred(in, in, out) is semidet, in, out) is semidet.
+ % Given two maps M1 and M2, create a third map M3 that has only the
+ % keys that occur in both M1 and M2. For keys that occur in both M1
+ % and M2, compute the value in the final map by applying the supplied
+ % predicate to the values associated with the key in M1 and M2.
+ % Fail if and only if this predicate fails on some common key.
+:- pred map__intersect(pred(V, V, V), map(K, V), map(K, V), map(K, V)).
+:- mode map__intersect(pred(in, in, out) is semidet, in, in, out) is semidet.
+:- mode map__intersect(pred(in, in, out) is det, in, in, out) is det.
+
+ % Calls map__intersect. Abort (with the last argument as the message)
+ % if map__intersect fails.
+:- pred map__det_intersect(pred(V, V, V), map(K, V), map(K, V), map(K, V),
+ string).
+:- mode map__det_intersect(pred(in, in, out) is semidet, in, in, out, in)
+ is det.
+
+ % Given two maps M1 and M2, create a third map M3 that all the keys
+ % that occur in either M1 and M2. For keys that occur in both M1
+ % and M2, compute the value in the final map by applying the supplied
+ % predicate to the values associated with the key in M1 and M2.
+ % Fail if and only if this predicate fails on some common key.
+:- pred map__union(pred(V, V, V), map(K, V), map(K, V), map(K, V)).
+:- mode map__union(pred(in, in, out) is semidet, in, in, out) is semidet.
+:- mode map__union(pred(in, in, out) is det, in, in, out) is det.
+
+ % Calls map__union. Abort (with the last argument as the message)
+ % if map__intersect fails.
+:- pred map__det_union(pred(V, V, V), map(K, V), map(K, V), map(K, V), string).
+:- mode map__det_union(pred(in, in, out) is semidet, in, in, out, in) is det.
+
%-----------------------------------------------------------------------------%
:- import_module tree234.
@@ -198,7 +228,7 @@
%-----------------------------------------------------------------------------%
:- implementation.
-:- import_module std_util, require, string.
+:- import_module set, std_util, require, string.
%-----------------------------------------------------------------------------%
@@ -423,6 +453,80 @@
map__map_values(Pred, Map0, Map) :-
tree234__map_values(Pred, Map0, Map).
+
+%-----------------------------------------------------------------------------%
+
+map__intersect(CommonPred, Map1, Map2, Common) :-
+ map__keys(Map1, Keys1),
+ map__keys(Map2, Keys2),
+ set__sorted_list_to_set(Keys1, Set1),
+ set__sorted_list_to_set(Keys2, Set2),
+ set__intersect(Set1, Set2, Set3),
+ set__to_sorted_list(Set3, Keys3),
+ map__init(Common0),
+ map__intersect_2(Keys3, Map1, Map2, CommonPred, Common0, Common).
+
+:- pred map__intersect_2(list(K), map(K, V), map(K, V), pred(V, V, V),
+ map(K, V), map(K, V)).
+:- mode map__intersect_2(in, in, in, pred(in, in, out) is semidet, in, out)
+ is semidet.
+:- mode map__intersect_2(in, in, in, pred(in, in, out) is det, in, out)
+ is det.
+
+map__intersect_2([], _, _, _, Common, Common).
+map__intersect_2([Key | Keys], Map1, Map2, CommonPred, Common0, Common) :-
+ map__lookup(Map1, Key, Value1),
+ map__lookup(Map2, Key, Value2),
+ call(CommonPred, Value1, Value2, Value),
+ map__det_insert(Common0, Key, Value, Common1),
+ map__intersect_2(Keys, Map1, Map2, CommonPred, Common1, Common).
+
+map__det_intersect(CommonPred, Map1, Map2, Common, Msg) :-
+ ( map__intersect(CommonPred, Map1, Map2, CommonPrime) ->
+ Common = CommonPrime
+ ;
+ error(Msg)
+ ).
+
+%-----------------------------------------------------------------------------%
+
+map__union(UnionPred, Map1, Map2, Union) :-
+ map__keys(Map1, Keys1),
+ map__keys(Map2, Keys2),
+ set__sorted_list_to_set(Keys1, Set1),
+ set__sorted_list_to_set(Keys2, Set2),
+ set__union(Set1, Set2, Set3),
+ set__to_sorted_list(Set3, Keys3),
+ map__init(Union0),
+ map__union_2(Keys3, Map1, Map2, UnionPred, Union0, Union).
+
+:- pred map__union_2(list(K), map(K, V), map(K, V), pred(V, V, V),
+ map(K, V), map(K, V)).
+:- mode map__union_2(in, in, in, pred(in, in, out) is semidet, in, out)
+ is semidet.
+:- mode map__union_2(in, in, in, pred(in, in, out) is det, in, out)
+ is det.
+
+map__union_2([], _, _, _, Union, Union).
+map__union_2([Key | Keys], Map1, Map2, UnionPred, Union0, Union) :-
+ ( map__search(Map1, Key, Value1) ->
+ ( map__search(Map2, Key, Value2) ->
+ call(UnionPred, Value1, Value2, Value)
+ ;
+ Value = Value1
+ )
+ ;
+ map__lookup(Map2, Key, Value)
+ ),
+ map__det_insert(Union0, Key, Value, Union1),
+ map__union_2(Keys, Map1, Map2, UnionPred, Union1, Union).
+
+map__det_union(UnionPred, Map1, Map2, Union, Msg) :-
+ ( map__union(UnionPred, Map1, Map2, UnionPrime) ->
+ Union = UnionPrime
+ ;
+ error(Msg)
+ ).
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
cvs diff: Diffing lp_solve
cvs diff: Diffing lp_solve/lp_examples
cvs diff: Diffing profiler
cvs diff: Diffing runtime
Index: runtime/mercury_accurate_gc.c
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_accurate_gc.c,v
retrieving revision 1.2
diff -u -u -r1.2 mercury_accurate_gc.c
--- mercury_accurate_gc.c 1998/10/16 06:18:41 1.2
+++ mercury_accurate_gc.c 1998/10/16 06:26:08
@@ -369,7 +369,7 @@
** replacing the original with the new copy.
**
** The copying is done using agc_deep_copy, which is
-** the accurate GC verison of deep_copy (it leaves
+** the accurate GC version of deep_copy (it leaves
** forwarding pointers in the old copy of the data, if
** it is on the old heap).
*/
@@ -421,6 +421,10 @@
break;
case MR_LVAL_TYPE_SP:
+ break;
+
+ case MR_LVAL_TYPE_INDIRECT:
+ /* XXX Tyson will have to write the code for this */
break;
case MR_LVAL_TYPE_UNKNOWN:
Index: runtime/mercury_agc_debug.c
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_agc_debug.c,v
retrieving revision 1.5
diff -u -u -r1.5 mercury_agc_debug.c
--- mercury_agc_debug.c 1998/10/16 06:18:42 1.5
+++ mercury_agc_debug.c 1998/10/16 06:26:08
@@ -240,6 +240,12 @@
fprintf(stderr, "sp");
break;
+ case MR_LVAL_TYPE_INDIRECT:
+ fprintf(stderr, "offset %d from ",
+ MR_LIVE_LVAL_INDIRECT_OFFSET(locn_num));
+ /* XXX Tyson will have to complete this */
+ /* based on what he wants this function to do */
+
case MR_LVAL_TYPE_UNKNOWN:
fprintf(stderr, "unknown");
break;
Index: runtime/mercury_layout_util.c
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_layout_util.c,v
retrieving revision 1.1
diff -u -u -r1.1 mercury_layout_util.c
--- mercury_layout_util.c 1998/10/16 06:18:52 1.1
+++ mercury_layout_util.c 1998/10/16 07:39:11
@@ -198,7 +198,10 @@
Word *base_sp, Word *base_curfr, bool *succeeded)
{
int locn_num;
+ int offset;
Word value;
+ Word baseaddr;
+ Word sublocn;
*succeeded = FALSE;
value = 0;
@@ -267,6 +270,23 @@
}
break;
+ case MR_LVAL_TYPE_INDIRECT:
+ offset = MR_LIVE_LVAL_INDIRECT_OFFSET(locn_num);
+ sublocn = MR_LIVE_LVAL_INDIRECT_BASE_LVAL(locn_num);
+ if (MR_print_locn) {
+ printf("offset %d from ", offset);
+ }
+ baseaddr = MR_lookup_live_lval_base(sublocn,
+ saved_regs, base_sp, base_curfr,
+ succeeded);
+ if (! succeeded) {
+ break;
+ }
+ value = MR_typeclass_info_superclass_info(baseaddr,
+ offset);
+ *succeeded = TRUE;
+ break;
+
case MR_LVAL_TYPE_UNKNOWN:
if (MR_print_locn) {
printf("unknown");
@@ -368,6 +388,7 @@
const char *name, Word *type_info)
{
return ((strncmp(name, "TypeInfo", 8) != 0)
+ && (strncmp(name, "TypeClassInfo", 13) != 0)
&& (strncmp(name, "ModuleInfo", 10) != 0)
&& (strncmp(name, "HLDS", 4) != 0)
&& MR_get_type(var, saved_regs, NULL, type_info));
Index: runtime/mercury_stack_layout.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_stack_layout.h,v
retrieving revision 1.9
diff -u -u -r1.9 mercury_stack_layout.h
--- mercury_stack_layout.h 1998/10/16 06:18:56 1.9
+++ mercury_stack_layout.h 1998/10/16 06:35:46
@@ -66,26 +66,33 @@
*/
/*
-** MR_Live_Lval is a Word which describes an lval. This includes:
-** - stack slots, registers, and special lvals such as succip, hp,
-** etc.
+** MR_Live_Lval is a Word which describes an location. This includes
+** lvals such as stack slots, general registers, and special registers
+** such as succip, hp, etc, as well as locations whose address is given
+** as a particular word offset from the memory address found in an lval.
**
-** MR_Live_Lval is encoded using an 8 bit low tag, the rest of the word is a
-** data field describing which stack slot number or register number.
+** What kind of of location an MR_Live_Lval refers to is encoded using
+** a low tag with MR_LIVE_LVAL_TAGBITS bits; the type MR_Lval_Type describes
+** the different tag values. The interpretation of the rest of the word
+** depends on the location type:
**
-** Lval Tag Rest
-** r(Num) 0 Num
-** f(Num) 1 Num
-** stackvar(Num) 2 Num
-** framevar(Num) 3 Num
+** Locn Tag Rest
+** r(Num) 0 Num (register number)
+** f(Num) 1 Num (register number)
+** stackvar(Num) 2 Num (stack slot number)
+** framevar(Num) 3 Num (stack slot number)
** succip 4
** maxfr 5
** curfr 6
** hp 7
** sp 8
-** unknown 9 (The location is not known)
+** indirect(Base, N) 9 See below
+** unknown 10 (The location is not known)
**
-** The type MR_Lval_Type describes the different tag values.
+** For indirect references, the word exclusive of the tag consists of
+** (a) an integer with MR_LIVE_LVAL_OFFSETBITS bits giving the number of
+** words to offset and (b) a MR_Live_Lval value giving the location of
+** the base address. This MR_Live_Lval valud will *not* have an indirect tag.
**
** This data is generated in compiler/stack_layout.m, which must be kept
** in sync with the constants defined here.
@@ -103,16 +110,27 @@
MR_LVAL_TYPE_CURFR,
MR_LVAL_TYPE_HP,
MR_LVAL_TYPE_SP,
- MR_LVAL_TYPE_UNKNOWN
+ MR_LVAL_TYPE_INDIRECT,
+ MR_LVAL_TYPE_UNKNOWN
} MR_Lval_Type;
-#define MR_LIVE_LVAL_TAGBITS 8
+/* This must be in sync with stack_layout__tag_bits */
+#define MR_LIVE_LVAL_TAGBITS 4
-#define MR_LIVE_LVAL_TYPE(Lval) \
- ((MR_Lval_Type) (((Word) Lval) & ((1 << MR_LIVE_LVAL_TAGBITS) - 1)))
+#define MR_LIVE_LVAL_TYPE(Locn) \
+ ((MR_Lval_Type) (((Word) Locn) & ((1 << MR_LIVE_LVAL_TAGBITS) - 1)))
-#define MR_LIVE_LVAL_NUMBER(Lval) \
- ((int) ((Word) Lval) >> MR_LIVE_LVAL_TAGBITS)
+#define MR_LIVE_LVAL_NUMBER(Locn) \
+ ((int) ((Word) Locn) >> MR_LIVE_LVAL_TAGBITS)
+
+/* This must be in sync with stack_layout__offset_bits */
+#define MR_LIVE_LVAL_OFFSETBITS 6
+
+#define MR_LIVE_LVAL_INDIRECT_OFFSET(LocnNumber) \
+ ((int) ((LocnNumber) & ((1 << MR_LIVE_LVAL_OFFSETBITS) - 1)))
+
+#define MR_LIVE_LVAL_INDIRECT_BASE_LVAL(LocnNumber) \
+ (((Word) (LocnNumber)) >> MR_LIVE_LVAL_OFFSETBITS)
/*-------------------------------------------------------------------------*/
/*
cvs diff: cannot find runtime/mercury_trace_util.c
cvs diff: Diffing runtime/GETOPT
cvs diff: Diffing runtime/machdeps
cvs diff: Diffing samples
cvs diff: Diffing samples/c_interface
cvs diff: Diffing samples/c_interface/c_calls_mercury
cvs diff: Diffing samples/c_interface/cplusplus_calls_mercury
cvs diff: Diffing samples/c_interface/mercury_calls_c
cvs diff: Diffing samples/c_interface/mercury_calls_cplusplus
cvs diff: Diffing samples/c_interface/mercury_calls_fortran
cvs diff: Diffing samples/c_interface/simpler_c_calls_mercury
cvs diff: Diffing samples/c_interface/simpler_cplusplus_calls_mercury
cvs diff: Diffing samples/diff
cvs diff: Diffing scripts
cvs diff: Diffing tests
cvs diff: Diffing tests/benchmarks
cvs diff: Diffing tests/debugger
Index: tests/debugger/Mmakefile
===================================================================
RCS file: /home/mercury1/repository/tests/debugger/Mmakefile,v
retrieving revision 1.11
diff -u -u -r1.11 Mmakefile
--- Mmakefile 1998/10/16 06:19:30 1.11
+++ Mmakefile 1998/10/17 08:34:33
@@ -8,13 +8,12 @@
#-----------------------------------------------------------------------------#
-# Commented out tests are currently disabled because they fail, but are
-# not vital at the moment because the debugger is still a work in
-# progress.
-
DEBUGGER_PROGS= \
- debugger_regs \
- interpreter \
+ debugger_regs \
+ existential_type_classes \
+ implied_instance \
+ interpreter \
+ multi_parameter \
queens
MCFLAGS = --trace deep
@@ -45,20 +44,20 @@
debugger_regs.out: debugger_regs debugger_regs.inp
mdb ./debugger_regs < debugger_regs.inp > debugger_regs.out
+existential_type_classes.out: existential_type_classes queens.inp
+ mdb ./existential_type_classes < existential_type_classes.inp > existential_type_classes.out
+
+implied_instance.out: implied_instance implied_instance.inp
+ mdb ./implied_instance < implied_instance.inp > implied_instance.out
+
interpreter.out: interpreter interpreter.inp
mdb ./interpreter interpreter.m < interpreter.inp > interpreter.out
+multi_parameter.out: multi_parameter multi_parameter.inp
+ mdb ./multi_parameter < multi_parameter.inp > multi_parameter.out
+
queens.out: queens queens.inp
mdb ./queens < queens.inp > queens.out
-
-debugger_regs_lib.out: debugger_regs_lib debugger_regs_lib.inp
- mdb ./debugger_regs_lib < debugger_regs_lib.inp > debugger_regs_lib.out
-
-interpreter_lib.out: interpreter_lib interpreter_lib.inp
- mdb ./interpreter_lib interpreter_lib.m < interpreter_lib.inp > interpreter_lib.out
-
-queens_lib.out: queens_lib queens_lib.inp
- mdb ./queens_lib < queens_lib.inp > queens_lib.out
# We ignore the result of this action because
# the exit status of grep is not useful in this case
Index: tests/debugger/existential_type_classes.exp
===================================================================
RCS file: existential_type_classes.exp
diff -N existential_type_classes.exp
--- /dev/null Wed May 28 10:49:58 1997
+++ existential_type_classes.exp Sat Oct 17 19:40:15 1998
@@ -0,0 +1,152 @@
+ 1: 1 1 CALL pred existential_type_classes:main/2-0 (det)
+s => step
+g => goto
+f => finish
+r => retry
+v => vars
+p => print *
+d => stack
+c => continue
+b => break
+h => help
+? => help
+mdb> Command echo enabled.
+mdb> alias P print *
+P => print *
+mdb> register --quiet
+mdb> break -i do_foo
+ 0: + stop interface pred existential_type_classes:do_foo/2-0 (det)
+mdb> continue -a
+ 2: 2 2 CALL pred existential_type_classes:do_foo/2-0 (det)
+mdb> P
+ HeadVar__1 42
+mdb>
+ 3: 3 3 CALL pred existential_type_classes:foo/2-0 (det)
+mdb> P
+ HeadVar__1 42
+mdb>
+ 4: 4 4 CALL pred existential_type_classes:Introduced_pred_for_existential_type_classes__fooable__int_0_____existential_type_classes__foo_2/2-0 (det)
+mdb> P
+ HeadVar__1 42
+mdb> continue -a
+ 5: 5 5 CALL pred existential_type_classes:int_foo/2-0 (det)
+ 6: 5 5 EXIT pred existential_type_classes:int_foo/2-0 (det)
+ 7: 4 4 EXIT pred existential_type_classes:Introduced_pred_for_existential_type_classes__fooable__int_0_____existential_type_classes__foo_2/2-0 (det)
+ 8: 3 3 EXIT pred existential_type_classes:foo/2-0 (det)
+ 9: 2 2 EXIT pred existential_type_classes:do_foo/2-0 (det)
+mdb> P
+ HeadVar__1 42
+ HeadVar__2 84
+mdb> continue -a
+ 10: 6 2 CALL pred existential_type_classes:do_foo/2-0 (det)
+mdb> P
+ HeadVar__1 blah
+mdb>
+ 11: 7 3 CALL pred existential_type_classes:foo/2-0 (det)
+mdb> P
+ HeadVar__1 blah
+mdb>
+ 12: 8 4 CALL pred existential_type_classes:Introduced_pred_for_existential_type_classes__fooable__string_0_____existential_type_classes__foo_2/2-0 (det)
+mdb> P
+ HeadVar__1 blah
+mdb> continue -a
+ 13: 9 5 CALL pred existential_type_classes:string_foo/2-0 (det)
+ 14: 9 5 EXIT pred existential_type_classes:string_foo/2-0 (det)
+ 15: 8 4 EXIT pred existential_type_classes:Introduced_pred_for_existential_type_classes__fooable__string_0_____existential_type_classes__foo_2/2-0 (det)
+ 16: 7 3 EXIT pred existential_type_classes:foo/2-0 (det)
+ 17: 6 2 EXIT pred existential_type_classes:do_foo/2-0 (det)
+mdb> P
+ HeadVar__1 blah
+ HeadVar__2 4
+mdb> continue -a
+ 18: 10 2 CALL func existential_type_classes:my_exist_t/1-0 (det)
+ 19: 10 2 EXIT func existential_type_classes:my_exist_t/1-0 (det)
+ 20: 11 2 CALL pred existential_type_classes:do_foo/2-0 (det)
+mdb> P
+ HeadVar__1 43
+mdb>
+ 21: 12 3 CALL pred existential_type_classes:foo/2-0 (det)
+mdb> P
+ HeadVar__1 43
+mdb>
+ 22: 13 4 CALL pred existential_type_classes:Introduced_pred_for_existential_type_classes__fooable__int_0_____existential_type_classes__foo_2/2-0 (det)
+mdb> P
+ HeadVar__1 43
+mdb> continue -a
+ 23: 14 5 CALL pred existential_type_classes:int_foo/2-0 (det)
+ 24: 14 5 EXIT pred existential_type_classes:int_foo/2-0 (det)
+ 25: 13 4 EXIT pred existential_type_classes:Introduced_pred_for_existential_type_classes__fooable__int_0_____existential_type_classes__foo_2/2-0 (det)
+ 26: 12 3 EXIT pred existential_type_classes:foo/2-0 (det)
+ 27: 11 2 EXIT pred existential_type_classes:do_foo/2-0 (det)
+mdb> P
+ HeadVar__1 43
+ HeadVar__2 86
+mdb> continue -a
+ 28: 15 2 CALL func existential_type_classes:call_my_exist_t/1-0 (det)
+ 29: 16 3 CALL func existential_type_classes:my_exist_t/1-0 (det)
+ 30: 16 3 EXIT func existential_type_classes:my_exist_t/1-0 (det)
+ 31: 15 2 EXIT func existential_type_classes:call_my_exist_t/1-0 (det)
+ 32: 17 2 CALL pred existential_type_classes:do_foo/2-0 (det)
+mdb> P
+ HeadVar__1 43
+mdb>
+ 33: 18 3 CALL pred existential_type_classes:foo/2-0 (det)
+mdb> P
+ HeadVar__1 43
+mdb>
+ 34: 19 4 CALL pred existential_type_classes:Introduced_pred_for_existential_type_classes__fooable__int_0_____existential_type_classes__foo_2/2-0 (det)
+mdb> P
+ HeadVar__1 43
+mdb> continue -a
+ 35: 20 5 CALL pred existential_type_classes:int_foo/2-0 (det)
+ 36: 20 5 EXIT pred existential_type_classes:int_foo/2-0 (det)
+ 37: 19 4 EXIT pred existential_type_classes:Introduced_pred_for_existential_type_classes__fooable__int_0_____existential_type_classes__foo_2/2-0 (det)
+ 38: 18 3 EXIT pred existential_type_classes:foo/2-0 (det)
+ 39: 17 2 EXIT pred existential_type_classes:do_foo/2-0 (det)
+mdb> P
+ HeadVar__1 43
+ HeadVar__2 86
+mdb> continue -a
+ 40: 21 2 CALL func existential_type_classes:my_univ_value/2-0 (det)
+ 41: 21 2 EXIT func existential_type_classes:my_univ_value/2-0 (det)
+ 42: 22 2 CALL pred existential_type_classes:do_foo/2-0 (det)
+mdb> P
+ HeadVar__1 44
+mdb>
+ 43: 23 3 CALL pred existential_type_classes:foo/2-0 (det)
+mdb> P
+ HeadVar__1 44
+mdb>
+ 44: 24 4 CALL pred existential_type_classes:Introduced_pred_for_existential_type_classes__fooable__int_0_____existential_type_classes__foo_2/2-0 (det)
+mdb> P
+ HeadVar__1 44
+mdb> continue -a
+ 45: 25 5 CALL pred existential_type_classes:int_foo/2-0 (det)
+ 46: 25 5 EXIT pred existential_type_classes:int_foo/2-0 (det)
+ 47: 24 4 EXIT pred existential_type_classes:Introduced_pred_for_existential_type_classes__fooable__int_0_____existential_type_classes__foo_2/2-0 (det)
+ 48: 23 3 EXIT pred existential_type_classes:foo/2-0 (det)
+ 49: 22 2 EXIT pred existential_type_classes:do_foo/2-0 (det)
+mdb> P
+ HeadVar__1 44
+ HeadVar__2 88
+mdb>
+ 50: 26 2 CALL func existential_type_classes:call_my_univ_value/2-0 (det)
+mdb> P
+ HeadVar__1 "something"
+mdb>
+ 51: 27 3 CALL func existential_type_classes:my_univ_value/2-0 (det)
+mdb> P
+ HeadVar__1 "something"
+mdb> continue -a
+ 52: 27 3 EXIT func existential_type_classes:my_univ_value/2-0 (det)
+ 53: 26 2 EXIT func existential_type_classes:call_my_univ_value/2-0 (det)
+ 54: 28 2 CALL pred existential_type_classes:do_foo/2-0 (det)
+mdb> P
+ HeadVar__1 44
+mdb> continue -S
+84
+4
+86
+86
+88
+88
Index: tests/debugger/existential_type_classes.inp
===================================================================
RCS file: existential_type_classes.inp
diff -N existential_type_classes.inp
--- /dev/null Wed May 28 10:49:58 1997
+++ existential_type_classes.inp Sat Oct 17 17:33:16 1998
@@ -0,0 +1,51 @@
+echo on
+alias P print *
+register --quiet
+break -i do_foo
+continue -a
+P
+
+P
+
+P
+continue -a
+P
+continue -a
+P
+
+P
+
+P
+continue -a
+P
+continue -a
+P
+
+P
+
+P
+continue -a
+P
+continue -a
+P
+
+P
+
+P
+continue -a
+P
+continue -a
+P
+
+P
+
+P
+continue -a
+P
+
+P
+
+P
+continue -a
+P
+continue -S
Index: tests/debugger/existential_type_classes.m
===================================================================
RCS file: existential_type_classes.m
diff -N existential_type_classes.m
--- /dev/null Wed May 28 10:49:58 1997
+++ existential_type_classes.m Sat Oct 17 17:30:08 1998
@@ -0,0 +1,79 @@
+% This test case tests the combination of existential types and
+% type classes, i.e. existential type class constraints.
+
+:- module existential_type_classes.
+:- interface.
+:- import_module io.
+
+:- pred main(io__state::di, state::uo) is det.
+
+:- implementation.
+:- import_module std_util, int, string, term.
+
+:- typeclass fooable(T) where [
+ pred foo(T::in, int::out) is det
+].
+:- typeclass barable(T) where [
+ pred bar(T::in, int::out) is det
+].
+
+:- instance fooable(int) where [
+ pred(foo/2) is int_foo
+].
+
+:- instance fooable(string) where [
+ pred(foo/2) is string_foo
+].
+
+ % my_univ_value(Univ):
+ % returns the value of the object stored in Univ.
+:- some [T] (func my_univ_value(univ) = T & fooable(T)).
+
+:- some [T] (func call_my_univ_value(univ) = T & fooable(T)).
+
+:- some [T] (func my_exist_t = T & fooable(T)).
+
+:- some [T] (func call_my_exist_t = T & (fooable(T))).
+
+:- pred int_foo(int::in, int::out) is det.
+int_foo(X, 2*X).
+
+:- pred string_foo(string::in, int::out) is det.
+string_foo(S, N) :- string__length(S, N).
+
+main -->
+ {
+ do_foo(42, T1),
+ do_foo("blah", T2),
+ do_foo(my_exist_t, T3),
+ do_foo(call_my_exist_t, T4),
+ do_foo(my_univ_value(univ(45)), T5),
+ do_foo(call_my_univ_value(univ("something")), T6)
+ },
+ io__write_int(T1), nl,
+ io__write_int(T2), nl,
+ io__write_int(T3), nl,
+ io__write_int(T4), nl,
+ io__write_int(T5), nl,
+ io__write_int(T6), nl.
+
+:- pred do_foo(T::in, int::out) is det <= fooable(T).
+
+do_foo(X, N) :-
+ foo(X, N).
+
+call_my_exist_t = my_exist_t.
+
+call_my_univ_value(Univ) = my_univ_value(Univ).
+
+my_exist_t = 43.
+
+/*
+XXX we don't yet support `pragma c_code' for existential type class constraints
+:- pragma c_code(my_univ_value(Univ::in) = (Value::out), will_not_call_mercury, "
+ TypeInfo_for_T = field(mktag(0), Univ, UNIV_OFFSET_FOR_TYPEINFO);
+ Value = field(mktag(0), Univ, UNIV_OFFSET_FOR_DATA);
+ ClassInfo_1 = XXX;
+").
+*/
+my_univ_value(_Univ) = 44.
Index: tests/debugger/implied_instance.exp
===================================================================
RCS file: implied_instance.exp
diff -N implied_instance.exp
--- /dev/null Wed May 28 10:49:58 1997
+++ implied_instance.exp Sat Oct 17 19:40:24 1998
@@ -0,0 +1,54 @@
+ 1: 1 1 CALL pred implied_instance:main/2-0 (det)
+s => step
+g => goto
+f => finish
+r => retry
+v => vars
+p => print *
+d => stack
+c => continue
+b => break
+h => help
+? => help
+mdb> Command echo enabled.
+mdb> register --quiet
+mdb> alias P print *
+P => print *
+mdb> goto 2
+ 2: 2 2 CALL pred implied_instance:p/2-0 (det)
+mdb> P
+ HeadVar__1 2
+mdb>
+ 3: 3 3 CALL pred implied_instance:Introduced_pred_for_implied_instance__sumable__int_0_____implied_instance__p_2/2-0 (det)
+mdb> P
+ HeadVar__1 2
+mdb> break -e p
+ 0: + stop entry pred implied_instance:p/2-0 (det)
+mdb> continue -a
+ 4: 4 4 CALL pred implied_instance:copy_int/2-0 (det)
+ 5: 4 4 EXIT pred implied_instance:copy_int/2-0 (det)
+ 6: 3 3 EXIT pred implied_instance:Introduced_pred_for_implied_instance__sumable__int_0_____implied_instance__p_2/2-0 (det)
+ 7: 2 2 EXIT pred implied_instance:p/2-0 (det)
+ 8: 5 2 CALL pred implied_instance:p/2-0 (det)
+mdb> P
+ HeadVar__1 [42, 24, 1, 2, 3]
+mdb>
+ 9: 6 3 CALL pred implied_instance:Introduced_pred_for_implied_instance__sumable__list_0_list_1_____implied_instance__p_2/2-0 (det)
+mdb> P
+ HeadVar__1 [42, 24, 1, 2, 3]
+mdb>
+ 10: 7 4 CALL pred implied_instance:sum_int_list/2-0 (det)
+mdb> P
+ HeadVar__1 [42, 24, 1, 2, 3]
+mdb> continue -a
+ 11: 7 4 SWTC pred implied_instance:sum_int_list/2-0 (det) s1;
+ 12: 8 5 CALL pred implied_instance:p/2-0 (det)
+mdb> P
+ HeadVar__1 42
+mdb>
+ 13: 9 6 CALL pred implied_instance:Introduced_pred_for_implied_instance__sumable__int_0_____implied_instance__p_2/2-0 (det)
+mdb> P
+ HeadVar__1 42
+mdb> continue -S
+2
+72
Index: tests/debugger/implied_instance.inp
===================================================================
RCS file: implied_instance.inp
diff -N implied_instance.inp
--- /dev/null Wed May 28 10:49:58 1997
+++ implied_instance.inp Sat Oct 17 17:18:23 1998
@@ -0,0 +1,19 @@
+echo on
+register --quiet
+alias P print *
+goto 2
+P
+
+P
+break -e p
+continue -a
+P
+
+P
+
+P
+continue -a
+P
+
+P
+continue -S
Index: tests/debugger/implied_instance.m
===================================================================
RCS file: implied_instance.m
diff -N implied_instance.m
--- /dev/null Wed May 28 10:49:58 1997
+++ implied_instance.m Sat Oct 17 17:15:01 1998
@@ -0,0 +1,46 @@
+:- module implied_instance.
+
+:- interface.
+
+:- pred main(io__state::di, io__state::uo) is det.
+
+:- import_module io.
+
+:- implementation.
+
+:- import_module int, list.
+
+:- typeclass sumable(A) where [
+ pred p(A::in, int::out) is det
+].
+
+:- instance sumable(int) where [
+ pred(p/2) is copy_int
+].
+
+:- instance sumable(list(T)) <= sumable(T) where [
+ pred(p/2) is sum_int_list
+].
+
+main -->
+ { p(2, SumA) },
+ { p([42, 24, 1, 2, 3], SumB) },
+ io__write_int(SumA),
+ io__write_string("\n"),
+ io__write_int(SumB),
+ io__write_string("\n").
+
+:- pred copy_int(int, int).
+:- mode copy_int(in, out) is det.
+
+copy_int(N, N).
+
+:- pred sum_int_list(list(T), int) <= sumable(T).
+:- mode sum_int_list(in, out) is det.
+
+sum_int_list([], 0).
+sum_int_list([X|Xs], Sum) :-
+ p(X, SumA),
+ sum_int_list(Xs, SumB),
+ Sum = SumA + SumB.
+
Index: tests/debugger/multi_parameter.exp
===================================================================
RCS file: multi_parameter.exp
diff -N multi_parameter.exp
--- /dev/null Wed May 28 10:49:58 1997
+++ multi_parameter.exp Sat Oct 17 19:39:45 1998
@@ -0,0 +1,46 @@
+ 1: 1 1 CALL pred multi_parameter:main/2-0 (det)
+s => step
+g => goto
+f => finish
+r => retry
+v => vars
+p => print *
+d => stack
+c => continue
+b => break
+h => help
+? => help
+mdb> Command echo enabled.
+mdb>
+ 2: 2 2 CALL pred multi_parameter:foo/2-0 (det)
+mdb> print *
+ HeadVar__1 z
+mdb>
+ 3: 3 3 CALL pred multi_parameter:a/2-0 (det)
+mdb> print *
+ HeadVar__1 z
+mdb>
+ 4: 4 4 CALL pred multi_parameter:Introduced_pred_for_multi_parameter__m__character_0_int_0_____multi_parameter__a_2/2-0 (det)
+mdb> print *
+ HeadVar__1 z
+mdb>
+ 5: 4 4 EXIT pred multi_parameter:Introduced_pred_for_multi_parameter__m__character_0_int_0_____multi_parameter__a_2/2-0 (det)
+mdb> print *
+ HeadVar__1 z
+ HeadVar__2 122
+mdb>
+ 6: 3 3 EXIT pred multi_parameter:a/2-0 (det)
+mdb> print *
+ HeadVar__1 z
+ HeadVar__2 122
+mdb>
+ 7: 2 2 EXIT pred multi_parameter:foo/2-0 (det)
+mdb> print *
+ HeadVar__1 z
+ HeadVar__2 122
+mdb>
+122
+ 8: 1 1 EXIT pred multi_parameter:main/2-0 (det)
+mdb> print *
+ HeadVar__2 state('<<c_pointer>>')
+mdb> continue -S
Index: tests/debugger/multi_parameter.inp
===================================================================
RCS file: multi_parameter.inp
diff -N multi_parameter.inp
--- /dev/null Wed May 28 10:49:58 1997
+++ multi_parameter.inp Sat Oct 17 17:22:05 1998
@@ -0,0 +1,16 @@
+echo on
+
+print *
+
+print *
+
+print *
+
+print *
+
+print *
+
+print *
+
+print *
+continue -S
Index: tests/debugger/multi_parameter.m
===================================================================
RCS file: multi_parameter.m
diff -N multi_parameter.m
--- /dev/null Wed May 28 10:49:58 1997
+++ multi_parameter.m Sat Oct 17 16:51:24 1998
@@ -0,0 +1,32 @@
+
+:- module multi_parameter.
+
+:- interface.
+
+:- import_module io.
+
+:- pred main(io__state::di, io__state::uo) is det.
+
+:- implementation.
+
+:- import_module char.
+
+:- typeclass m(A, B) where [
+ pred a(A, B),
+ mode a(in, out) is det
+].
+
+:- instance m(char, int) where [
+ pred(a/2) is char__to_int
+].
+
+main -->
+ { foo('z', X) },
+ io__write_int(X),
+ io__nl.
+
+:- pred foo(A, B) <= m(A,B).
+:- mode foo(in, out) is det.
+:- pragma no_inline(foo/2).
+
+foo(X, Y) :- a(X, Y).
cvs diff: Diffing tests/general
cvs diff: Diffing tests/hard_coded
cvs diff: Diffing tests/hard_coded/typeclasses
Index: tests/hard_coded/typeclasses/Mmakefile
===================================================================
RCS file: /home/mercury1/repository/tests/hard_coded/typeclasses/Mmakefile,v
retrieving revision 1.12
diff -u -u -r1.12 Mmakefile
--- Mmakefile 1998/10/16 06:19:57 1.12
+++ Mmakefile 1998/10/17 06:51:59
@@ -59,7 +59,7 @@
--typeinfo-liveness
MCFLAGS-inference_test = --infer-all
MCFLAGS-inference_test_2 = --infer-all
-MCFLAGS-existential_type_classes = --infer-all --trace deep
+MCFLAGS-existential_type_classes = --infer-all
MCFLAGS-lambda_multi_constraint_same_tvar = --infer-all
#-----------------------------------------------------------------------------#
cvs diff: Diffing tests/invalid
cvs diff: Diffing tests/misc_tests
cvs diff: Diffing tests/tabling
cvs diff: Diffing tests/term
cvs diff: Diffing tests/valid
cvs diff: Diffing tests/warnings
cvs diff: Diffing tools
cvs diff: Diffing trace
Index: trace/mercury_trace_internal.c
===================================================================
RCS file: /home/mercury1/repository/mercury/trace/mercury_trace_internal.c,v
retrieving revision 1.3
diff -u -u -r1.3 mercury_trace_internal.c
--- mercury_trace_internal.c 1998/10/16 10:15:49 1.3
+++ mercury_trace_internal.c 1998/10/16 10:15:58
@@ -1662,6 +1662,7 @@
*/
if ((strncmp(name, "TypeInfo", 8) == 0)
+ || (strncmp(name, "TypeClassInfo", 13) == 0)
|| (strncmp(name, "ModuleInfo", 10) == 0)
|| (strncmp(name, "HLDS", 4) == 0))
return;
cvs diff: Diffing trial
cvs diff: Diffing util
More information about the developers
mailing list