[m-rev.] for review: term size profiling
Zoltan Somogyi
zs at cs.mu.OZ.AU
Tue May 27 02:38:34 AEST 2003
For review by Fergus.
Zoltan.
Implement the infrastructure for term size profiling. This means adding two
new grade components, tsw and tsc, and implementing them in the LLDS code
generator. In grades including tsw (term size words), each term is augmented
with an extra word giving the number of heap words it contains; in grades
including tsc (term size cells), each term is augmented with an extra word
giving the number of heap cells it contains. The extra word is at the start,
at offset -1, to leave almost all of the machinery for accessing the heap
unchanged.
For now, the only way to access term sizes is with a new mdb command,
"term_size <varspec>". Later, we will use term sizes in conjunction with
deep profiling to do experimental complexity analysis, but that requires
a lot more research. This diff is a necessary first step.
The implementation of term size profiling consists of three main parts:
- a source-to-source transform that computes the size of each heap cell
when it is constructed (and increments it in the rare cases when a free
argument of an existing heap cell is bound),
- a relatively small change to the code generator that reserves the extra
slot in new heap cells, and
- extensions to the facilities for creating cells from C code to record
the extra information we now need.
In addition to these three things, the diff also contains an overhaul of
polymorphism.m to make the source-to-source transform possible. This overhaul
includes separating type_ctor_infos and type_infos as strictly as possible
from each other, casting from one to the other as needed. It also includes
separating type_ctor_infos, type_infos, base_typeclass_infos and
typeclass_infos from plain user-defined types in type categorications.
This change needs this separation because values of those four types do not
have size slots, but they ought to be treated specially in other situations
as well (e.g. by tabling).
compiler/size_prof.m:
A new module implementing the source-to-source transform.
compiler/notes/compiler_design.html:
Mention the new module.
compiler/transform_hlds.m:
Include size_prof as a submodule of transform_hlds.
compiler/mercury_compile.m:
If term size profiling is enabled, invoke its source-to-source
transform.
compiler/hlds_goal.m:
Extend construction unifications with an optional slot for recording
the size of the term if the size is a constant, or the identity of the
variable holding the size, if the size is not constant. This is
needed by the source-to-source transform.
compiler/quantification.m:
Treat the variable reference that may be in this slot as a nonlocal
variable of construction unifications, since the code generator needs
this.
compiler/compile_target_code.m:
Handle the new grade components.
compiler/options.m:
Implement the options that control term size profiling.
doc/user_guide.texi
Document the options and grade components that control term size
profiling.
compiler/modules.m:
Import the new builtin library module that implements the operations
needed by term size profiling automatically in term size profiling
grades.
Switch the predicate involved to use state var syntax.
compiler/prog_util.m:
Add predicates and functions that return the sym_names of the modules
needed by term size profiling and some that could be needed later.
compiler/unify_gen.m:
compiler/var_locn.m:
Reserve an extra slot in heap cells and fill them in in unifications
marked by size_prof.
compiler/goal_util.m:
compiler/hlds_module.m:
When generating calls, specify whether the call is to a predicate or
function. Previously, all calls generated here were to predicates,
but size_prof wants to add calls to int.+. Actually, we call the
function term_size_prof_builtin.term_size_plus, which is the same
as int.+, except it doesn't get deleted by dead proc elimination.
compiler/goal_util.m:
compiler/unify_proc.m:
Move a predicate that generates unsafe casts from unify_proc to
goal_util, since polymorphism may also want to use it someday.
compiler/builtin_ops.m:
Add term_size_prof_builtin.term_size_plus as a builtin, with the same
implementation as int.+.
compiler/make_hlds.m:
Disable warnings about clauses for builtins while the change to
builtin_ops is bootstrapped.
compiler/handle_options.m:
Handle the implications of term size profiling grades.
Add a -D flag value to print HLDS components relevant to HLDS
transformations.
compiler/polymorphism.m:
Export predicates that generate goals to create type_infos and
type_ctor_infos to add_to_construct.m. Rewrite their documentation
to make it more detailed.
Make orders of arguments amenable to the use of state variable syntax.
Consolidate knowledge of which type categories have builtin unify and
compare predicates in one place.
Add code to leave the types of type_ctor_infos alone: instead of
changing their types to type_info when used as arguments of other
type_infos, create a new variable of type type_info instead, and
use an unsafe_cast. This would make the HLDS closer to being type
correct, but this new code is currently commented out, for two
reasons. First, common.m is currently not smart enough to figure out
that if X and Y are equal, then similar unsafe_casts of X and Y
are also equal, and this causes the compiler do not detect some
duplicate calls it used to detect. Second, the code generators
are also not smart enough to know that if Z is an unsafe_cast of X,
then X and Z do not need separate stack slots, but can use the same
slot.
compiler/type_util.m:
Add utility predicates for returning the types of type_infos and
type_ctor_infos, for use by new code in polymorphism.m.
Move some utility predicates here from other modules, since they
are now used by more than one module.
Rename the type `builtin_type' as type_category, to better reflect
what it does. Extend it to put the type_info, type_ctor_info,
typeclass_info, base_typeclass_info and void types into categories
of their own: treating these types as if they were a user-defined
type (which is how it used to be classified) is not always appropriate.
Rename the functor polymorphic_type to variable_type, since types
such as list(T) are polymorphic, but they fall into the user-defined
category. Rename user_type as user_ctor_type, since list(int) is not
wholly user-defined but falls into this category. Rename pred_type
as higher_order_type, since it also encompasses functions.
Replace code that used to check for a few of the alternatives
of this type with code that does a full switch on the type,
to ensure that they are updated if the type definition ever
changes again.
compiler/pseudo_type_info.m:
Delete a predicate now in type_util.m.
compiler/mlds_to_c.m:
compiler/mlds_to_gcc.m:
Treat type_infos and type_ctor_infos as builtin types in their own
right, mapping each to its own C type. Typeclass_infos and
base_typeclass_infos are still treated as user-defined types.
compiler/mlds_to_il.m:
compiler/mlds_to_java.m:
Treat type_infos, type_ctor_infos, typeclass_infos and
base_typeclass_infos as user-defined types, as before.
compiler/hlds_pred.m:
Require interface typeinfo liveness when term size profiling is
enabled.
compiler/hlds_out.m:
Print more details of unifications if HLDS dump flags call for it.
(The flag test is in the caller of the modified predicate.)
Print the goal annotations that specify which variables need to be
saved on the stack on one line, to allow people to grep for them.
doc/user_guide.tex:
Document the extended output from specifying the the 'u' flag.
compiler/llds.m:
Extend incr_hp instructions and data_addr_consts with optional fields
that allow the code generator to refer to N words past the start of
a static structure. Term size profiling uses this with N=1.
compiler/llds_out.m:
Minor updates to conform to the changes above.
compiler/llds_common.m:
Minor updates to conform to the changes above.
Use counters where relevant.
compiler/stack_layout.m:
Minor updates to conform to the changes above.
Delete an unused predicate.
compiler/accumulator.m:
compiler/add_heap_ops.m:
compiler/add_trail_ops.m:
compiler/aditi_builtin_ops.m:
compiler/bytecode_gen.m:
compiler/code_exprn.m:
compiler/code_info.m:
compiler/common.m:
compiler/constraint.m:
compiler/dead_proc_elim.m:
compiler/deep_profiling.m:
compiler/delay_construct.m:
compiler/dense_switch.m:
compiler/dependency_graph.m:
compiler/det_analysis.m:
compiler/dnf.m:
compiler/dupelim.m:
compiler/exprn_aux.m:
compiler/goal_form.m:
compiler/higher_order.m:
compiler/intermod.m:
compiler/jumpopt.m:
compiler/lambda.m:
compiler/lco.m:
compiler/livemap.m:
compiler/ll_pseudo_type_info.m:
compiler/lookup_switch.m:
compiler/loop_inv.m:
compiler/magic.m:
compiler/magic_util.m:
compiler/mark_static_terms.m:
compiler/middle_rec.m:
compiler/ml_code_util.m:
compiler/ml_switch_gen.m:
compiler/ml_unify_gen.m:
compiler/mlds.m:
compiler/mlds_to_c.m:
compiler/mlds_to_gcc.m:
compiler/mlds_to_il.m:
compiler/mlds_to_java.m:
compiler/modecheck_unify.m:
compiler/opt_debug.m:
compiler/opt_util.m:
compiler/par_conj_gen.m:
compiler/pd_cost.m:
compiler/pd_util.m:
compiler/post_typecheck.m:
compiler/reassign.m:
compiler/rl.m:
compiler/rl_exprn.m:
compiler/rl_gen.m:
compiler/rl_key.m:
compiler/saved_vars.m:
compiler/simplify.m:
compiler/special_pred.m:
compiler/stack_opt.m:
compiler/static_term.m:
compiler/stratify.m:
compiler/string_switch.m:
compiler/switch_gen.m:
compiler/switch_util.m:
compiler/table_gen.m:
compiler/term_traversal.m:
compiler/term_util.m:
compiler/type_ctor_info.m:
compiler/typecheck.m:
compiler/unify_proc.m:
compiler/unused_args.m:
compiler/use_local_vars.m:
Minor updates to conform to the changes above.
browser/declarative_tree.m:
browser/program_representation.m:
compiler/prog_rep.m:
Fix a bug: treat unsafe casts as we treat assignment unifications.
We used to treat them as calls, which was wrong, because unlike calls,
unsafe_casts do not generate trace events.
Minor updates to conform to the changes above.
library/term_size_prof_builtin.m:
New module containing helper predicates for term size profiling.
library/library.m:
Include the new module in the library.
doc/Mmakefile:
Do not include the term_size_prof_builtin module in the library
documentation.
library/array.m:
library/benchmarking.m:
library/construct.m:
library/deconstruct.m:
library/io.m:
library/sparse_bitset.m:
library/store.m:
library/string.m:
Replace all uses of MR_incr_hp with MR_offset_incr_hp, to ensure
that we haven't overlooked any places where offsets may need to be
specified.
Use new macros defined by the runtime system when constructing
terms (which all happen to be lists) in C code. These new macros
specify the types of the cell arguments, allowing the implementation
to figure out the size of the new cell based on the sizes of its
fields.
Fix formatting of foreign_procs.
library/private_builtin.m:
Define some constant type_info structures for use by these macros.
They cannot be defined in the runtime, since they refer to types
defined in the library (list.list and std_util.univ).
util/mkinit.c:
Make the addresses of these type_info structures available to the
runtime.
runtime/mercury_init.h:
Declare these type_info structures, for use in mkinit-generated
*_init.c files.
runtime/mercury_wrapper.[ch]:
Declare and define the variables that hold these addresses, for use
in the new macros for constructing typed lists.
Since term size profiling can refer to a memory cell by a pointer
that is offset by one word, register the extra offsets with the Boehm
collector if is being used.
Document the incompatibility of MR_HIGHTAGS and the Boehm collector.
Document the new condition for enabling low level debugging
implemented by the change to mercury_debug.c (see below).
runtime/mercury_tags.h:
Define new macros for constructing typed lists.
Provide macros for preserving the old interface presented by this file
to the extent possible. Uses of the old MR_list_cons macro will
continue to work in grades without term size profiling. In term
size profiling grades, their use will get a C compiler error.
Fix a bug caused by a missing backslash.
runtime/mercury_engine.[ch]:
Define a new debugging flag whose purpose is to allow an mdb command,
"flag enabled on", to turn on low level debugging if the
executable was compiled with the appropriate options.
runtime/mercury_heap.h:
Change the basic macros for allocating new heap cells to take
an optional offset argument. If this is nonzero, the macros
increment the returned address by the given number of words.
Term size profiling specifies offset=1, reserving the extra
word at the start (which is ignored by all components of the
system except term size profiling) for holding the size of the term.
Provide macros for preserving the old interface presented by this file
to the extent possible. Since the old MR_create[123] and MR_list_cons
macros did not specify type information, they had to be changed
to take additional arguments. This affects only hand-written C code.
Make the heap allocation routines debuggable.
runtime/mercury_string.h:
Provide some needed variants of the macro for copying strings.
runtime/mercury_debug.[ch]:
Add diagnostic routines to debug heap allocations.
Update the debugging routines for hand-allocated cells to print the
values of the term size slot as well as the other slots in the relevant
grades.
When recomputing MR_lld_print_enabled, respect the new debugging flag.
Fix a bug: do not try to access the dummy frame at the bottom of the
nondet stack.
runtime/mercury_deconstruct_macros.h:
runtime/mercury_type_info.c:
Supply type information when constructing terms.
runtime/mercury_deep_copy_body.h:
Preserve the term size slot when copying terms.
runtime/mercury_deep_copy_body.h:
runtime/mercury_ml_expand_body.h:
Use MR_offset_incr_hp instead of MR_incr_hp to ensure that all places
that allocate cells also allocate space for the term size slot if
necessary.
Reduce code duplication by using a now standard macro for copying
strings.
runtime/mercury_grade.h:
Handle the two new grade components.
runtime/mercury_conf_param.h:
Document the C macros used to control the two new grade components,
as well as MR_DEBUG_HEAP_ALLOC.
Detect incompatibilities between high level code and profiling.
runtime/mercury_term_size.[ch]:
A new module to house a function to find and return term sizes
stored in heap cells.
runtime/mercury_proc_id.h:
runtime/mercury_univ.h:
New header files. mercury_proc_id.h contains the (unchanged)
definition of MR_Proc_Id, while mercury_univ.h contains the
definitions of the macros for manipulating univs that used to be
in mercury_type_info.h, updated to use the new macros for allocating
memory.
In the absence of these header files, the following circularity
would ensue:
mercury_deep_profiling.h includes mercury_stack_layout.h
- needs definition of MR_Proc_Id
mercury_stack_layout.h needs mercury_type_info.h
- needs definition of MR_PseudoTypeInfo
mercury_type_info.h needs mercury_heap.h
- needs heap allocation macros for MR_new_univ_on_hp
mercury_heap.h includes mercury_deep_profiling.h
- needs MR_current_call_site_dynamic for recording allocations
Breaking the circular dependency in two places, not just one, is to
minimize similar problems in the future.
runtime/mercury_types.h:
Move more typedefs here from other header files, such as
mercury_stack_layout.h and mercury_type_info.h; the declarations of the
structures they refer to stay in their original files. These forward
declarations reduce the need to include the header files that
previously defined these type names at the tops of other header files,
and thus reduce the risk of circular dependencies.
Move up the definition of MR_Box for use by some of these typedefs.
runtime/mercury_stack_layout.h:
Delete the definition of MR_Proc_Id, which is now in mercury_proc_id.h.
Delete typedefs which are now in mercury_types.h.
Add a macro to compute the max MR_mrN register used at a label, to
reduce code duplication in the trace directory.
runtime/mercury_type_info.h:
Delete the macros for manipulating univs, which are now in
mercury_univ.h.
Delete typedefs which are now in mercury_types.h.
runtime/mercury_deep_profiling.h:
#include mercury_proc_id.h instead of mercury_stack_layout.h.
runtime/Mmakefile:
Mention the new files.
runtime/mercury_imp.h:
runtime/mercury.h:
runtime/mercury_construct.c:
Include the new files at appropriate points.
runtime/mercury.c:
Change the names of the functions that create heap cells for
hand-written code, since the interface to hand-written code has
changed to include type information.
runtime/mercury_tabling.h:
Delete some unused macros.
runtime/mercury_trace_base.[ch]:
Provide a mechanism to print a message from the debugger when the
program aborts, for use by the integrity checking mechanism in mdb
(see below).
runtime/mercury_trace_base.c:
runtime/mercury_type_info.c:
Use the new macros supplying type information when constructing lists.
scripts/c2init.in:
Document why this file includes canonical_grade_options.sh-subr
without including the other files (init_grade_options.sh-subr,
parse_grade_options.sh-subr and final_grade_options.sh-subr)
that canonical_grade_options.sh-subr depends on.
scripts/canonical_grade_options.sh-subr:
Fix an undefined sh variable bug that could cause error messages
to come out without identifying the program they were from.
scripts/init_grade_options.sh-subr:
scripts/parse_grade_options.sh-subr:
scripts/canonical_grade_options.sh-subr:
scripts/mgnuc.in:
Handle the new grade components and the options controlling them.
trace/mercury_trace_internal.c:
Implement the mdb command "term_size <varspec>", which is like
"print <varspec>", but prints the size of a term instead of its value.
In non-term-size-profiling grades, it prints an error message.
Add an option, -i to the forward movement commands, which causes
the debugger to perform an integrity check of all ancestor stack frames
at every event. This is useful when looking for code generation errors
that cause cells to be built wrong.
doc/user_guide.tex:
Add documentation of the term_size mdb command. Since the command is
for implementors only, and works only in grades that are not yet ready
for public consumption, the documentation is commented out.
trace/mercury_trace.[ch]:
Implement the integrity check.
trace/mercury_trace_vars.[ch]:
Add the functions needed to implement the new mdb command, and factor
out the code common to the "size" and "print" commands.
Decide whether to print the name of a variable before invoking the
supplied print or browse predicate on it based on a flag design for
this purpose, instead of overloading the meaning of the output FILE *
variable. This arrangement is much clearer.
Implement the integrity check.
trace/mercury_trace_browse.c:
trace/mercury_trace_external.c:
trace/mercury_trace_help.c:
Supply type information when constructing terms.
Conform to the changes in mercury_trace.c.
tests/debugger/Mmakefile:
Disable the tests sensitive to stack frame sizes in term size profiling
grades.
tests/debugger/completion.exp:
Add the new "term_size" mdb command to the list of command completions.
cvs diff: Diffing .
cvs diff: Diffing analysis
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/doc
cvs diff: Diffing boehm_gc/include
cvs diff: Diffing boehm_gc/include/private
cvs diff: Diffing boehm_gc/tests
cvs diff: Diffing browser
Index: browser/declarative_tree.m
===================================================================
RCS file: /home/mercury1/repository/mercury/browser/declarative_tree.m,v
retrieving revision 1.1
diff -u -b -r1.1 declarative_tree.m
--- browser/declarative_tree.m 13 Sep 2002 04:17:40 -0000 1.1
+++ browser/declarative_tree.m 22 May 2003 12:11:35 -0000
@@ -895,9 +895,22 @@
)
;
AtomicGoal = unify_assign_rep(ToVar, FromVar),
+ % We handle assigns the same as we handle unsafe casts.
( list__member(Var0, BoundVars) ->
decl_require(unify(Var0, ToVar),
"traverse_primitives", "bad assign"),
+ traverse_primitives(Prims, FromVar, TermPath0,
+ Store, ProcRep, Origin)
+ ;
+ traverse_primitives(Prims, Var0, TermPath0,
+ Store, ProcRep, Origin)
+ )
+ ;
+ AtomicGoal = unsafe_cast_rep(ToVar, FromVar),
+ % We handle unsafe casts the same as we handle assigns.
+ ( list__member(Var0, BoundVars) ->
+ decl_require(unify(Var0, ToVar),
+ "traverse_primitives", "bad unsafe_cast"),
traverse_primitives(Prims, FromVar, TermPath0,
Store, ProcRep, Origin)
;
Index: browser/program_representation.m
===================================================================
RCS file: /home/mercury1/repository/mercury/browser/program_representation.m,v
retrieving revision 1.8
diff -u -b -r1.8 program_representation.m
--- browser/program_representation.m 23 Apr 2002 08:52:34 -0000 1.8
+++ browser/program_representation.m 22 May 2003 12:12:12 -0000
@@ -100,6 +100,10 @@
var_rep, % target
var_rep % source
)
+ ; unsafe_cast_rep(
+ var_rep, % target
+ var_rep % source
+ )
; unify_simple_test_rep(
var_rep,
var_rep
@@ -216,6 +220,7 @@
atomic_goal_generates_event(unify_deconstruct_rep(_, _, _)) = no.
atomic_goal_generates_event(unify_assign_rep(_, _)) = no.
atomic_goal_generates_event(unify_simple_test_rep(_, _)) = no.
+atomic_goal_generates_event(unsafe_cast_rep(_, _)) = no.
atomic_goal_generates_event(pragma_foreign_code_rep(_)) = no.
atomic_goal_generates_event(higher_order_call_rep(_, Args)) = yes(Args).
atomic_goal_generates_event(method_call_rep(_, _, Args)) = yes(Args).
cvs diff: Diffing bytecode
cvs diff: Diffing compiler
Index: compiler/accumulator.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/accumulator.m,v
retrieving revision 1.22
diff -u -b -r1.22 accumulator.m
--- compiler/accumulator.m 15 Mar 2003 03:08:42 -0000 1.22
+++ compiler/accumulator.m 17 Mar 2003 07:36:46 -0000
@@ -896,7 +896,7 @@
FullyStrict, VarTypes, ModuleInfo) :-
goal_store__lookup(GoalStore, N - I, LaterGoal - LaterInstMap),
LaterGoal = unify(_, _, _, Unify, _) - _GoalInfo,
- Unify = construct(_, _, _, _, _, _, _),
+ Unify = construct(_, _, _, _, _, _, _, _),
(
member_lessthan_goalid(GoalStore, N - I, _N - J,
EarlierGoal - EarlierInstMap),
@@ -928,7 +928,7 @@
_, _, _), FullyStrict, VarTypes, ModuleInfo) :-
goal_store__lookup(GoalStore, N - I, LaterGoal - LaterInstMap),
LaterGoal = unify(_, _, _, Unify, _) - _GoalInfo,
- Unify = construct(_, ConsId, _, _, _, _, _),
+ Unify = construct(_, ConsId, _, _, _, _, _, _),
goal_store__all_ancestors(GoalStore, N - I, VarTypes, ModuleInfo,
FullyStrict, Ancestors),
Index: compiler/add_heap_ops.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/add_heap_ops.m,v
retrieving revision 1.8
diff -u -b -r1.8 add_heap_ops.m
--- compiler/add_heap_ops.m 15 Mar 2003 07:11:55 -0000 1.8
+++ compiler/add_heap_ops.m 25 Mar 2003 20:18:16 -0000
@@ -351,8 +351,8 @@
generate_call(PredName, Args, Detism, MaybeFeature, InstMap, Module, Context,
CallGoal) :-
mercury_private_builtin_module(BuiltinModule),
- goal_util__generate_simple_call(BuiltinModule, PredName, Args,
- only_mode, Detism, MaybeFeature, InstMap, Module,
+ goal_util__generate_simple_call(BuiltinModule, PredName, predicate,
+ Args, only_mode, Detism, MaybeFeature, InstMap, Module,
Context, CallGoal).
%-----------------------------------------------------------------------------%
Index: compiler/add_trail_ops.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/add_trail_ops.m,v
retrieving revision 1.10
diff -u -b -r1.10 add_trail_ops.m
--- compiler/add_trail_ops.m 15 Mar 2003 03:08:42 -0000 1.10
+++ compiler/add_trail_ops.m 25 Mar 2003 20:18:31 -0000
@@ -145,7 +145,7 @@
% So we use a call to `private_builtin__unused' (which
% will call error/1) rather than `fail' for the "then" part.
mercury_private_builtin_module(PrivateBuiltin),
- generate_simple_call(PrivateBuiltin, "unused",
+ generate_simple_call(PrivateBuiltin, "unused", predicate,
[], only_mode, det,
no, [], ModuleInfo, Context, ThenGoal)
;
@@ -475,8 +475,8 @@
generate_call(PredName, Args, Detism, MaybeFeature, InstMap, Module, Context,
CallGoal) :-
mercury_private_builtin_module(BuiltinModule),
- goal_util__generate_simple_call(BuiltinModule, PredName, Args,
- only_mode, Detism, MaybeFeature, InstMap, Module,
+ goal_util__generate_simple_call(BuiltinModule, PredName, predicate,
+ Args, only_mode, Detism, MaybeFeature, InstMap, Module,
Context, CallGoal).
%-----------------------------------------------------------------------------%
Index: compiler/aditi_builtin_ops.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/aditi_builtin_ops.m,v
retrieving revision 1.1
diff -u -b -r1.1 aditi_builtin_ops.m
--- compiler/aditi_builtin_ops.m 18 Mar 2003 02:43:35 -0000 1.1
+++ compiler/aditi_builtin_ops.m 25 Mar 2003 20:11:30 -0000
@@ -100,7 +100,7 @@
transform_aditi_builtins_in_goal_expr(Goal0, GoalInfo, Goal) -->
{ Goal0 = unify(_, _, _, Unification, _) },
(
- { Unification = construct(Var, ConsId, Args, _, _, _, _) },
+ { Unification = construct(Var, ConsId, Args, _, _, _, _, _) },
{ ConsId = pred_const(PredId, ProcId, aditi_bottom_up) }
->
^ changed := yes,
@@ -197,8 +197,8 @@
ModuleInfo0 =^ module_info,
{ lookup_builtin_pred_proc_id(ModuleInfo0,
- aditi_private_builtin_module, "do_call_returning_relation", 4,
- only_mode, BuiltinPredId, BuiltinProcId) },
+ aditi_private_builtin_module, "do_call_returning_relation",
+ predicate, 4, only_mode, BuiltinPredId, BuiltinProcId) },
%
% Build the input arguments describing the procedure to call.
@@ -231,7 +231,7 @@
{ ExprnId = no },
{ Unification = construct(NewVar, BuiltinConsId, BuiltinArgs,
UniModes, construct_dynamically,
- cell_is_unique, ExprnId) },
+ cell_is_unique, ExprnId, no) },
{ set__list_to_set([NewVar | BuiltinArgs], NonLocals) },
{ instmap_delta_from_assoc_list([NewVar - ground_inst],
InstMapDelta) },
@@ -304,7 +304,7 @@
{ aditi_builtin_info(ModuleInfo, Builtin,
BuiltinProcName, BuiltinProcArity, ConstArgs) },
{ lookup_builtin_pred_proc_id(ModuleInfo, aditi_private_builtin_module,
- BuiltinProcName, BuiltinProcArity, only_mode,
+ BuiltinProcName, predicate, BuiltinProcArity, only_mode,
PredId, ProcId) },
generate_const_args(ConstArgs, ConstArgVars, ConstArgGoals),
transform_aditi_builtin_2(Builtin, Args, Modes, Det,
@@ -478,7 +478,7 @@
; Det = erroneous, Proc = "do_erroneous_call"
},
{ lookup_builtin_pred_proc_id(ModuleInfo0,
- aditi_private_builtin_module, Proc, 4, only_mode,
+ aditi_private_builtin_module, Proc, predicate, 4, only_mode,
BuiltinPredId, BuiltinProcId) },
{ BuiltinSymName = qualified(aditi_private_builtin_module, Proc) },
Index: compiler/builtin_ops.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/builtin_ops.m,v
retrieving revision 1.12
diff -u -b -r1.12 builtin_ops.m
--- compiler/builtin_ops.m 15 Mar 2003 03:08:42 -0000 1.12
+++ compiler/builtin_ops.m 27 Mar 2003 15:35:37 -0000
@@ -177,6 +177,9 @@
builtin_translation("private_builtin", "builtin_int_lt", 0, [X, Y],
test(binary((<), leaf(X), leaf(Y)))).
+builtin_translation("term_size_prof_builtin", "term_size_plus", 0, [X, Y, Z],
+ assign(Z, binary((+), leaf(X), leaf(Y)))).
+
builtin_translation("int", "+", 0, [X, Y, Z],
assign(Z, binary((+), leaf(X), leaf(Y)))).
builtin_translation("int", "+", 1, [X, Y, Z],
Index: compiler/bytecode_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/bytecode_gen.m,v
retrieving revision 1.73
diff -u -b -r1.73 bytecode_gen.m
--- compiler/bytecode_gen.m 26 May 2003 08:59:49 -0000 1.73
+++ compiler/bytecode_gen.m 26 May 2003 09:11:49 -0000
@@ -472,7 +472,7 @@
:- pred bytecode_gen__unify(unification::in, prog_var::in, unify_rhs::in,
byte_info::in, byte_tree::out) is det.
-bytecode_gen__unify(construct(Var, ConsId, Args, UniModes, _, _, _),
+bytecode_gen__unify(construct(Var, ConsId, Args, UniModes, _, _, _, _),
_, _, ByteInfo, Code) :-
bytecode_gen__map_var(ByteInfo, Var, ByteVar),
bytecode_gen__map_vars(ByteInfo, Args, ByteArgs),
@@ -536,36 +536,50 @@
ByteInfo = byte_info(_, _, ModuleInfo, _, _),
- classify_type_ctor(ModuleInfo, TypeCtor, BuiltinType),
+ TypeCategory = classify_type_ctor(ModuleInfo, TypeCtor),
(
- BuiltinType = int_type,
+ TypeCategory = int_type,
TestId = int_test
-
- ; BuiltinType = char_type,
+ ;
+ TypeCategory = char_type,
TestId = char_test
-
- ; BuiltinType = str_type,
+ ;
+ TypeCategory = str_type,
TestId = string_test
-
- ; BuiltinType = float_type,
+ ;
+ TypeCategory = float_type,
TestId = float_test
-
- ; BuiltinType = enum_type,
+ ;
+ TypeCategory = enum_type,
TestId = enum_test
-
- ; BuiltinType = pred_type,
- unexpected(this_file, "pred_type in simple_test")
-
- ; BuiltinType = tuple_type,
+ ;
+ TypeCategory = higher_order_type,
+ unexpected(this_file, "higher_order_type in simple_test")
+ ;
+ TypeCategory = tuple_type,
unexpected(this_file, "tuple_type in simple_test")
-
- ; BuiltinType = user_type,
- unexpected(this_file, "user_type in simple_test")
-
- ; BuiltinType = polymorphic_type,
- unexpected(this_file, "polymorphic_type in simple_test")
-
+ ;
+ TypeCategory = user_ctor_type,
+ unexpected(this_file, "user_ctor_type in simple_test")
+ ;
+ TypeCategory = variable_type,
+ unexpected(this_file, "variable_type in simple_test")
+ ;
+ TypeCategory = void_type,
+ unexpected(this_file, "void_type in simple_test")
+ ;
+ TypeCategory = type_info_type,
+ unexpected(this_file, "type_info_type in simple_test")
+ ;
+ TypeCategory = type_ctor_info_type,
+ unexpected(this_file, "type_ctor_info_type in simple_test")
+ ;
+ TypeCategory = typeclass_info_type,
+ unexpected(this_file, "typeclass_info_type in simple_test")
+ ;
+ TypeCategory = base_typeclass_info_type,
+ unexpected(this_file, "base_typeclass_info_type in simple_test")
),
Code = node([test(ByteVar1, ByteVar2, TestId)]).
bytecode_gen__unify(complicated_unify(_,_,_), _Var, _RHS, _ByteInfo, _Code) :-
Index: compiler/code_info.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/code_info.m,v
retrieving revision 1.278
diff -u -b -r1.278 code_info.m
--- compiler/code_info.m 26 May 2003 08:59:51 -0000 1.278
+++ compiler/code_info.m 26 May 2003 09:11:50 -0000
@@ -3070,8 +3070,8 @@
code_info::in, code_info::out) is det.
:- pred code_info__assign_cell_to_var(prog_var::in, tag::in,
- list(maybe(rval))::in, string::in, code_tree::out,
- code_info::in, code_info::out) is det.
+ list(maybe(rval))::in, maybe(term_size_value)::in, string::in,
+ code_tree::out, code_info::in, code_info::out) is det.
:- pred code_info__place_var(prog_var::in, lval::in, code_tree::out,
code_info::in, code_info::out) is det.
@@ -3207,13 +3207,13 @@
},
code_info__set_var_locn_info(VarLocnInfo).
-code_info__assign_cell_to_var(Var, Ptag, Vector, TypeMsg, Code) -->
+code_info__assign_cell_to_var(Var, Ptag, Vector, Size, TypeMsg, Code) -->
code_info__get_var_locn_info(VarLocnInfo0),
code_info__get_static_cell_info(StaticCellInfo0),
- { var_locn__assign_cell_to_var(Var, Ptag, Vector, TypeMsg, Code,
+ { var_locn__assign_cell_to_var(Var, Ptag, Vector, Size, TypeMsg, Code,
StaticCellInfo0, StaticCellInfo, VarLocnInfo0, VarLocnInfo) },
- code_info__set_var_locn_info(VarLocnInfo),
- code_info__set_static_cell_info(StaticCellInfo).
+ code_info__set_static_cell_info(StaticCellInfo),
+ code_info__set_var_locn_info(VarLocnInfo).
code_info__place_var(Var, Lval, Code) -->
code_info__get_var_locn_info(VarLocnInfo0),
Index: compiler/common.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/common.m,v
retrieving revision 1.70
diff -u -b -r1.70 common.m
--- compiler/common.m 13 May 2003 07:52:14 -0000 1.70
+++ compiler/common.m 15 May 2003 02:31:33 -0000
@@ -141,7 +141,7 @@
common__optimise_unification(Unification0, _Left0, _Right0, Mode, _Context,
Goal0, GoalInfo0, Goal, GoalInfo, Info0, Info) :-
(
- Unification0 = construct(Var, ConsId, ArgVars, _, _, _, _),
+ Unification0 = construct(Var, ConsId, ArgVars, _, _, _, _, _),
Mode = LVarMode - _,
simplify_info_get_module_info(Info0, ModuleInfo),
mode_get_insts(ModuleInfo, LVarMode, _, Inst),
Index: compiler/compile_target_code.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/compile_target_code.m,v
retrieving revision 1.44
diff -u -b -r1.44 compile_target_code.m
--- compiler/compile_target_code.m 26 May 2003 08:59:52 -0000 1.44
+++ compiler/compile_target_code.m 26 May 2003 09:11:50 -0000
@@ -492,7 +492,28 @@
;
ProfileDeepOpt = ""
},
-
+ globals__io_lookup_bool_option(record_term_sizes_as_words,
+ RecordTermSizesAsWords),
+ globals__io_lookup_bool_option(record_term_sizes_as_cells,
+ RecordTermSizesAsCells),
+ {
+ RecordTermSizesAsWords = yes,
+ RecordTermSizesAsCells = yes,
+ % this should have been caught in handle_options
+ error("compile_c_file: inconsistent record term size options")
+ ;
+ RecordTermSizesAsWords = yes,
+ RecordTermSizesAsCells = no,
+ RecordTermSizesOpt = "-DMR_RECORD_TERM_SIZES "
+ ;
+ RecordTermSizesAsWords = no,
+ RecordTermSizesAsCells = yes,
+ RecordTermSizesOpt = "-DMR_RECORD_TERM_SIZES -DMR_RECORD_TERM_SIZES_AS_CELLS "
+ ;
+ RecordTermSizesAsWords = no,
+ RecordTermSizesAsCells = no,
+ RecordTermSizesOpt = ""
+ },
(
{ PIC = pic },
globals__io_lookup_string_option(cflags_for_pic,
@@ -620,8 +641,8 @@
CFLAGS_FOR_REGS, " ", CFLAGS_FOR_GOTOS, " ",
CFLAGS_FOR_THREADS, " ", CFLAGS_FOR_PIC, " ",
GC_Opt, ProfileCallsOpt, ProfileTimeOpt, ProfileMemoryOpt,
- ProfileDeepOpt, PIC_Reg_Opt, TagsOpt, NumTagBitsOpt,
- Target_DebugOpt, LL_DebugOpt,
+ ProfileDeepOpt, RecordTermSizesOpt, PIC_Reg_Opt, TagsOpt,
+ NumTagBitsOpt, Target_DebugOpt, LL_DebugOpt,
DeclDebugOpt, RequireTracingOpt, StackTraceOpt,
UseTrailOpt, ReserveTagOpt, MinimalModelOpt, TypeLayoutOpt,
InlineAllocOpt, " ", AnsiOpt, " ", WarningOpt, " ", CFLAGS,
Index: compiler/constraint.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/constraint.m,v
retrieving revision 1.51
diff -u -b -r1.51 constraint.m
--- compiler/constraint.m 15 Mar 2003 03:08:43 -0000 1.51
+++ compiler/constraint.m 17 Mar 2003 07:37:10 -0000
@@ -439,7 +439,7 @@
% doesn't need to be kept on the stack.
%
{ Goal = unify(_, _, _, Unify, _) - _ },
- { Unify = construct(ConstructVar, _, [], _, _, _, _) }
+ { Unify = construct(ConstructVar, _, [], _, _, _, _, _) }
->
{ Goals1 = [Goal - [] | Goals0] },
constraint__add_constant_construction(ConstructVar, Goal,
Index: compiler/dead_proc_elim.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/dead_proc_elim.m,v
retrieving revision 1.80
diff -u -b -r1.80 dead_proc_elim.m
--- compiler/dead_proc_elim.m 26 May 2003 08:59:52 -0000 1.80
+++ compiler/dead_proc_elim.m 26 May 2003 09:11:50 -0000
@@ -493,7 +493,7 @@
dead_proc_elim__examine_expr(unify(_,_,_, Uni, _), _CurrProc, Queue0, Queue,
Needed0, Needed) :-
(
- Uni = construct(_, ConsId, _, _, _, _, _),
+ Uni = construct(_, ConsId, _, _, _, _, _, _),
(
ConsId = pred_const(PredId, ProcId, _),
Entity = proc(PredId, ProcId)
Index: compiler/deep_profiling.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/deep_profiling.m,v
retrieving revision 1.18
diff -u -b -r1.18 deep_profiling.m
--- compiler/deep_profiling.m 18 Mar 2003 02:43:35 -0000 1.18
+++ compiler/deep_profiling.m 25 Mar 2003 20:17:56 -0000
@@ -1471,22 +1471,22 @@
( Expr = call(PredId, ProcId, Args, _, _, _) ->
(
lookup_builtin_pred_proc_id(ModuleInfo,
- mercury_public_builtin_module, "unify", 2,
- mode_no(0), PredId, _),
+ mercury_public_builtin_module, "unify",
+ predicate, 2, mode_no(0), PredId, _),
Args = [TypeInfoVar | _]
->
Class = special(proc(PredId, ProcId), TypeInfoVar)
;
lookup_builtin_pred_proc_id(ModuleInfo,
- mercury_public_builtin_module, "compare", 3,
- mode_no(0), PredId, _),
+ mercury_public_builtin_module, "compare",
+ predicate, 3, mode_no(0), PredId, _),
Args = [TypeInfoVar | _]
->
Class = special(proc(PredId, ProcId), TypeInfoVar)
;
lookup_builtin_pred_proc_id(ModuleInfo,
mercury_public_builtin_module,
- "compare_representation", 3,
+ "compare_representation", predicate, 3,
mode_no(0), PredId, _),
Args = [TypeInfoVar | _]
->
@@ -1680,7 +1680,7 @@
Goal = unify(Var, functor(ConsId, no, []),
(free -> Ground) - (Ground -> Ground),
construct(Var, ConsId, [], [], construct_statically([]),
- cell_is_shared, no),
+ cell_is_shared, no, no),
unify_context(explicit, [])) - GoalInfo.
:- pred generate_cell_unify(int::in, cons_id::in, list(prog_var)::in,
@@ -1697,7 +1697,7 @@
Goal = unify(Var, functor(ConsId, no, Args),
(free -> Ground) - (Ground -> Ground),
construct(Var, ConsId, Args, ArgModes,
- construct_statically([]), cell_is_shared, no),
+ construct_statically([]), cell_is_shared, no, no),
unify_context(explicit, [])) - GoalInfo.
%-----------------------------------------------------------------------------%
Index: compiler/delay_construct.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/delay_construct.m,v
retrieving revision 1.4
diff -u -b -r1.4 delay_construct.m
--- compiler/delay_construct.m 15 Mar 2003 03:08:44 -0000 1.4
+++ compiler/delay_construct.m 17 Mar 2003 07:39:26 -0000
@@ -208,7 +208,7 @@
instmap__apply_instmap_delta(InstMap0, InstMapDelta0, InstMap1),
(
GoalExpr0 = unify(_, _, _, Unif, _),
- Unif = construct(Var, _, Args, _, _, _, _),
+ Unif = construct(Var, _, Args, _, _, _, _, _),
Args = [_ | _], % We are constructing a cell, not a constant
instmap__lookup_var(InstMap0, Var, Inst0),
inst_is_free(DelayInfo ^ module_info, Inst0),
Index: compiler/dense_switch.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/dense_switch.m,v
retrieving revision 1.45
diff -u -b -r1.45 dense_switch.m
--- compiler/dense_switch.m 26 May 2003 08:59:52 -0000 1.45
+++ compiler/dense_switch.m 26 May 2003 09:11:51 -0000
@@ -49,7 +49,8 @@
:- mode dense_switch__calc_density(in, in, out) is det.
% also used by lookup_switch
-:- pred dense_switch__type_range(builtin_type, type, int, code_info, code_info).
+:- pred dense_switch__type_range(type_category, type, int,
+ code_info, code_info).
:- mode dense_switch__type_range(in, in, out, in, out) is semidet.
%-----------------------------------------------------------------------------%
@@ -87,7 +88,7 @@
% of the values for the type.
code_info__variable_type(CaseVar, Type),
code_info__get_module_info(ModuleInfo),
- { classify_type(Type, ModuleInfo, TypeCategory) },
+ { classify_type(ModuleInfo, Type) = TypeCategory },
(
dense_switch__type_range(TypeCategory, Type, TypeRange),
{ dense_switch__calc_density(NumCases, TypeRange,
Index: compiler/dependency_graph.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/dependency_graph.m,v
retrieving revision 1.60
diff -u -b -r1.60 dependency_graph.m
--- compiler/dependency_graph.m 26 May 2003 08:59:53 -0000 1.60
+++ compiler/dependency_graph.m 26 May 2003 09:11:51 -0000
@@ -340,7 +340,7 @@
DepGraph0 = DepGraph
; Unify = simple_test(_, _),
DepGraph0 = DepGraph
- ; Unify = construct(_, Cons, _, _, _, _, _),
+ ; Unify = construct(_, Cons, _, _, _, _, _, _),
dependency_graph__add_arcs_in_cons(Cons, Caller,
DepGraph0, DepGraph)
; Unify = deconstruct(_, Cons, _, _, _, _),
@@ -733,7 +733,7 @@
Map0, Map) -->
(
{ Unify = construct(_, pred_const(PredId, ProcId, _),
- _, _, _, _, _) }
+ _, _, _, _, _, _) }
->
aditi_scc_info_add_closure(Var,
proc(PredId, ProcId), Map0, Map)
Index: compiler/det_analysis.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/det_analysis.m,v
retrieving revision 1.160
diff -u -b -r1.160 det_analysis.m
--- compiler/det_analysis.m 15 Mar 2003 03:08:44 -0000 1.160
+++ compiler/det_analysis.m 17 Mar 2003 07:39:58 -0000
@@ -1007,7 +1007,7 @@
% the concrete representation of the abstract values involved.
:- pred det_infer_unify_examines_rep(unification::in, bool::out) is det.
det_infer_unify_examines_rep(assign(_, _), no).
-det_infer_unify_examines_rep(construct(_, _, _, _, _, _, _), no).
+det_infer_unify_examines_rep(construct(_, _, _, _, _, _, _, _), no).
det_infer_unify_examines_rep(deconstruct(_, _, _, _, _, _), yes).
det_infer_unify_examines_rep(simple_test(_, _), yes).
det_infer_unify_examines_rep(complicated_unify(_, _, _), no).
@@ -1032,7 +1032,7 @@
det_infer_unify_canfail(deconstruct(_, _, _, _, CanFail, _), CanFail).
det_infer_unify_canfail(assign(_, _), cannot_fail).
-det_infer_unify_canfail(construct(_, _, _, _, _, _, _), cannot_fail).
+det_infer_unify_canfail(construct(_, _, _, _, _, _, _, _), cannot_fail).
det_infer_unify_canfail(simple_test(_, _), can_fail).
det_infer_unify_canfail(complicated_unify(_, CanFail, _), CanFail).
Index: compiler/dnf.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/dnf.m,v
retrieving revision 1.49
diff -u -b -r1.49 dnf.m
--- compiler/dnf.m 26 May 2003 08:59:53 -0000 1.49
+++ compiler/dnf.m 26 May 2003 09:11:52 -0000
@@ -515,7 +515,7 @@
dnf__free_of_nonatomic(unify(_, _, _, Uni, _) - _, NonAtomic) :-
\+ (
Uni = construct(_, pred_const(PredId, ProcId, _),
- _, _, _, _, _),
+ _, _, _, _, _, _),
set__member(proc(PredId, ProcId), NonAtomic)
).
dnf__free_of_nonatomic(disj(Goals) - GoalInfo, NonAtomic) :-
Index: compiler/dupelim.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/dupelim.m,v
retrieving revision 1.56
diff -u -b -r1.56 dupelim.m
--- compiler/dupelim.m 9 May 2003 05:51:50 -0000 1.56
+++ compiler/dupelim.m 9 May 2003 06:03:45 -0000
@@ -342,10 +342,10 @@
standardize_rval(Rval1, Rval),
Instr = if_val(Rval, CodeAddr)
;
- Instr1 = incr_hp(Lval1, MaybeTag, Rval1, Msg),
+ Instr1 = incr_hp(Lval1, MaybeTag, MaybeOffset, Rval1, Msg),
standardize_lval(Lval1, Lval),
standardize_rval(Rval1, Rval),
- Instr = incr_hp(Lval, MaybeTag, Rval, Msg)
+ Instr = incr_hp(Lval, MaybeTag, MaybeOffset, Rval, Msg)
;
Instr1 = mark_hp(Lval1),
standardize_lval(Lval1, Lval),
@@ -649,11 +649,11 @@
most_specific_rval(Rval1, Rval2, Rval),
Instr = if_val(Rval, CodeAddr)
;
- Instr1 = incr_hp(Lval1, MaybeTag, Rval1, Msg),
- Instr2 = incr_hp(Lval2, MaybeTag, Rval2, Msg),
+ Instr1 = incr_hp(Lval1, MaybeTag, MaybeOffset, Rval1, Msg),
+ Instr2 = incr_hp(Lval2, MaybeTag, MaybeOffset, Rval2, Msg),
most_specific_lval(Lval1, Lval2, Lval),
most_specific_rval(Rval1, Rval2, Rval),
- Instr = incr_hp(Lval, MaybeTag, Rval, Msg)
+ Instr = incr_hp(Lval, MaybeTag, MaybeOffset, Rval, Msg)
;
Instr1 = mark_hp(Lval1),
Instr2 = mark_hp(Lval2),
Index: compiler/exprn_aux.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/exprn_aux.m,v
retrieving revision 1.49
diff -u -b -r1.49 exprn_aux.m
--- compiler/exprn_aux.m 26 May 2003 08:59:54 -0000 1.49
+++ compiler/exprn_aux.m 26 May 2003 09:11:53 -0000
@@ -142,7 +142,7 @@
exprn_aux__const_is_constant(multi_string_const(_, _), _, yes).
exprn_aux__const_is_constant(code_addr_const(CodeAddr), ExprnOpts, IsConst) :-
exprn_aux__addr_is_constant(CodeAddr, ExprnOpts, IsConst).
-exprn_aux__const_is_constant(data_addr_const(_), _, yes).
+exprn_aux__const_is_constant(data_addr_const(_, _), _, yes).
exprn_aux__const_is_constant(label_entry(Label), ExprnOpts, IsConst) :-
exprn_aux__addr_is_constant(label(Label), ExprnOpts, IsConst).
@@ -387,12 +387,12 @@
Rval0, Rval, N0, N),
Uinstr = if_val(Rval, CodeAddr)
;
- Uinstr0 = incr_hp(Lval0, MaybeTag, Rval0, TypeCtor),
+ Uinstr0 = incr_hp(Lval0, MaybeTag, MO, Rval0, TypeCtor),
exprn_aux__substitute_lval_in_lval_count(OldLval, NewLval,
Lval0, Lval, N0, N1),
exprn_aux__substitute_lval_in_rval_count(OldLval, NewLval,
Rval0, Rval, N1, N),
- Uinstr = incr_hp(Lval, MaybeTag, Rval, TypeCtor)
+ Uinstr = incr_hp(Lval, MaybeTag, MO, Rval, TypeCtor)
;
Uinstr0 = mark_hp(Lval0),
exprn_aux__substitute_lval_in_lval_count(OldLval, NewLval,
@@ -996,7 +996,7 @@
( Const = code_addr_const(CodeAddress) ->
CodeAddrs = [CodeAddress],
DataAddrs = []
- ; Const = data_addr_const(DataAddress) ->
+ ; Const = data_addr_const(DataAddress, _) ->
CodeAddrs = [],
DataAddrs = [DataAddress]
;
Index: compiler/goal_form.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/goal_form.m,v
retrieving revision 1.5
diff -u -b -r1.5 goal_form.m
--- compiler/goal_form.m 15 Mar 2003 07:11:56 -0000 1.5
+++ compiler/goal_form.m 17 Mar 2003 07:40:25 -0000
@@ -164,7 +164,7 @@
;
Uni = simple_test(_, _)
;
- Uni = construct(_, _, _, _, _, _, _)
+ Uni = construct(_, _, _, _, _, _, _, _)
;
Uni = deconstruct(_, _, _, _, _, _)
).
@@ -197,7 +197,7 @@
;
Uni = simple_test(_, _)
;
- Uni = construct(_, _, _, _, _, _, _)
+ Uni = construct(_, _, _, _, _, _, _, _)
;
Uni = deconstruct(_, _, _, _, _, _)
).
@@ -266,7 +266,7 @@
May = yes
).
goal_may_allocate_heap_2(unify(_, _, _, Unification, _), May) :-
- ( Unification = construct(_,_,Args,_,_,_,_), Args = [_|_] ->
+ ( Unification = construct(_,_,Args,_,_,_,_,_), Args = [_|_] ->
May = yes
;
May = no
Index: compiler/goal_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/goal_util.m,v
retrieving revision 1.85
diff -u -b -r1.85 goal_util.m
--- compiler/goal_util.m 26 May 2003 08:59:54 -0000 1.85
+++ compiler/goal_util.m 26 May 2003 09:11:54 -0000
@@ -220,7 +220,7 @@
:- pred goal_util__reordering_maintains_termination(module_info::in, bool::in,
hlds_goal::in, hlds_goal::in) is semidet.
- % generate_simple_call(ModuleName, PredName, Args, ModeNo,
+ % generate_simple_call(ModuleName, ProcName, PredOrFunc, Args, ModeNo,
% Detism, MaybeFeature, InstMapDelta,
% ModuleInfo, Context, CallGoal):
% Generate a call to a builtin procedure (e.g.
@@ -235,10 +235,13 @@
% from 0.
%
:- pred goal_util__generate_simple_call(module_name::in, string::in,
- list(prog_var)::in, mode_no::in, determinism::in,
+ pred_or_func::in, list(prog_var)::in, mode_no::in, determinism::in,
maybe(goal_feature)::in, assoc_list(prog_var, inst)::in,
module_info::in, term__context::in, hlds_goal::out) is det.
+:- pred goal_util__generate_unsafe_cast(prog_var::in, prog_var::in,
+ prog_context::in, hlds_goal::out) is det.
+
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -471,9 +474,9 @@
:- mode goal_util__rename_unify(in, in, in, out) is det.
goal_util__rename_unify(
- construct(Var0, ConsId, Vars0, Modes, How0, Uniq, Aditi),
+ construct(Var0, ConsId, Vars0, Modes, How0, Uniq, Aditi, Size),
Must, Subn,
- construct(Var, ConsId, Vars, Modes, How, Uniq, Aditi)) :-
+ construct(Var, ConsId, Vars, Modes, How, Uniq, Aditi, Size)) :-
goal_util__rename_var(Var0, Must, Subn, Var),
goal_util__rename_var_list(Vars0, Must, Subn, Vars),
(
@@ -592,7 +595,7 @@
goal_util__goal_vars_2(unify(Var, RHS, _, Unif, _), Set0, Set) :-
set__insert(Set0, Var, Set1),
- ( Unif = construct(_, _, _, _, CellToReuse, _, _) ->
+ ( Unif = construct(_, _, _, _, CellToReuse, _, _, _) ->
( CellToReuse = reuse_cell(cell_to_reuse(Var, _, _)) ->
set__insert(Set1, Var, Set2)
;
@@ -603,8 +606,7 @@
),
goal_util__rhs_goal_vars(RHS, Set2, Set).
-goal_util__goal_vars_2(generic_call(GenericCall, ArgVars, _, _),
- Set0, Set) :-
+goal_util__goal_vars_2(generic_call(GenericCall, ArgVars, _, _), Set0, Set) :-
goal_util__generic_call_vars(GenericCall, Vars0),
set__insert_list(Set0, Vars0, Set1),
set__insert_list(Set1, ArgVars, Set).
@@ -953,7 +955,7 @@
goal_expr_contains_reconstruction(some(_, _, Goal)) :-
goal_contains_reconstruction(Goal).
goal_expr_contains_reconstruction(unify(_, _, _, Unify, _)) :-
- Unify = construct(_, _, _, _, HowToConstruct, _, _),
+ Unify = construct(_, _, _, _, HowToConstruct, _, _, _),
HowToConstruct = reuse_cell(_).
:- pred goals_contain_reconstruction(list(hlds_goal)).
@@ -1228,10 +1230,10 @@
%-----------------------------------------------------------------------------%
-goal_util__generate_simple_call(ModuleName, PredName, Args, ModeNo, Detism,
- MaybeFeature, InstMap, Module, Context, CallGoal) :-
+goal_util__generate_simple_call(ModuleName, ProcName, PredOrFunc, Args, ModeNo,
+ Detism, MaybeFeature, InstMap, Module, Context, CallGoal) :-
list__length(Args, Arity),
- lookup_builtin_pred_proc_id(Module, ModuleName, PredName,
+ lookup_builtin_pred_proc_id(Module, ModuleName, ProcName, PredOrFunc,
Arity, ModeNo, PredId, ProcId),
% builtin_state only uses this to work out whether
@@ -1241,7 +1243,7 @@
builtin_state(Module, InvalidPredId, PredId, ProcId, BuiltinState),
Call = call(PredId, ProcId, Args, BuiltinState, no,
- qualified(ModuleName, PredName)),
+ qualified(ModuleName, ProcName)),
set__init(NonLocals0),
set__insert_list(NonLocals0, Args, NonLocals),
determinism_components(Detism, _CanFail, NumSolns),
@@ -1264,6 +1266,14 @@
CallGoalInfo = CallGoalInfo0
),
CallGoal = Call - CallGoalInfo.
+
+generate_unsafe_cast(InArg, OutArg, Context, Goal) :-
+ set__list_to_set([InArg, OutArg], NonLocals),
+ instmap_delta_from_assoc_list([OutArg - ground(shared, none)],
+ InstMapDelta),
+ goal_info_init(NonLocals, InstMapDelta, det, pure, Context, GoalInfo),
+ Goal = generic_call(unsafe_cast, [InArg, OutArg],
+ [in_mode, out_mode], det) - GoalInfo.
%-----------------------------------------------------------------------------%
Index: compiler/handle_options.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/handle_options.m,v
retrieving revision 1.185
diff -u -b -r1.185 handle_options.m
--- compiler/handle_options.m 14 May 2003 04:05:39 -0000 1.185
+++ compiler/handle_options.m 22 May 2003 17:06:22 -0000
@@ -814,6 +814,33 @@
[]
),
+ globals__io_lookup_bool_option(record_term_sizes_as_words,
+ RecordTermSizesAsWords),
+ globals__io_lookup_bool_option(record_term_sizes_as_cells,
+ RecordTermSizesAsCells),
+ (
+ { RecordTermSizesAsWords = yes },
+ { RecordTermSizesAsCells = yes }
+ ->
+ usage_error("we can't record term size as both words and cells")
+ ;
+ { RecordTermSizesAsWords = yes
+ ; RecordTermSizesAsCells = yes
+ }
+ ->
+ ( { HighLevel = yes } ->
+ usage_error("term size profiling is incompatible with high level code")
+ ;
+ % XXX Term size profiling exposes a bug in
+ % type specialization.
+ globals__io_set_option(type_specialization, bool(no)),
+ globals__io_set_option(user_guided_type_specialization,
+ bool(no))
+ )
+ ;
+ []
+ ),
+
(
{ given_trace_level_is_none(TraceLevel) = yes
; HighLevel = no, Target = c
@@ -1431,6 +1458,7 @@
; par % parallelism / multithreading
; gc % the kind of GC to use
; prof % what profiling options to use
+ ; term_size % whether or not to record term sizes
; trail % whether or not to use trailing
; tag % whether or not to reserve a tag
; minimal_model % whether we set up for minimal model tabling
@@ -1691,6 +1719,14 @@
[profile_time - bool(no), profile_calls - bool(no),
profile_memory - bool(no), profile_deep - bool(yes)], no).
+ % Term size components
+grade_component_table("tsw", term_size,
+ [record_term_sizes_as_words - bool(yes),
+ record_term_sizes_as_cells - bool(no)], no).
+grade_component_table("tsc", term_size,
+ [record_term_sizes_as_words - bool(no),
+ record_term_sizes_as_cells - bool(yes)], no).
+
% Trailing components
grade_component_table("tr", trail, [use_trail - bool(yes)], no).
@@ -1796,6 +1832,7 @@
convert_dump_alias("ALL", "abcdfgilmnprstuvCDIMPTU").
convert_dump_alias("all", "abcdfgilmnprstuvCMPT").
convert_dump_alias("most", "bcdfgilmnprstuvP").
+convert_dump_alias("trans", "bcdglmnstuv").
convert_dump_alias("codegen", "dfnprsu").
convert_dump_alias("vanessa", "ltuCIU").
convert_dump_alias("paths", "cP").
Index: compiler/higher_order.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/higher_order.m,v
retrieving revision 1.107
diff -u -b -r1.107 higher_order.m
--- compiler/higher_order.m 26 May 2003 08:59:55 -0000 1.107
+++ compiler/higher_order.m 26 May 2003 09:11:54 -0000
@@ -504,7 +504,7 @@
{ Goal0 = GoalExpr0 - _ },
{ GoalExpr0 = unify(_, _, _, Unify0, _) },
(
- { Unify0 = construct(_, pred_const(_, _, _), _, _, _, _, _) }
+ { Unify0 = construct(_, pred_const(_, _, _), _,_,_,_,_,_) }
->
maybe_specialize_pred_const(Goal0, Goal)
;
@@ -665,7 +665,7 @@
% deconstructing a higher order term is not allowed
check_unify(deconstruct(_, _, _, _, _, _)) --> [].
-check_unify(construct(LVar, ConsId, Args, _Modes, _, _, _), Info0, Info) :-
+check_unify(construct(LVar, ConsId, Args, _Modes, _, _, _, _), Info0, Info) :-
( is_interesting_cons_id(Info0 ^ global_info ^ ho_params, ConsId) ->
( map__search(Info0 ^ pred_vars, LVar, Specializable) ->
(
@@ -942,7 +942,8 @@
get_typeclass_info_args(ModuleInfo, TypeClassInfoVar, PredName, MakeResultType,
Args, Index, Goals, Vars, ProcInfo0, ProcInfo) :-
lookup_builtin_pred_proc_id(ModuleInfo, mercury_private_builtin_module,
- PredName, 3, only_mode, ExtractArgPredId, ExtractArgProcId),
+ PredName, predicate, 3, only_mode, ExtractArgPredId,
+ ExtractArgProcId),
get_typeclass_info_args_2(TypeClassInfoVar, ExtractArgPredId,
ExtractArgProcId,
qualified(mercury_private_builtin_module, PredName),
@@ -1085,7 +1086,7 @@
(
{ Goal0 = unify(_, _, UniMode, Unify0, Context) },
{ Unify0 = construct(LVar, ConsId0, Args0, _,
- HowToConstruct, CellIsUnique, MaybeExprn) },
+ HowToConstruct, CellIsUnique, MaybeExprn, no) },
{ ConsId0 = pred_const(PredId, ProcId, EvalMethod) },
{ map__contains(NewPreds, proc(PredId, ProcId)) },
{ proc_info_vartypes(ProcInfo0, VarTypes0) },
@@ -1155,7 +1156,7 @@
EvalMethod) },
{ Unify = construct(LVar, NewConsId,
NewArgs, UniModes, HowToConstruct,
- CellIsUnique, MaybeExprn) },
+ CellIsUnique, MaybeExprn, no) },
{ Goal2 = unify(LVar, functor(NewConsId, no, NewArgs),
UniMode, Unify, Context) },
@@ -1554,7 +1555,7 @@
arg_type_contains_type_info_for_tvar(TypeInfoType, TVars0, TVars) :-
(
- polymorphism__type_info_type(TypeInfoType, Type),
+ polymorphism__type_info_or_ctor_type(TypeInfoType, Type),
Type = term__variable(TVar)
->
TVars = [TVar | TVars0]
@@ -2149,7 +2150,7 @@
find_builtin_type_with_equivalent_compare(ModuleInfo, Type, EqvType,
NeedIntCast) :-
- classify_type(Type, ModuleInfo, TypeCategory),
+ TypeCategory = classify_type(ModuleInfo, Type),
(
TypeCategory = int_type,
EqvType = Type,
@@ -2167,8 +2168,11 @@
EqvType = Type,
NeedIntCast = no
;
- TypeCategory = pred_type,
- error("pred type in find_builtin_type_with_equivalent_compare")
+ TypeCategory = void_type,
+ error("void type in find_builtin_type_with_equivalent_compare")
+ ;
+ TypeCategory = higher_order_type,
+ error("higher_order type in find_builtin_type_with_equivalent_compare")
;
TypeCategory = tuple_type,
error("tuple type in find_builtin_type_with_equivalent_compare")
@@ -2177,11 +2181,23 @@
construct_type(unqualified("int") - 0, [], EqvType),
NeedIntCast = yes
;
- TypeCategory = polymorphic_type,
- error("poly type in find_builtin_type_with_equivalent_compare")
+ TypeCategory = variable_type,
+ error("var type in find_builtin_type_with_equivalent_compare")
;
- TypeCategory = user_type,
+ TypeCategory = user_ctor_type,
error("user type in find_builtin_type_with_equivalent_compare")
+ ;
+ TypeCategory = type_info_type,
+ error("type_info type in find_builtin_type_with_equivalent_compare")
+ ;
+ TypeCategory = type_ctor_info_type,
+ error("type_ctor_info type in find_builtin_type_with_equivalent_compare")
+ ;
+ TypeCategory = typeclass_info_type,
+ error("typeclass_info type in find_builtin_type_with_equivalent_compare")
+ ;
+ TypeCategory = base_typeclass_info_type,
+ error("base_typeclass_info type in find_builtin_type_with_equivalent_compare")
).
:- pred specializeable_special_call(special_pred_id::in, proc_id::in)
@@ -3014,7 +3030,7 @@
UniMode = (free -> ConstInst) - (ConstInst -> ConstInst),
ConstGoal = unify(LVar, RHS, UniMode,
construct(LVar, ConsId, CurriedHeadVars1, UniModes,
- construct_dynamically, cell_is_unique, no),
+ construct_dynamically, cell_is_unique, no, no),
unify_context(explicit, [])) - ConstGoalInfo,
ConstGoals0 = CurriedConstGoals ++ [ConstGoal]
;
@@ -3039,7 +3055,7 @@
add_rtti_info(Var - VarType, !ProcInfo) :-
(
- polymorphism__type_info_type(VarType, Type),
+ polymorphism__type_info_or_ctor_type(VarType, Type),
Type = term__variable(TVar)
->
maybe_set_typeinfo_locn(TVar, type_info(Var), !ProcInfo)
Index: compiler/hlds_goal.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_goal.m,v
retrieving revision 1.106
diff -u -b -r1.106 hlds_goal.m
--- compiler/hlds_goal.m 7 May 2003 00:50:21 -0000 1.106
+++ compiler/hlds_goal.m 7 May 2003 05:22:23 -0000
@@ -375,7 +375,7 @@
construct_is_unique :: cell_is_unique,
% Can the cell be allocated
% in shared data.
- construct_exprn_id :: maybe(rl_exprn_id)
+ construct_exprn_id :: maybe(rl_exprn_id),
% Used for `aditi_top_down' closures
% passed to `aditi_delete' and
% `aditi_modify' calls where the
@@ -390,6 +390,18 @@
% to tuples for which the closure could
% succeed, reducing the number of
% tuples read from disk.
+ term_size_slot :: maybe(term_size_value)
+ % The value `yes' tells the code
+ % generator to reserve an extra slot,
+ % at offset -1, to hold an integer
+ % giving the size of the term.
+ % The argument specifies the value
+ % to be put into this slot, either
+ % as an integer constant or as the
+ % value of a given variable.
+ %
+ % The value `no' means there is no
+ % extra slot, and is the default.
)
% A deconstruction unification is a unification with a functor
@@ -475,6 +487,15 @@
% being a complicated unify.
).
+:- type term_size_value
+ ---> known_size(
+ int % The cell being created has this size.
+ )
+ ; dynamic_size(
+ prog_var % This variable contains the size of
+ % the cell being created.
+ ).
+
% `yes' iff the cell is available for compile time garbage collection.
% Compile time garbage collection is when the compiler
% recognises that a memory cell is no longer needed and can be
@@ -1841,7 +1862,7 @@
Mode = (free -> Inst) - (Inst -> Inst),
RLExprnId = no,
Unification = construct(Var, ConsId, [], [],
- construct_dynamically, cell_is_unique, RLExprnId),
+ construct_dynamically, cell_is_unique, RLExprnId, no),
Context = unify_context(explicit, []),
Goal = unify(Var, RHS, Mode, Unification, Context),
set__singleton_set(NonLocals, Var),
@@ -1858,7 +1879,7 @@
list__duplicate(Arity, UniMode, UniModes),
ExprnId = no,
Unification = construct(Tuple, ConsId, Args, UniModes,
- construct_dynamically, cell_is_unique, ExprnId),
+ construct_dynamically, cell_is_unique, ExprnId, no),
UnifyContext = unify_context(explicit, []),
Unify = unify(Tuple, Rhs, UnifyMode, Unification, UnifyContext),
set__list_to_set([Tuple | Args], NonLocals),
Index: compiler/hlds_module.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_module.m,v
retrieving revision 1.86
diff -u -b -r1.86 hlds_module.m
--- compiler/hlds_module.m 26 May 2003 08:59:55 -0000 1.86
+++ compiler/hlds_module.m 26 May 2003 09:11:55 -0000
@@ -1320,8 +1320,8 @@
; mode_no(int). % The Nth mode, counting from 0.
:- pred lookup_builtin_pred_proc_id(module_info, module_name,
- string, arity, mode_no, pred_id, proc_id).
-:- mode lookup_builtin_pred_proc_id(in, in, in, in, in, out, out) is det.
+ string, pred_or_func, arity, mode_no, pred_id, proc_id).
+:- mode lookup_builtin_pred_proc_id(in, in, in, in, in, in, out, out) is det.
%-----------------------------------------------------------------------------%
@@ -2029,27 +2029,47 @@
error(Message)
).
-lookup_builtin_pred_proc_id(Module, ModuleName, PredName,
+lookup_builtin_pred_proc_id(Module, ModuleName, ProcName, PredOrFunc,
Arity, ModeNo, PredId, ProcId) :-
module_info_get_predicate_table(Module, PredTable),
(
+ (
+ PredOrFunc = predicate,
predicate_table_search_pred_m_n_a(PredTable,
- is_fully_qualified, ModuleName, PredName, Arity,
+ is_fully_qualified, ModuleName, ProcName, Arity,
+ [PredId0])
+ ;
+ PredOrFunc = function,
+ predicate_table_search_func_m_n_a(PredTable,
+ is_fully_qualified, ModuleName, ProcName, Arity,
[PredId0])
+ )
->
PredId = PredId0
;
% Some of the table builtins are polymorphic,
% and for them we need to subtract one from the arity
% to take into account the type_info argument.
+ % XXX The caller should supply us with the exact arity.
+ % Guessing how many of the arguments are typeinfos and/or
+ % typeclass_infos, as this code here does, is error-prone
+ % as well as inefficient.
+ (
+ PredOrFunc = predicate,
predicate_table_search_pred_m_n_a(PredTable,
- is_fully_qualified, ModuleName, PredName, Arity - 1,
- [PredId0])
+ is_fully_qualified, ModuleName, ProcName,
+ Arity - 1, [PredId0])
+ ;
+ PredOrFunc = function,
+ predicate_table_search_func_m_n_a(PredTable,
+ is_fully_qualified, ModuleName, ProcName,
+ Arity - 1, [PredId0])
+ )
->
PredId = PredId0
;
string__int_to_string(Arity, ArityS),
- string__append_list(["can't locate ", PredName,
+ string__append_list(["can't locate ", ProcName,
"/", ArityS], ErrorMessage),
error(ErrorMessage)
),
@@ -2064,7 +2084,7 @@
;
error(string__format(
"expected single mode for %s/%d",
- [s(PredName), i(Arity)]))
+ [s(ProcName), i(Arity)]))
)
;
ModeNo = mode_no(N),
@@ -2075,7 +2095,7 @@
;
error(string__format(
"there is no mode %d for %s/%d",
- [i(N), s(PredName), i(Arity)]))
+ [i(N), s(ProcName), i(Arity)]))
)
).
Index: compiler/hlds_out.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_out.m,v
retrieving revision 1.309
diff -u -b -r1.309 hlds_out.m
--- compiler/hlds_out.m 26 May 2003 08:59:55 -0000 1.309
+++ compiler/hlds_out.m 26 May 2003 09:11:58 -0000
@@ -1913,39 +1913,30 @@
{ set__to_sorted_list(CallResumeSet, CallResumeList) },
{ set__to_sorted_list(CallNondetSet, CallNondetList) },
hlds_out__write_indent(Indent),
- io__write_string("% need across call forward vars:"),
+ io__write_string("% need across call forward vars: "),
( { CallForwardList = [] } ->
- io__write_string(" none\n")
+ io__write_string("none\n")
;
- io__write_string("\n"),
- hlds_out__write_indent(Indent),
- io__write_string("% "),
hlds_out__write_vars(CallForwardList, VarSet,
AppendVarnums),
io__write_string("\n")
),
hlds_out__write_indent(Indent),
- io__write_string("% need across call resume vars:"),
+ io__write_string("% need across call resume vars: "),
( { CallResumeList = [] } ->
- io__write_string(" none\n")
+ io__write_string("none\n")
;
- io__write_string("\n"),
- hlds_out__write_indent(Indent),
- io__write_string("% "),
hlds_out__write_vars(CallResumeList, VarSet,
AppendVarnums),
io__write_string("\n")
),
hlds_out__write_indent(Indent),
- io__write_string("% need across call nondet vars:"),
+ io__write_string("% need across call nondet vars: "),
( { CallNondetList = [] } ->
- io__write_string(" none\n")
+ io__write_string("none\n")
;
- io__write_string("\n"),
- hlds_out__write_indent(Indent),
- io__write_string("% "),
hlds_out__write_vars(CallNondetList, VarSet,
AppendVarnums),
io__write_string("\n")
@@ -1973,26 +1964,20 @@
io__write_string("% resume point has no stack label\n")
),
hlds_out__write_indent(Indent),
- io__write_string("% need in resume resume vars:"),
+ io__write_string("% need in resume resume vars: "),
( { ResumeResumeList = [] } ->
- io__write_string(" none\n")
+ io__write_string("none\n")
;
- io__write_string("\n"),
- hlds_out__write_indent(Indent),
- io__write_string("% "),
hlds_out__write_vars(ResumeResumeList, VarSet,
AppendVarnums),
io__write_string("\n")
),
hlds_out__write_indent(Indent),
- io__write_string("% need in resume nondet vars:"),
+ io__write_string("% need in resume nondet vars: "),
( { ResumeNondetList = [] } ->
- io__write_string(" none\n")
+ io__write_string("none\n")
;
- io__write_string("\n"),
- hlds_out__write_indent(Indent),
- io__write_string("% "),
hlds_out__write_vars(ResumeNondetList, VarSet,
AppendVarnums),
io__write_string("\n")
@@ -2009,9 +1994,7 @@
{ NeedInParConj = need_in_par_conj(ParConjSet) },
{ set__to_sorted_list(ParConjSet, ParConjList) },
hlds_out__write_indent(Indent),
- io__write_string("% need in par_conj vars:\n"),
- hlds_out__write_indent(Indent),
- io__write_string("% "),
+ io__write_string("% need in par_conj vars: "),
hlds_out__write_vars(ParConjList, VarSet, AppendVarnums),
io__write_string("\n")
;
@@ -2184,14 +2167,40 @@
mercury_output_var(Y, ProgVarSet, AppendVarnums),
io__write_string("\n").
-hlds_out__write_unification(construct(Var, ConsId, ArgVars, ArgModes, _, _, _),
+hlds_out__write_unification(construct(Var, ConsId, ArgVars, ArgModes,
+ _ConstructHow, Uniqueness, _AditiRLExprnId, Size),
ModuleInfo, ProgVarSet, InstVarSet, AppendVarnums, Indent) -->
hlds_out__write_indent(Indent),
io__write_string("% "),
mercury_output_var(Var, ProgVarSet, AppendVarnums),
io__write_string(" := "),
hlds_out_write_functor_and_submodes(ConsId, ArgVars, ArgModes,
- ModuleInfo, ProgVarSet, InstVarSet, AppendVarnums, Indent).
+ ModuleInfo, ProgVarSet, InstVarSet, AppendVarnums, Indent),
+ (
+ { Uniqueness = cell_is_unique },
+ hlds_out__write_indent(Indent),
+ io__write_string("% cell_is_unique\n")
+ ;
+ { Uniqueness = cell_is_shared }
+ ),
+ (
+ { Size = yes(SizeSource) },
+ hlds_out__write_indent(Indent),
+ io__write_string("% term size "),
+ (
+ { SizeSource = known_size(KnownSize) },
+ io__write_string("const "),
+ io__write_int(KnownSize),
+ io__write_string("\n")
+ ;
+ { SizeSource = dynamic_size(SizeVar) },
+ io__write_string("var "),
+ mercury_output_var(SizeVar, ProgVarSet, AppendVarnums),
+ io__write_string("\n")
+ )
+ ;
+ { Size = no }
+ ).
hlds_out__write_unification(deconstruct(Var, ConsId, ArgVars, ArgModes,
CanFail, CanCGC),
Index: compiler/hlds_pred.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_pred.m,v
retrieving revision 1.126
diff -u -b -r1.126 hlds_pred.m
--- compiler/hlds_pred.m 26 May 2003 08:59:56 -0000 1.126
+++ compiler/hlds_pred.m 26 May 2003 09:12:01 -0000
@@ -2483,6 +2483,17 @@
% follows that it must be exported somewhere.
Status \= local
;
+ % If term size profiling (of either form) is enabled,
+ % then we may need to access the typeinfo of any
+ % variable bound to a heap cell argument. The only way
+ % to ensure that this is possible is to preserve the
+ % ability to access the typeinfo of any variable.
+ globals__lookup_bool_option(Globals,
+ record_term_sizes_as_words, yes)
+ ;
+ globals__lookup_bool_option(Globals,
+ record_term_sizes_as_cells, yes)
+ ;
non_special_body_should_use_typeinfo_liveness(Globals,
yes)
)
Index: compiler/intermod.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/intermod.m,v
retrieving revision 1.141
diff -u -b -r1.141 intermod.m
--- compiler/intermod.m 26 May 2003 08:59:57 -0000 1.141
+++ compiler/intermod.m 26 May 2003 09:12:01 -0000
@@ -434,7 +434,7 @@
(
mode_is_input(ModuleInfo, ArgMode),
map__lookup(VarTypes, HeadVar, Type),
- classify_type(Type, ModuleInfo, pred_type)
+ classify_type(ModuleInfo, Type) = higher_order_type
;
check_for_ho_input_args(ModuleInfo, HeadVars,
ArgModes, VarTypes)
Index: compiler/jumpopt.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/jumpopt.m,v
retrieving revision 1.66
diff -u -b -r1.66 jumpopt.m
--- compiler/jumpopt.m 9 May 2003 05:51:50 -0000 1.66
+++ compiler/jumpopt.m 9 May 2003 06:05:02 -0000
@@ -826,7 +826,7 @@
;
CodeAddr = CodeAddr0
).
-jumpopt__short_labels_const(data_addr_const(D), _, data_addr_const(D)).
+jumpopt__short_labels_const(data_addr_const(D, O), _, data_addr_const(D, O)).
:- pred jumpopt__short_labels_maybe_rvals(list(maybe(rval)), instrmap,
list(maybe(rval))).
Index: compiler/lambda.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/lambda.m,v
retrieving revision 1.81
diff -u -b -r1.81 lambda.m
--- compiler/lambda.m 9 May 2003 01:03:22 -0000 1.81
+++ compiler/lambda.m 9 May 2003 02:11:43 -0000
@@ -350,7 +350,7 @@
OrigVars = OrigNonLocals0,
(
- Unification0 = construct(Var0, _, _, UniModes0, _, _, _)
+ Unification0 = construct(Var0, _, _, UniModes0, _, _, _, _)
->
Var = Var0,
UniModes1 = UniModes0
@@ -592,7 +592,7 @@
RLExprnId = no,
Unification = construct(Var, ConsId, ArgVars, UniModes,
- construct_dynamically, cell_is_unique, RLExprnId),
+ construct_dynamically, cell_is_unique, RLExprnId, no),
LambdaInfo = lambda_info(VarSet, VarTypes, Constraints, TVarSet,
InstVarSet, TVarMap, TCVarMap, Markers, POF, OrigPredName,
Owner, ModuleInfo, MustRecomputeNonLocals).
Index: compiler/lco.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/lco.m,v
retrieving revision 1.20
diff -u -b -r1.20 lco.m
--- compiler/lco.m 15 Mar 2003 03:08:54 -0000 1.20
+++ compiler/lco.m 17 Mar 2003 08:12:44 -0000
@@ -153,7 +153,7 @@
Goal0 = GoalExpr0 - _,
(
GoalExpr0 = unify(_, _, _, Unif, _),
- Unif = construct(_, _, _, _, _, _, _)
+ Unif = construct(_, _, _, _, _, _, _, _)
->
Unifies1 = [Goal0 | Unifies0],
lco_in_conj(Goals0, Unifies1, ModuleInfo, Goals)
Index: compiler/livemap.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/livemap.m,v
retrieving revision 1.57
diff -u -b -r1.57 livemap.m
--- compiler/livemap.m 9 May 2003 05:51:50 -0000 1.57
+++ compiler/livemap.m 9 May 2003 06:05:07 -0000
@@ -240,7 +240,7 @@
Livemap = Livemap0,
DontValueNumber = DontValueNumber0
;
- Uinstr0 = incr_hp(Lval, _, Rval, _),
+ Uinstr0 = incr_hp(Lval, _, _, Rval, _),
% Make dead the variable assigned, but make any variables
% needed to access it live. Make the variables in the size
Index: compiler/ll_pseudo_type_info.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ll_pseudo_type_info.m,v
retrieving revision 1.10
diff -u -b -r1.10 ll_pseudo_type_info.m
--- compiler/ll_pseudo_type_info.m 9 May 2003 05:51:50 -0000 1.10
+++ compiler/ll_pseudo_type_info.m 15 May 2003 04:29:15 -0000
@@ -85,7 +85,7 @@
Pseudo = plain_arity_zero_pseudo_type_info(RttiTypeCtor),
DataAddr = rtti_addr(
ctor_rtti_id(RttiTypeCtor, pseudo_type_info(Pseudo))),
- Rval = const(data_addr_const(DataAddr)),
+ Rval = const(data_addr_const(DataAddr, no)),
LldsType = data_ptr
;
Pseudo = plain_pseudo_type_info(RttiTypeCtor, Args),
@@ -109,7 +109,7 @@
TypeInfo = plain_arity_zero_type_info(RttiTypeCtor),
DataAddr = rtti_addr(
ctor_rtti_id(RttiTypeCtor, type_info(TypeInfo))),
- Rval = const(data_addr_const(DataAddr)),
+ Rval = const(data_addr_const(DataAddr, no)),
LldsType = data_ptr
;
TypeInfo = plain_type_info(RttiTypeCtor, Args),
@@ -133,7 +133,7 @@
!StaticCellInfo, Rval, LldsType) :-
TypeCtorInfoDataAddr = rtti_addr(
ctor_rtti_id(RttiTypeCtor, type_ctor_info)),
- TypeCtorInfoRval = const(data_addr_const(TypeCtorInfoDataAddr)),
+ TypeCtorInfoRval = const(data_addr_const(TypeCtorInfoDataAddr, no)),
LldsType = data_ptr,
list__map_foldl((pred(A::in, AR::out, SCI0::in, SCI::out) is det :-
(
@@ -147,7 +147,7 @@
list__append(ArgRvals0, ArgRvals1, ArgRvals),
add_static_cell_natural_types([TypeCtorInfoRval | ArgRvals], DataAddr,
!StaticCellInfo),
- Rval = const(data_addr_const(DataAddr)).
+ Rval = const(data_addr_const(DataAddr, no)).
:- pred convert_compound_type_info(rtti_type_ctor::in, list(rval)::in,
list(rtti_type_info)::in, static_cell_info::in, static_cell_info::out,
@@ -158,7 +158,7 @@
TypeCtorInfoData = type_info(plain_arity_zero_type_info(RttiTypeCtor)),
TypeCtorInfoDataAddr = rtti_addr(
ctor_rtti_id(RttiTypeCtor, TypeCtorInfoData)),
- TypeCtorInfoRval = const(data_addr_const(TypeCtorInfoDataAddr)),
+ TypeCtorInfoRval = const(data_addr_const(TypeCtorInfoDataAddr, no)),
LldsType = data_ptr,
list__map_foldl((pred(A::in, AR::out, SCI0::in, SCI::out) is det :-
convert_plain_type_info(A, SCI0, SCI, AR, _LldsType)
@@ -166,4 +166,4 @@
list__append(ArgRvals0, ArgRvals1, ArgRvals),
add_static_cell_natural_types([TypeCtorInfoRval | ArgRvals],
DataAddr, !StaticCellInfo),
- Rval = const(data_addr_const(DataAddr)).
+ Rval = const(data_addr_const(DataAddr, no)).
Index: compiler/llds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/llds.m,v
retrieving revision 1.295
diff -u -b -r1.295 llds.m
--- compiler/llds.m 9 May 2003 05:51:50 -0000 1.295
+++ compiler/llds.m 9 May 2003 06:10:50 -0000
@@ -235,10 +235,12 @@
; if_val(rval, code_addr)
% If rval is true, then goto code_addr.
- ; incr_hp(lval, maybe(tag), rval, string)
+ ; incr_hp(lval, maybe(tag), maybe(int), rval, string)
% Get a memory block of a size given by an rval
% and put its address in the given lval,
- % possibly after tagging it with a given tag.
+ % possibly after incrementing it by N words
+ % (if the maybe(int) is bound to `yes(N)')
+ % and/or after tagging it with a given tag.
% The string gives the name of the type constructor
% of the memory cell for use in memory profiling.
@@ -756,7 +758,9 @@
% whose real length is given by the integer,
% and not the location of the first NULL
; code_addr_const(code_addr)
- ; data_addr_const(data_addr)
+ ; data_addr_const(data_addr, maybe(int))
+ % if the second arg is yes(Offset), then increment the
+ % address of the first by Offset words
; label_entry(label).
% the address of the label (uses MR_ENTRY macro).
@@ -967,7 +971,7 @@
llds__const_type(string_const(_), string).
llds__const_type(multi_string_const(_, _), string).
llds__const_type(code_addr_const(_), code_ptr).
-llds__const_type(data_addr_const(_), data_ptr).
+llds__const_type(data_addr_const(_, _), data_ptr).
llds__const_type(label_entry(_), code_ptr).
llds__unop_return_type(mktag, word).
Index: compiler/llds_out.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/llds_out.m,v
retrieving revision 1.214
diff -u -b -r1.214 llds_out.m
--- compiler/llds_out.m 9 May 2003 05:51:51 -0000 1.214
+++ compiler/llds_out.m 26 May 2003 09:34:18 -0000
@@ -1347,7 +1347,7 @@
output_instruction_decls(if_val(Rval, Target), _, DeclSet0, DeclSet) -->
output_rval_decls(Rval, "", "", 0, _, DeclSet0, DeclSet1),
output_code_addr_decls(Target, "", "", 0, _, DeclSet1, DeclSet).
-output_instruction_decls(incr_hp(Lval, _Tag, Rval, _), _,
+output_instruction_decls(incr_hp(Lval, _Tag, _, Rval, _), _,
DeclSet0, DeclSet) -->
output_lval_decls(Lval, "", "", 0, _, DeclSet0, DeclSet1),
output_rval_decls(Rval, "", "", 0, _, DeclSet1, DeclSet).
@@ -1643,19 +1643,28 @@
output_goto(Target, CallerLabel),
io__write_string("\t}\n").
-output_instruction(incr_hp(Lval, MaybeTag, Rval, TypeMsg), ProfInfo) -->
+output_instruction(incr_hp(Lval, MaybeTag, MaybeOffset, Rval, TypeMsg),
+ ProfInfo) -->
(
{ MaybeTag = no },
- io__write_string("\tMR_incr_hp_msg("),
+ io__write_string("\tMR_offset_incr_hp_msg("),
output_lval_as_word(Lval)
;
{ MaybeTag = yes(Tag) },
- io__write_string("\tMR_tag_incr_hp_msg("),
+ io__write_string("\tMR_tag_offset_incr_hp_msg("),
output_lval_as_word(Lval),
io__write_string(", "),
output_tag(Tag)
),
io__write_string(", "),
+ (
+ { MaybeOffset = no },
+ io__write_string("0, ")
+ ;
+ { MaybeOffset = yes(Offset) },
+ io__write_int(Offset),
+ io__write_string(", ")
+ ),
output_rval_as_type(Rval, word),
io__write_string(", "),
{ ProfInfo = CallerLabel - _ },
@@ -2095,7 +2104,7 @@
( { Const = code_addr_const(CodeAddress) } ->
output_code_addr_decls(CodeAddress, FirstIndent, LaterIndent,
N0, N, DeclSet0, DeclSet)
- ; { Const = data_addr_const(DataAddr) } ->
+ ; { Const = data_addr_const(DataAddr, _) } ->
output_data_addr_decls(DataAddr,
FirstIndent, LaterIndent, N0, N, DeclSet0, DeclSet)
; { Const = float_const(FloatVal) } ->
@@ -3460,12 +3469,25 @@
io__write_string("MR_FALSE").
output_rval_const(code_addr_const(CodeAddress)) -->
output_code_addr(CodeAddress).
-output_rval_const(data_addr_const(DataAddr)) -->
- % data addresses are all assumed to be of type `MR_Word *';
- % we need to cast them here to avoid type errors
+output_rval_const(data_addr_const(DataAddr, MaybeOffset)) -->
+ % Data addresses are all assumed to be of type `MR_Word *';
+ % we need to cast them here to avoid type errors. The offset
+ % is also in MR_Words.
+ (
+ { MaybeOffset = no },
output_llds_type_cast(data_ptr),
io__write_string("&"),
- output_data_addr(DataAddr).
+ output_data_addr(DataAddr)
+ ;
+ { MaybeOffset = yes(Offset) },
+ io__write_string("(("),
+ output_llds_type_cast(data_ptr),
+ io__write_string("&"),
+ output_data_addr(DataAddr),
+ io__write_string(") + "),
+ io__write_int(Offset),
+ io__write_string(")")
+ ).
output_rval_const(label_entry(Label)) -->
io__write_string("MR_ENTRY("),
output_label(Label),
Index: compiler/lookup_switch.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/lookup_switch.m,v
retrieving revision 1.49
diff -u -b -r1.49 lookup_switch.m
--- compiler/lookup_switch.m 26 May 2003 08:59:58 -0000 1.49
+++ compiler/lookup_switch.m 26 May 2003 09:12:01 -0000
@@ -142,7 +142,7 @@
% bitvector test.
code_info__variable_type(CaseVar, Type),
code_info__get_module_info(ModuleInfo),
- { classify_type(Type, ModuleInfo, TypeCategory) },
+ { classify_type(ModuleInfo, Type) = TypeCategory },
(
dense_switch__type_range(TypeCategory, Type,
TypeRange),
@@ -419,7 +419,7 @@
map__to_assoc_list(BitMap, WordVals),
generate_bit_vec_args(WordVals, 0, Args),
add_static_cell_natural_types(Args, DataAddr, !CodeInfo),
- BitVec = const(data_addr_const(DataAddr)).
+ BitVec = const(data_addr_const(DataAddr, no)).
:- pred generate_bit_vec_2(case_consts::in, int::in, int::in,
map(int, int)::in, map(int, int)::out) is det.
@@ -478,7 +478,7 @@
{ list__sort(Vals0, Vals) },
{ construct_args(Vals, 0, Args) },
code_info__add_static_cell_natural_types(Args, DataAddr),
- { ArrayTerm = const(data_addr_const(DataAddr)) },
+ { ArrayTerm = const(data_addr_const(DataAddr, no)) },
{ LookupLval = field(yes(0), ArrayTerm, Index) },
code_info__assign_lval_to_var(Var, LookupLval, Code),
{ require(tree__is_empty(Code),
Index: compiler/loop_inv.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/loop_inv.m,v
retrieving revision 1.4
diff -u -b -r1.4 loop_inv.m
--- compiler/loop_inv.m 15 Mar 2003 03:08:56 -0000 1.4
+++ compiler/loop_inv.m 17 Mar 2003 08:12:40 -0000
@@ -1172,7 +1172,7 @@
(
% The LHS is always an output var in constructions.
%
- Kind = construct(_, _, RHSArgs, ArgUniModes, _, _, _),
+ Kind = construct(_, _, RHSArgs, ArgUniModes, _, _, _, _),
Inputs = list__filter_map_corresponding(
input_arg(MI), RHSArgs, rhs_modes(ArgUniModes))
;
@@ -1256,7 +1256,7 @@
(
% The LHS is the only output in a construction.
%
- Kind = construct(_, _, _, _, _, _, _),
+ Kind = construct(_, _, _, _, _, _, _, _),
Outputs = [LHS]
;
% The LHS is always in input in deconstructions.
Index: compiler/magic.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/magic.m,v
retrieving revision 1.36
diff -u -b -r1.36 magic.m
--- compiler/magic.m 26 May 2003 08:59:58 -0000 1.36
+++ compiler/magic.m 26 May 2003 09:12:02 -0000
@@ -1446,7 +1446,7 @@
magic__preprocess_goal_2(Goal0, Goals, HOMap0, HOMap) -->
{ Goal0 = unify(_, _, _, Uni, _) - GoalInfo },
(
- { Uni = construct(Var, pred_const(_, _, _), Args, _, _, _, _) }
+ { Uni = construct(Var, pred_const(_, _, _), Args, _,_,_,_,_) }
->
% Collect up the closure construction so that it can be
% placed next to the aggregate goal that uses it.
@@ -1578,7 +1578,7 @@
;
Goal = unify(_, _, _, Uni, _) - _,
Uni = construct(_, pred_const(PredId, ProcId, _),
- _, _, _, _, _),
+ _, _, _, _, _, _),
% XXX once the implementation of aggregates has
% been updated to use `aditi_bottom_up' closures,
% this can be done by just checking the eval_method.
Index: compiler/magic_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/magic_util.m,v
retrieving revision 1.28
diff -u -b -r1.28 magic_util.m
--- compiler/magic_util.m 26 May 2003 08:59:58 -0000 1.28
+++ compiler/magic_util.m 26 May 2003 09:12:02 -0000
@@ -269,7 +269,7 @@
magic_util__check_aggregate_closure(Goal, Goal) :-
Goal = unify(_, _, _, Uni, _) - _,
- Uni = construct(_, pred_const(_, _, _), _, _, _, _, _).
+ Uni = construct(_, pred_const(_, _, _), _, _, _, _, _, _).
:- pred magic_util__construct_db_call(module_info::in, pred_id::in,
proc_id::in, list(prog_var)::in, hlds_goal::in, db_call::out) is det.
@@ -451,7 +451,7 @@
magic_info_get_pred_map(PredMap),
(
{ Closure = unify(_, _, UniMode, Uni0, Context) - Info },
- { Uni0 = construct(Var, ConsId0, _, Modes, _, _, _) },
+ { Uni0 = construct(Var, ConsId0, _, Modes, _, _, _, _) },
{ ConsId0 = pred_const(PredId0, ProcId0, Method) }
->
%
@@ -504,7 +504,8 @@
{ RLExprnId = no },
{ Uni = construct(Var, ConsId, InputVars, Modes,
- construct_dynamically, cell_is_unique, RLExprnId) },
+ construct_dynamically, cell_is_unique, RLExprnId,
+ no) },
{ Goal1 = unify(Var, Rhs, UniMode, Uni, Context) - Info },
{ list__append(InputGoals, [Goal1], InputAndClosure) }
@@ -845,7 +846,7 @@
{ Unify = construct(InputVar,
pred_const(SuppPredId, SuppProcId, (aditi_bottom_up)),
LambdaInputs, UniModes, construct_dynamically,
- cell_is_unique, RLExprnId) },
+ cell_is_unique, RLExprnId, no) },
{ UnifyContext = unify_context(explicit, []) },
% Construct a goal_info.
@@ -1292,7 +1293,7 @@
% Polymorphic types are not allowed.
% Errors for type_infos and typeclass_infos are only reported
% if there are no other polymorphic arguments.
- ( { polymorphism__type_info_type(ArgType, _) } ->
+ ( { polymorphism__type_info_or_ctor_type(ArgType, _) } ->
{ set__init(Errors) },
{ MaybeRtti = yes(type_info) }
; { polymorphism__typeclass_info_class_constraint(ArgType, _) } ->
Index: compiler/make_hlds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/make_hlds.m,v
retrieving revision 1.441
diff -u -b -r1.441 make_hlds.m
--- compiler/make_hlds.m 26 May 2003 08:59:58 -0000 1.441
+++ compiler/make_hlds.m 26 May 2003 09:12:09 -0000
@@ -4344,8 +4344,10 @@
% easier when redefining builtins to use normal Mercury code.
{ pred_info_is_builtin(PredInfo1) }
->
- prog_out__write_context(Context),
- report_warning("Warning: clause for builtin.\n"),
+ % XXX commented out while the change to builtin_ops is
+ % bootstrapped
+ % prog_out__write_context(Context),
+ % report_warning("Warning: clause for builtin.\n"),
{ ModuleInfo = ModuleInfo1 },
{ Info = Info0 }
;
Index: compiler/mark_static_terms.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mark_static_terms.m,v
retrieving revision 1.10
diff -u -b -r1.10 mark_static_terms.m
--- compiler/mark_static_terms.m 15 Mar 2003 03:08:57 -0000 1.10
+++ compiler/mark_static_terms.m 17 Mar 2003 08:11:40 -0000
@@ -144,7 +144,7 @@
StaticVars0, StaticVars) :-
(
Unification0 = construct(Var, ConsId, ArgVars, D,
- HowToConstruct0, F, G),
+ HowToConstruct0, F, G, H),
(
% if all the arguments are static,
% then the newly constructed variable
@@ -168,7 +168,7 @@
Unification = Unification0
;
Unification = construct(Var, ConsId, ArgVars, D,
- HowToConstruct, F, G)
+ HowToConstruct, F, G, H)
)
;
Unification0 = deconstruct(_Var, _ConsId, _ArgVars, _UniModes,
Index: compiler/mercury_compile.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mercury_compile.m,v
retrieving revision 1.287
diff -u -b -r1.287 mercury_compile.m
--- compiler/mercury_compile.m 26 May 2003 09:00:00 -0000 1.287
+++ compiler/mercury_compile.m 26 May 2003 09:12:10 -0000
@@ -79,6 +79,7 @@
:- import_module transform_hlds__unused_args.
:- import_module transform_hlds__unneeded_code.
:- import_module transform_hlds__lco.
+:- import_module transform_hlds__size_prof.
:- import_module ll_backend__deep_profiling.
% the LLDS back-end
@@ -2151,8 +2152,14 @@
mercury_compile__maybe_magic(HLDS45, Verbose, Stats, HLDS47),
mercury_compile__maybe_dump_hlds(HLDS47, "47", "magic"),
- mercury_compile__maybe_dead_procs(HLDS47, Verbose, Stats, HLDS49),
- mercury_compile__maybe_dump_hlds(HLDS49, "49", "dead_procs"),
+ mercury_compile__maybe_dead_procs(HLDS47, Verbose, Stats, HLDS48),
+ mercury_compile__maybe_dump_hlds(HLDS48, "48", "dead_procs"),
+
+ % The term size profiling transformation should be after all
+ % transformations that construct terms of non-zero size. (Deep
+ % profiling does not construct non-zero size terms.)
+ mercury_compile__maybe_term_size_prof(HLDS48, Verbose, Stats, HLDS49),
+ mercury_compile__maybe_dump_hlds(HLDS49, "49", "term_size_prof"),
% Deep profiling transformation should be done late in the piece
% since it munges the code a fair amount and introduces strange
@@ -3195,6 +3202,47 @@
{ HLDS0 = HLDS }
).
+:- pred mercury_compile__maybe_term_size_prof(module_info::in,
+ bool::in, bool::in, module_info::out, io__state::di, io__state::uo)
+ is det.
+
+mercury_compile__maybe_term_size_prof(HLDS0, Verbose, Stats, HLDS) -->
+ globals__io_lookup_bool_option(record_term_sizes_as_words, AsWords),
+ globals__io_lookup_bool_option(record_term_sizes_as_cells, AsCells),
+ {
+ AsWords = yes,
+ AsCells = yes,
+ error("mercury_compile__maybe_term_size_prof: "
+ ++ "as_words and as_cells")
+ ;
+ AsWords = yes,
+ AsCells = no,
+ MaybeTransform = yes(term_words)
+ ;
+ AsWords = no,
+ AsCells = yes,
+ MaybeTransform = yes(term_cells)
+ ;
+ AsWords = no,
+ AsCells = no,
+ MaybeTransform = no
+ },
+ (
+ { MaybeTransform = yes(Transform) },
+ maybe_write_string(Verbose,
+ "% Applying term size profiling transformation...\n"),
+ maybe_flush_output(Verbose),
+ process_all_nonimported_nonaditi_procs(
+ update_module_io(
+ size_prof__process_proc_msg(Transform)),
+ HLDS0, HLDS),
+ maybe_write_string(Verbose, "% done.\n"),
+ maybe_report_stats(Stats)
+ ;
+ { MaybeTransform = no },
+ { HLDS0 = HLDS }
+ ).
+
:- pred mercury_compile__maybe_deep_profiling(module_info, bool, bool,
module_info, list(layout_data), io__state, io__state).
:- mode mercury_compile__maybe_deep_profiling(in, in, in, out, out, di, uo)
Index: compiler/middle_rec.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/middle_rec.m,v
retrieving revision 1.95
diff -u -b -r1.95 middle_rec.m
--- compiler/middle_rec.m 26 May 2003 09:00:01 -0000 1.95
+++ compiler/middle_rec.m 26 May 2003 09:12:10 -0000
@@ -397,55 +397,55 @@
:- pred middle_rec__find_used_registers_instr(instr, set(int), set(int)).
:- mode middle_rec__find_used_registers_instr(in, di, uo) is det.
-middle_rec__find_used_registers_instr(comment(_), Used, Used).
-middle_rec__find_used_registers_instr(livevals(LvalSet), Used0, Used) :-
+middle_rec__find_used_registers_instr(comment(_), !Used).
+middle_rec__find_used_registers_instr(livevals(LvalSet), !Used) :-
set__to_sorted_list(LvalSet, LvalList),
- middle_rec__find_used_registers_lvals(LvalList, Used0, Used).
-middle_rec__find_used_registers_instr(block(_, _, Instrs), Used0, Used) :-
- middle_rec__find_used_registers(Instrs, Used0, Used).
-middle_rec__find_used_registers_instr(assign(Lval, Rval), Used0, Used) :-
- middle_rec__find_used_registers_lval(Lval, Used0, Used1),
- middle_rec__find_used_registers_rval(Rval, Used1, Used).
-middle_rec__find_used_registers_instr(call(_, _, _, _, _, _), Used, Used).
-middle_rec__find_used_registers_instr(mkframe(_, _), Used, Used).
-middle_rec__find_used_registers_instr(label(_), Used, Used).
-middle_rec__find_used_registers_instr(goto(_), Used, Used).
-middle_rec__find_used_registers_instr(computed_goto(Rval, _), Used0, Used) :-
- middle_rec__find_used_registers_rval(Rval, Used0, Used).
-middle_rec__find_used_registers_instr(c_code(_, _), Used, Used).
-middle_rec__find_used_registers_instr(if_val(Rval, _), Used0, Used) :-
- middle_rec__find_used_registers_rval(Rval, Used0, Used).
-middle_rec__find_used_registers_instr(incr_hp(Lval, _, Rval, _), Used0, Used) :-
- middle_rec__find_used_registers_lval(Lval, Used0, Used1),
- middle_rec__find_used_registers_rval(Rval, Used1, Used).
-middle_rec__find_used_registers_instr(mark_hp(Lval), Used0, Used) :-
- middle_rec__find_used_registers_lval(Lval, Used0, Used).
-middle_rec__find_used_registers_instr(restore_hp(Rval), Used0, Used) :-
- middle_rec__find_used_registers_rval(Rval, Used0, Used).
-middle_rec__find_used_registers_instr(free_heap(Rval), Used0, Used) :-
- middle_rec__find_used_registers_rval(Rval, Used0, Used).
-middle_rec__find_used_registers_instr(store_ticket(Lval), Used0, Used) :-
- middle_rec__find_used_registers_lval(Lval, Used0, Used).
-middle_rec__find_used_registers_instr(reset_ticket(Rval, _Rsn), Used0, Used) :-
- middle_rec__find_used_registers_rval(Rval, Used0, Used).
-middle_rec__find_used_registers_instr(discard_ticket, Used, Used).
-middle_rec__find_used_registers_instr(prune_ticket, Used, Used).
-middle_rec__find_used_registers_instr(mark_ticket_stack(Lval), Used0, Used) :-
- middle_rec__find_used_registers_lval(Lval, Used0, Used).
-middle_rec__find_used_registers_instr(prune_tickets_to(Rval), Used0, Used) :-
- middle_rec__find_used_registers_rval(Rval, Used0, Used).
-middle_rec__find_used_registers_instr(incr_sp(_, _), Used, Used).
-middle_rec__find_used_registers_instr(decr_sp(_), Used, Used).
+ middle_rec__find_used_registers_lvals(LvalList, !Used).
+middle_rec__find_used_registers_instr(block(_, _, Instrs), !Used) :-
+ middle_rec__find_used_registers(Instrs, !Used).
+middle_rec__find_used_registers_instr(assign(Lval, Rval), !Used) :-
+ middle_rec__find_used_registers_lval(Lval, !Used),
+ middle_rec__find_used_registers_rval(Rval, !Used).
+middle_rec__find_used_registers_instr(call(_, _, _, _, _, _), !Used).
+middle_rec__find_used_registers_instr(mkframe(_, _), !Used).
+middle_rec__find_used_registers_instr(label(_), !Used).
+middle_rec__find_used_registers_instr(goto(_), !Used).
+middle_rec__find_used_registers_instr(computed_goto(Rval, _), !Used) :-
+ middle_rec__find_used_registers_rval(Rval, !Used).
+middle_rec__find_used_registers_instr(c_code(_, _), !Used).
+middle_rec__find_used_registers_instr(if_val(Rval, _), !Used) :-
+ middle_rec__find_used_registers_rval(Rval, !Used).
+middle_rec__find_used_registers_instr(incr_hp(Lval, _, _, Rval, _), !Used) :-
+ middle_rec__find_used_registers_lval(Lval, !Used),
+ middle_rec__find_used_registers_rval(Rval, !Used).
+middle_rec__find_used_registers_instr(mark_hp(Lval), !Used) :-
+ middle_rec__find_used_registers_lval(Lval, !Used).
+middle_rec__find_used_registers_instr(restore_hp(Rval), !Used) :-
+ middle_rec__find_used_registers_rval(Rval, !Used).
+middle_rec__find_used_registers_instr(free_heap(Rval), !Used) :-
+ middle_rec__find_used_registers_rval(Rval, !Used).
+middle_rec__find_used_registers_instr(store_ticket(Lval), !Used) :-
+ middle_rec__find_used_registers_lval(Lval, !Used).
+middle_rec__find_used_registers_instr(reset_ticket(Rval, _Rsn), !Used) :-
+ middle_rec__find_used_registers_rval(Rval, !Used).
+middle_rec__find_used_registers_instr(discard_ticket, !Used).
+middle_rec__find_used_registers_instr(prune_ticket, !Used).
+middle_rec__find_used_registers_instr(mark_ticket_stack(Lval), !Used) :-
+ middle_rec__find_used_registers_lval(Lval, !Used).
+middle_rec__find_used_registers_instr(prune_tickets_to(Rval), !Used) :-
+ middle_rec__find_used_registers_rval(Rval, !Used).
+middle_rec__find_used_registers_instr(incr_sp(_, _), !Used).
+middle_rec__find_used_registers_instr(decr_sp(_), !Used).
middle_rec__find_used_registers_instr(pragma_c(_, Components,
- _, _, _, _, _, _), Used0, Used) :-
- middle_rec__find_used_registers_components(Components, Used0, Used).
-middle_rec__find_used_registers_instr(init_sync_term(Lval, _), Used0, Used) :-
- middle_rec__find_used_registers_lval(Lval, Used0, Used).
-middle_rec__find_used_registers_instr(fork(_, _, _), Used, Used).
-middle_rec__find_used_registers_instr(join_and_terminate(Lval), Used0, Used) :-
- middle_rec__find_used_registers_lval(Lval, Used0, Used).
-middle_rec__find_used_registers_instr(join_and_continue(Lval,_), Used0, Used) :-
- middle_rec__find_used_registers_lval(Lval, Used0, Used).
+ _, _, _, _, _, _), !Used) :-
+ middle_rec__find_used_registers_components(Components, !Used).
+middle_rec__find_used_registers_instr(init_sync_term(Lval, _), !Used) :-
+ middle_rec__find_used_registers_lval(Lval, !Used).
+middle_rec__find_used_registers_instr(fork(_, _, _), !Used).
+middle_rec__find_used_registers_instr(join_and_terminate(Lval), !Used) :-
+ middle_rec__find_used_registers_lval(Lval, !Used).
+middle_rec__find_used_registers_instr(join_and_continue(Lval,_), !Used) :-
+ middle_rec__find_used_registers_lval(Lval, !Used).
:- pred middle_rec__find_used_registers_components(list(pragma_c_component),
set(int), set(int)).
Index: compiler/ml_code_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_code_util.m,v
retrieving revision 1.71
diff -u -b -r1.71 ml_code_util.m
--- compiler/ml_code_util.m 14 May 2003 14:38:43 -0000 1.71
+++ compiler/ml_code_util.m 26 May 2003 07:51:36 -0000
@@ -1770,10 +1770,25 @@
% back-ends that don't need it, e.g. the .NET and Java back-ends.
% This routine should be modified to check the target.
ml_must_box_field_type(Type, ModuleInfo) :-
- classify_type(Type, ModuleInfo, Category),
- ( Category = float_type
- ; Category = char_type
- ).
+ classify_type(ModuleInfo, Type) = Category,
+ ml_must_box_field_type_category(Category) = yes.
+
+:- func ml_must_box_field_type_category(type_category) = bool.
+
+ml_must_box_field_type_category(int_type) = no.
+ml_must_box_field_type_category(char_type) = yes.
+ml_must_box_field_type_category(str_type) = no.
+ml_must_box_field_type_category(float_type) = yes.
+ml_must_box_field_type_category(higher_order_type) = no.
+ml_must_box_field_type_category(tuple_type) = no.
+ml_must_box_field_type_category(enum_type) = no.
+ml_must_box_field_type_category(variable_type) = no.
+ml_must_box_field_type_category(type_info_type) = no.
+ml_must_box_field_type_category(type_ctor_info_type) = no.
+ml_must_box_field_type_category(typeclass_info_type) = no.
+ml_must_box_field_type_category(base_typeclass_info_type) = no.
+ml_must_box_field_type_category(void_type) = no.
+ml_must_box_field_type_category(user_ctor_type) = no.
%-----------------------------------------------------------------------------%
%
@@ -2171,6 +2186,10 @@
% to the heap, so we don't need to trace them
% for accurate GC.
% Hence we can return `no' here for mlds__cont_type.
+ %
+ % Similarly, the only pointers in type_ctor_infos and
+ % base_typeclass_infos are to static code and/or static data,
+ % which do not need to be traced.
:- func ml_type_might_contain_pointers(mlds__type) = bool.
@@ -2198,16 +2217,21 @@
ml_type_might_contain_pointers(mlds__rtti_type(_)) = yes.
ml_type_might_contain_pointers(mlds__unknown_type) = yes.
-:- func ml_type_category_might_contain_pointers(builtin_type) = bool.
+:- func ml_type_category_might_contain_pointers(type_category) = bool.
ml_type_category_might_contain_pointers(int_type) = no.
ml_type_category_might_contain_pointers(char_type) = no.
ml_type_category_might_contain_pointers(str_type) = yes.
ml_type_category_might_contain_pointers(float_type) = no.
-ml_type_category_might_contain_pointers(pred_type) = yes.
+ml_type_category_might_contain_pointers(void_type) = no.
+ml_type_category_might_contain_pointers(type_info_type) = yes.
+ml_type_category_might_contain_pointers(type_ctor_info_type) = no.
+ml_type_category_might_contain_pointers(typeclass_info_type) = yes.
+ml_type_category_might_contain_pointers(base_typeclass_info_type) = no.
+ml_type_category_might_contain_pointers(higher_order_type) = yes.
ml_type_category_might_contain_pointers(tuple_type) = yes.
ml_type_category_might_contain_pointers(enum_type) = no.
-ml_type_category_might_contain_pointers(polymorphic_type) = yes.
-ml_type_category_might_contain_pointers(user_type) = yes.
+ml_type_category_might_contain_pointers(variable_type) = yes.
+ml_type_category_might_contain_pointers(user_ctor_type) = yes.
% trace_type_info_type(Type, RealType):
% Succeed iff Type is a type_info-related type
@@ -2322,7 +2346,7 @@
{ mercury_private_builtin_module(PredModule) },
{ MLDS_Module = mercury_module_name_to_mlds(PredModule) },
{ Proc = qual(MLDS_Module, Pred - ProcId) },
- { CPointerType = mercury_type(c_pointer_type, user_type,
+ { CPointerType = mercury_type(c_pointer_type, user_ctor_type,
non_foreign_type(c_pointer_type)) },
{ ArgTypes = [mlds__pseudo_type_info_type, CPointerType] },
{ Signature = mlds__func_signature(ArgTypes, []) },
Index: compiler/ml_switch_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_switch_gen.m,v
retrieving revision 1.12
diff -u -b -r1.12 ml_switch_gen.m
--- compiler/ml_switch_gen.m 15 Mar 2003 03:08:59 -0000 1.12
+++ compiler/ml_switch_gen.m 22 May 2003 08:04:25 -0000
@@ -324,7 +324,7 @@
ml_variable_type(CaseVar, Type),
=(MLGenInfo),
{ ml_gen_info_get_module_info(MLGenInfo, ModuleInfo) },
- { type_util__classify_type(Type, ModuleInfo, TypeCategory) },
+ { type_util__classify_type(ModuleInfo, Type) = TypeCategory },
{ switch_util__type_cat_to_switch_cat(TypeCategory, SwitchCategory) }.
%-----------------------------------------------------------------------------%
Index: compiler/ml_unify_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_unify_gen.m,v
retrieving revision 1.65
diff -u -b -r1.65 ml_unify_gen.m
--- compiler/ml_unify_gen.m 9 May 2003 00:45:05 -0000 1.65
+++ compiler/ml_unify_gen.m 26 May 2003 08:01:05 -0000
@@ -147,7 +147,7 @@
ml_gen_set_success(Test, Context, MLDS_Statement).
ml_gen_unification(construct(Var, ConsId, Args, ArgModes,
- HowToConstruct, _CellIsUnique, MaybeAditiRLExprnID),
+ HowToConstruct, _CellIsUnique, MaybeAditiRLExprnID, _),
CodeModel, Context, MLDS_Decls, MLDS_Statements) -->
{ require(unify(CodeModel, model_det),
"ml_code_gen: construct not det") },
@@ -830,8 +830,12 @@
% Check for type_infos and typeclass_infos,
% since these need to be handled specially;
% their Mercury type definitions are lies.
- MLDS_Type = mercury_type(MercuryType, user_type, _),
- type_util__is_introduced_type_info_type(MercuryType)
+ MLDS_Type = mercury_type(_, TypeCategory, _),
+ ( TypeCategory = type_info_type
+ ; TypeCategory = type_ctor_info_type
+ ; TypeCategory = typeclass_info_type
+ ; TypeCategory = base_typeclass_info_type
+ )
->
ConstType = mlds__array_type(mlds__generic_type)
;
@@ -848,7 +852,7 @@
TypeArity, _)
;
MLDS_Type = mercury_type(MercuryType,
- user_type, _),
+ user_ctor_type, _),
type_to_ctor_and_args(MercuryType, TypeCtor,
_ArgsTypes),
ml_gen_type_name(TypeCtor, QualTypeName,
@@ -873,7 +877,8 @@
% `mlds__ptr_type(mlds__class_type(...))', but when
% declarating static constants we want just the
% class type, not the pointer type.
- MLDS_Type = mercury_type(MercuryType, user_type, _),
+ MLDS_Type = mercury_type(MercuryType,
+ user_ctor_type, _),
type_to_ctor_and_args(MercuryType, TypeCtor, _ArgsTypes)
->
ml_gen_type_name(TypeCtor, ClassName, ClassArity),
@@ -892,7 +897,7 @@
% Note that we're still using a low-level data
% representation for closures, even when
% --high-level-data is enabled.
- MLDS_Type = mercury_type(_, pred_type, _)
+ MLDS_Type = mercury_type(_, higher_order_type, _)
->
ConstType = mlds__array_type(mlds__generic_type)
;
@@ -973,7 +978,7 @@
% happens: the type for a ctor_id should never
% be a free type variable
unexpected(this_file,
- "cons_id_to_arg_types: invalid type")
+ "constructor_arg_types: invalid type")
),
% Given the type_ctor, lookup up the constructor
Index: compiler/mlds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds.m,v
retrieving revision 1.101
diff -u -b -r1.101 mlds.m
--- compiler/mlds.m 16 May 2003 09:48:53 -0000 1.101
+++ compiler/mlds.m 22 May 2003 08:04:35 -0000
@@ -594,7 +594,7 @@
---> % Mercury data types
mercury_type(
prog_data__type, % the exact Mercury type
- builtin_type, % what kind of type it is:
+ type_category, % what kind of type it is:
% enum, float, etc.
exported_type % a representation of the type
% which can be used to
@@ -1741,7 +1741,7 @@
MLDSElemType = mercury_type_to_mlds_type(ModuleInfo, ElemType),
MLDSType = mlds__mercury_array_type(MLDSElemType)
;
- classify_type(Type, ModuleInfo, Category),
+ classify_type(ModuleInfo, Type) = Category,
ExportedType = to_exported_type(ModuleInfo, Type),
MLDSType = mercury_type(Type, Category, ExportedType)
).
Index: compiler/mlds_to_c.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds_to_c.m,v
retrieving revision 1.148
diff -u -b -r1.148 mlds_to_c.m
--- compiler/mlds_to_c.m 26 May 2003 09:00:01 -0000 1.148
+++ compiler/mlds_to_c.m 26 May 2003 10:34:29 -0000
@@ -1080,8 +1080,9 @@
Kind \= mlds__enum,
ClassType = Type
;
- Type = mercury_type(MercuryType, user_type, _),
- type_to_ctor_and_args(MercuryType, TypeCtor, _ArgsTypes),
+ Type = mercury_type(MercuryType, user_ctor_type, _),
+ type_to_ctor_and_args(MercuryType, TypeCtor,
+ _ArgsTypes),
ml_gen_type_name(TypeCtor, ClassName, ClassArity),
ClassType = mlds__class_type(ClassName, ClassArity,
mlds__class)
@@ -1793,7 +1794,7 @@
( { HighLevelData = yes } ->
mlds_output_mercury_user_type_name(
qualified(unqualified("array"), "array") - 1,
- user_type)
+ user_ctor_type)
;
% for the --no-high-level-data case,
% we just treat everything as `MR_Word'
@@ -1877,7 +1878,7 @@
mlds_output_type_prefix(mlds__unknown_type) -->
{ error("mlds_to_c.m: prefix has unknown type") }.
-:- pred mlds_output_mercury_type_prefix(mercury_type, builtin_type,
+:- pred mlds_output_mercury_type_prefix(mercury_type, type_category,
io__state, io__state).
:- mode mlds_output_mercury_type_prefix(in, in, di, uo) is det.
@@ -1895,13 +1896,36 @@
{ TypeCategory = float_type },
io__write_string("MR_Float")
;
- { TypeCategory = polymorphic_type },
+ { TypeCategory = void_type },
+ io__write_string("MR_Word")
+ ;
+ { TypeCategory = variable_type },
io__write_string("MR_Box")
;
+ { TypeCategory = type_info_type },
+ % runtime/mercury_hlc_types requires typeclass_infos
+ % to be treated as user defined types.
+ mlds_output_mercury_user_type_prefix(Type, user_ctor_type)
+ ;
+ { TypeCategory = type_ctor_info_type },
+ % runtime/mercury_hlc_types requires typeclass_infos
+ % to be treated as user defined types.
+ mlds_output_mercury_user_type_prefix(Type, user_ctor_type)
+ ;
+ { TypeCategory = typeclass_info_type },
+ % runtime/mercury_hlc_types requires typeclass_infos
+ % to be treated as user defined types.
+ mlds_output_mercury_user_type_prefix(Type, user_ctor_type)
+ ;
+ { TypeCategory = base_typeclass_info_type },
+ % runtime/mercury_hlc_types requires typeclass_infos
+ % to be treated as user defined types.
+ mlds_output_mercury_user_type_prefix(Type, user_ctor_type)
+ ;
{ TypeCategory = tuple_type },
io__write_string("MR_Tuple")
;
- { TypeCategory = pred_type },
+ { TypeCategory = higher_order_type },
globals__io_lookup_bool_option(highlevel_data, HighLevelData),
( { HighLevelData = yes } ->
io__write_string("MR_ClosurePtr")
@@ -1912,11 +1936,11 @@
{ TypeCategory = enum_type },
mlds_output_mercury_user_type_prefix(Type, TypeCategory)
;
- { TypeCategory = user_type },
+ { TypeCategory = user_ctor_type },
mlds_output_mercury_user_type_prefix(Type, TypeCategory)
).
-:- pred mlds_output_mercury_user_type_prefix(mercury_type, builtin_type,
+:- pred mlds_output_mercury_user_type_prefix(mercury_type, type_category,
io__state, io__state).
:- mode mlds_output_mercury_user_type_prefix(in, in, di, uo) is det.
@@ -1935,7 +1959,7 @@
io__write_string("MR_Word")
).
-:- pred mlds_output_mercury_user_type_name(type_ctor, builtin_type,
+:- pred mlds_output_mercury_user_type_name(type_ctor, type_category,
io__state, io__state).
:- mode mlds_output_mercury_user_type_name(in, in, di, uo) is det.
@@ -2917,8 +2941,8 @@
:- func type_needs_forwarding_pointer_space(mlds__type) = bool.
type_needs_forwarding_pointer_space(mlds__type_info_type) = yes.
type_needs_forwarding_pointer_space(mlds__pseudo_type_info_type) = yes.
-type_needs_forwarding_pointer_space(mercury_type(Type, _, _)) =
- (if is_introduced_type_info_type(Type) then yes else no).
+type_needs_forwarding_pointer_space(mercury_type(_, TypeCategory, _)) =
+ is_introduced_type_info_type_category(TypeCategory).
type_needs_forwarding_pointer_space(mercury_array_type(_)) = no.
type_needs_forwarding_pointer_space(mlds__cont_type(_)) = no.
type_needs_forwarding_pointer_space(mlds__commit_type) = no.
@@ -2942,7 +2966,6 @@
unexpected(this_file,
"type_needs_forwarding_pointer_space: unknown_type").
-
:- pred mlds_output_init_args(list(mlds__rval), list(mlds__type), mlds__context,
int, mlds__lval, mlds__tag, indent, io__state, io__state).
:- mode mlds_output_init_args(in, in, in, in, in, in, in, di, uo) is det.
@@ -3199,7 +3222,7 @@
mlds_output_boxed_rval(Type, Exprn) -->
(
{ Type = mlds__generic_type
- ; Type = mlds__mercury_type(_, polymorphic_type, _)
+ ; Type = mlds__mercury_type(_, variable_type, _)
}
->
% It already has type MR_Box, so no cast is needed
Index: compiler/mlds_to_gcc.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds_to_gcc.m,v
retrieving revision 1.86
diff -u -b -r1.86 mlds_to_gcc.m
--- compiler/mlds_to_gcc.m 13 May 2003 08:51:48 -0000 1.86
+++ compiler/mlds_to_gcc.m 26 May 2003 10:34:53 -0000
@@ -1838,11 +1838,11 @@
build_type(mlds__unknown_type, _, _, _) -->
{ unexpected(this_file, "build_type: unknown type") }.
-:- pred build_mercury_type(mercury_type, builtin_type, gcc__type,
+:- pred build_mercury_type(mercury_type, type_category, gcc__type,
io__state, io__state).
:- mode build_mercury_type(in, in, out, di, uo) is det.
-build_mercury_type(_Type, TypeCategory, GCC_Type) -->
+build_mercury_type(Type, TypeCategory, GCC_Type) -->
(
{ TypeCategory = char_type },
{ GCC_Type = 'MR_Char' }
@@ -1856,7 +1856,34 @@
{ TypeCategory = float_type },
{ GCC_Type = 'MR_Float' }
;
- { TypeCategory = polymorphic_type },
+ { TypeCategory = void_type },
+ { GCC_Type = 'MR_Word' }
+ ;
+ { TypeCategory = type_info_type },
+ build_mercury_type(Type, user_ctor_type, GCC_Type)
+ ;
+ { TypeCategory = type_ctor_info_type },
+ build_mercury_type(Type, user_ctor_type, GCC_Type)
+ ;
+ { TypeCategory = typeclass_info_type },
+ globals__io_lookup_bool_option(highlevel_data, HighLevelData),
+ ( { HighLevelData = yes } ->
+ { sorry(this_file,
+ "--high-level-data (typeclass_info_type)") }
+ ;
+ { GCC_Type = 'MR_Word' }
+ )
+ ;
+ { TypeCategory = base_typeclass_info_type },
+ globals__io_lookup_bool_option(highlevel_data, HighLevelData),
+ ( { HighLevelData = yes } ->
+ { sorry(this_file,
+ "--high-level-data (base_typeclass_info_type)") }
+ ;
+ { GCC_Type = 'MR_Word' }
+ )
+ ;
+ { TypeCategory = variable_type },
{ GCC_Type = 'MR_Box' }
;
{ TypeCategory = tuple_type },
@@ -1865,7 +1892,7 @@
gcc__build_pointer_type('MR_Box', MR_Tuple),
{ GCC_Type = MR_Tuple }
;
- { TypeCategory = pred_type },
+ { TypeCategory = higher_order_type },
globals__io_lookup_bool_option(highlevel_data, HighLevelData),
( { HighLevelData = yes } ->
{ sorry(this_file, "--high-level-data (pred_type)") }
@@ -1882,7 +1909,7 @@
% XXX for --high-level-data, we should use a real enum type
{ GCC_Type = 'MR_Integer' }
;
- { TypeCategory = user_type },
+ { TypeCategory = user_ctor_type },
globals__io_lookup_bool_option(highlevel_data, HighLevelData),
( { HighLevelData = yes } ->
{ sorry(this_file, "--high-level-data (user_type)") }
@@ -3550,6 +3577,7 @@
:- func 'MR_Word' = gcc__type.
:- func 'MR_bool' = gcc__type.
:- func 'MR_TypeInfo' = gcc__type.
+:- func 'MR_TypeCtorInfo' = gcc__type.
:- func 'MR_PseudoTypeInfo' = gcc__type.
:- func 'MR_Sectag_Locn' = gcc__type.
:- func 'MR_TypeCtorRep' = gcc__type.
@@ -3572,6 +3600,7 @@
'MR_bool' = gcc__integer_type_node. % i.e. typedef int MR_bool
'MR_TypeInfo' = gcc__ptr_type_node.
+'MR_TypeCtorInfo' = gcc__ptr_type_node.
'MR_PseudoTypeInfo' = gcc__ptr_type_node.
% XXX MR_Sectag_Locn and MR_TypeCtorRep are actually enums
Index: compiler/mlds_to_il.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds_to_il.m,v
retrieving revision 1.130
diff -u -b -r1.130 mlds_to_il.m
--- compiler/mlds_to_il.m 9 May 2003 00:45:08 -0000 1.130
+++ compiler/mlds_to_il.m 26 May 2003 10:35:11 -0000
@@ -331,7 +331,6 @@
ILEnvPtrType = choose_il_envptr_type(Globals),
ILDataRep = il_data_rep(HighLevelData, ILEnvPtrType).
-
:- pred has_foreign_code_defined(
map(foreign_language, mlds__foreign_code)::in,
foreign_language::in) is semidet.
@@ -374,7 +373,6 @@
% must precede the references to those types in WrapperClass.
MLDS = MLDS0 ^ defns := list__map(rename_defn, Others) ++ [WrapperClass].
-
:- func wrapper_class(mlds__defns) = mlds__defn.
wrapper_class(Members)
@@ -411,7 +409,8 @@
list__map(rename_defn, Members)))
).
-:- func rename_maybe_statement(maybe(mlds__statement)) = maybe(mlds__statement).
+:- func rename_maybe_statement(maybe(mlds__statement))
+ = maybe(mlds__statement).
rename_maybe_statement(no) = no.
rename_maybe_statement(yes(Stmt)) = yes(rename_statement(Stmt)).
@@ -717,7 +716,6 @@
sym_name_to_list(qualified(Module, Name))
= sym_name_to_list(Module) ++ [Name].
-
:- func decl_flags_to_classattrs(mlds__decl_flags) = list(ilasm__classattr).
decl_flags_to_classattrs(Flags)
@@ -815,7 +813,6 @@
Abstractness = [abstract]
).
-
:- func decl_flags_to_fieldattrs(mlds__decl_flags) = list(ilasm__fieldattr).
decl_flags_to_fieldattrs(Flags)
@@ -846,7 +843,6 @@
Constness = [initonly]
).
-
:- func entity_name_to_ilds_id(mlds__entity_name) = ilds__id.
entity_name_to_ilds_id(export(Name)) = Name.
@@ -1101,7 +1097,7 @@
qualified(unqualified("std_util"), "univ"),
[], UnivMercuryType) },
{ UnivMLDSType = mercury_type(UnivMercuryType,
- user_type, non_foreign_type(UnivMercuryType)) },
+ user_ctor_type, non_foreign_type(UnivMercuryType)) },
{ UnivType = mlds_type_to_ilds_type(DataRep, UnivMLDSType) },
{ RenameNode = (func(N) = list__map(RenameRets, N)) },
@@ -1134,7 +1130,6 @@
void, ConsoleWriteName,
[il_generic_type]) },
-
% A code block to catch any exception at all.
{ CatchAnyException = tree__list([
@@ -1258,7 +1253,8 @@
:- func attribute_to_custom_attribute(il_data_rep, mlds__attribute)
= method_body_decl.
-attribute_to_custom_attribute(DataRep, custom(MLDSType)) = custom(CustomDecl) :-
+attribute_to_custom_attribute(DataRep, custom(MLDSType))
+ = custom(CustomDecl) :-
ClassName = mlds_type_to_ilds_class_name(DataRep, MLDSType),
MethodRef = get_constructor_methoddef(ClassName, []),
CustomDecl = custom_decl(methodref(MethodRef), no, no_initalizer).
@@ -1439,7 +1435,6 @@
data_initializer_to_instrs(init_struct(InitList0), Type,
AllocInstrs, InitInstrs) -->
-
{ InitList = flatten_inits(InitList0) },
data_initializer_to_instrs(init_array(InitList), Type,
AllocInstrs, InitInstrs).
@@ -1522,7 +1517,6 @@
{ rval_to_type(Rval, BoxType) },
{ NewRval = unop(box(BoxType), Rval) }.
-
% Code to flatten nested intializers.
:- func flatten_inits(list(mlds__initializer)) = list(mlds__initializer).
@@ -1538,8 +1532,6 @@
Inits = [I]
).
-
-
%-----------------------------------------------------------------------------%
%
% Convert basic MLDS statements into IL.
@@ -1552,7 +1544,6 @@
statement_to_il(S, Instrs0),
statements_to_il(Statements, Instrs1).
-
:- pred statement_to_il(mlds__statement, instr_tree, il_info, il_info).
:- mode statement_to_il(in, out, in, out) is det.
@@ -1850,8 +1841,6 @@
instr_node(switch(Targets))
]) }.
-
-
:- pred atomic_statement_to_il(mlds__atomic_statement, instr_tree,
il_info, il_info).
:- mode atomic_statement_to_il(in, out, in, out) is det.
@@ -1936,7 +1925,6 @@
atomic_statement_to_il(inline_target_code(lang_C_minus_minus, _), _) -->
{ unexpected(this_file, "lang_C_minus_minus") }.
-
atomic_statement_to_il(trail_op(_), node(Instrs)) -->
{ Instrs = [comment(
"... some trail operation ... (unimplemented)")] }.
@@ -1978,7 +1966,8 @@
Type = mlds__class_type(_, _, mlds__class)
;
DataRep ^ highlevel_data = yes,
- Type = mlds__mercury_type(MercuryType, user_type, _),
+ Type = mlds__mercury_type(MercuryType,
+ user_ctor_type, _),
\+ type_needs_lowlevel_rep(il, MercuryType)
}
->
@@ -2161,7 +2150,6 @@
get_max_stack_attribute([]) = no.
get_max_stack_attribute([X | _Xs]) = yes(X) :- X = max_stack_size(_).
-
:- pred get_all_load_store_lval_instrs(list(lval), instr_tree, instr_tree,
il_info, il_info).
:- mode get_all_load_store_lval_instrs(in, out, out, in, out) is det.
@@ -2202,9 +2190,11 @@
{ LoadMemRefInstrs = tree__list([
LoadArrayRval,
LoadIndexRval]) },
- { StoreLvalInstrs = node([stelem(FieldILType)]) }
+ { StoreLvalInstrs = node(
+ [stelem(FieldILType)]) }
; { FieldNum = named_field(_, _) },
- { unexpected(this_file, "named_field for a type with an array representation.") }
+ { unexpected(this_file,
+ "named_field for a type with an array representation.") }
)
;
{ get_fieldref(DataRep, FieldNum, FieldType, ClassType,
@@ -2391,7 +2381,6 @@
% Convert binary and unary operations to IL
%
-
:- pred unaryop_to_il(mlds__unary_op, mlds__rval, instr_tree, il_info,
il_info) is det.
:- mode unaryop_to_il(in, in, out, in, out) is det.
@@ -2508,10 +2497,20 @@
)
;
( already_boxed(SrcILType) ->
- ( SrcType = mercury_type(_, user_type, _) ->
+ (
+ SrcType = mercury_type(_, TypeCategory, _),
+ % XXX Consider whether this is the right way
+ % to handle type_infos, type_ctor_infos,
+ % typeclass_infos and base_typeclass_infos.
+ ( TypeCategory = user_ctor_type
+ ; is_introduced_type_info_type_category(
+ TypeCategory) = yes
+ )
+ ->
% XXX we should look into a nicer way to
% generate MLDS so we don't need to do this
- % XXX This looks wrong for --high-level-data. -fjh.
+ % XXX This looks wrong for --high-level-data.
+ % -fjh.
Instrs = tree__list([
comment_node(
"loading out of an MR_Word"),
@@ -2630,7 +2629,6 @@
binaryop_to_il(body, _) -->
{ unexpected(this_file, "binop: body") }.
-
binaryop_to_il(array_index(ElemType), instr_node(I)) -->
DataRep =^ il_data_rep,
{ MLDS_Type = ml_gen_array_elem_type(ElemType) },
@@ -2759,7 +2757,6 @@
% XXX This predicate should be narrowed down to the cases that actually
% make sense.
-
% Convert an rval into a function we can call.
:- pred rval_to_function(rval, class_member_name).
:- mode rval_to_function(in, out) is det.
@@ -2884,7 +2881,6 @@
set_rtti_initialization_field(FieldRef, Instrs) -->
{ Instrs = [ldc(int32, i(1)), stsfld(FieldRef)] }.
-
:- pred generate_rtti_initialization_field(ilds__class_name,
fieldref, class_member).
:- mode generate_rtti_initialization_field(in, out, out) is det.
@@ -2896,8 +2892,6 @@
AllocDoneFieldRef = make_fieldref(ilds__type([], bool),
ClassName, AllocDoneFieldName).
-
-
%-----------------------------------------------------------------------------
%
% Conversion of MLDS types to IL types.
@@ -2926,7 +2920,6 @@
Id - Type :-
mangle_entity_name(EntityName, Id).
-
:- func mlds_signature_to_ilds_type_params(il_data_rep, mlds__func_signature)
= list(ilds__type).
mlds_signature_to_ilds_type_params(DataRep, func_signature(Args, _Returns)) =
@@ -2973,13 +2966,12 @@
mlds_type_to_ilds_simple_type(DataRep, MLDSType) = SimpleType :-
ilds__type(_, SimpleType) = mlds_type_to_ilds_type(DataRep, MLDSType).
-
% XXX make sure all the types are converted correctly
mlds_type_to_ilds_type(_, mlds__rtti_type(_RttiName)) = il_object_array_type.
mlds_type_to_ilds_type(DataRep, mlds__mercury_array_type(ElementType)) =
- ( ElementType = mlds__mercury_type(_, polymorphic_type, _) ->
+ ( ElementType = mlds__mercury_type(_, variable_type, _) ->
il_generic_array_type
;
ilds__type([], '[]'(mlds_type_to_ilds_type(DataRep,
@@ -3052,20 +3044,37 @@
mlds_type_to_ilds_type(ILDataRep, mlds__ptr_type(MLDSType)) =
ilds__type([], '&'(mlds_type_to_ilds_type(ILDataRep, MLDSType))).
-mlds_type_to_ilds_type(_, mercury_type(_, int_type, _)) =
- ilds__type([], int32).
-mlds_type_to_ilds_type(_, mercury_type(_, char_type, _)) =
- ilds__type([], char).
-mlds_type_to_ilds_type(_, mercury_type(_, float_type, _)) =
- ilds__type([], float64).
-mlds_type_to_ilds_type(_, mercury_type(_, str_type, _)) = il_string_type.
-mlds_type_to_ilds_type(_, mercury_type(_, pred_type, _)) = il_object_array_type.
-mlds_type_to_ilds_type(_, mercury_type(_, tuple_type, _)) =
- il_object_array_type.
-mlds_type_to_ilds_type(_, mercury_type(_, enum_type, _)) = il_object_array_type.
-mlds_type_to_ilds_type(_, mercury_type(_, polymorphic_type, _)) =
- il_generic_type.
-mlds_type_to_ilds_type(DataRep, mercury_type(MercuryType, user_type, _)) =
+mlds_type_to_ilds_type(ILDataRep, mercury_type(MercuryType, BuiltinType, _)) =
+ mlds_mercury_type_to_ilds_type(ILDataRep, MercuryType, BuiltinType).
+
+mlds_type_to_ilds_type(_, mlds__unknown_type) = _ :-
+ unexpected(this_file, "mlds_type_to_ilds_type: unknown_type").
+
+ % Get the corresponding ILDS type for an MLDS mercury type
+ % (this depends on which representation you happen to be using).
+ % The entry for the void type is a dummy; there shouldn't be values
+ % of type void, so the type is moot.
+:- func mlds_mercury_type_to_ilds_type(il_data_rep, prog_data__type,
+ type_category) = ilds__type.
+
+mlds_mercury_type_to_ilds_type(_, _, int_type) = ilds__type([], int32).
+mlds_mercury_type_to_ilds_type(_, _, char_type) = ilds__type([], char).
+mlds_mercury_type_to_ilds_type(_, _, float_type) = ilds__type([], float64).
+mlds_mercury_type_to_ilds_type(_, _, str_type) = il_string_type.
+mlds_mercury_type_to_ilds_type(_, _, void_type) = ilds__type([], int32).
+mlds_mercury_type_to_ilds_type(_, _, higher_order_type) = il_object_array_type.
+mlds_mercury_type_to_ilds_type(_, _, tuple_type) = il_object_array_type.
+mlds_mercury_type_to_ilds_type(_, _, enum_type) = il_object_array_type.
+mlds_mercury_type_to_ilds_type(_, _, variable_type) = il_generic_type.
+mlds_mercury_type_to_ilds_type(DataRep, MercuryType, type_info_type) =
+ mlds_mercury_type_to_ilds_type(DataRep, MercuryType, user_ctor_type).
+mlds_mercury_type_to_ilds_type(DataRep, MercuryType, type_ctor_info_type) =
+ mlds_mercury_type_to_ilds_type(DataRep, MercuryType, user_ctor_type).
+mlds_mercury_type_to_ilds_type(DataRep, MercuryType, typeclass_info_type) =
+ mlds_mercury_type_to_ilds_type(DataRep, MercuryType, user_ctor_type).
+mlds_mercury_type_to_ilds_type(DataRep, MercuryType, base_typeclass_info_type) =
+ mlds_mercury_type_to_ilds_type(DataRep, MercuryType, user_ctor_type).
+mlds_mercury_type_to_ilds_type(DataRep, MercuryType, user_ctor_type) =
(
DataRep ^ highlevel_data = yes,
\+ type_needs_lowlevel_rep(il, MercuryType)
@@ -3074,8 +3083,6 @@
;
il_object_array_type
).
-mlds_type_to_ilds_type(_, mlds__unknown_type) = _ :-
- unexpected(this_file, "mlds_type_to_ilds_type: unknown_type").
:- func mlds_class_to_ilds_simple_type(mlds__class_kind, ilds__class_name) =
ilds__simple_type.
@@ -3127,7 +3134,6 @@
%
% Name mangling.
-
% XXX We may need to do different name mangling for CLS compliance
% than we would otherwise need.
%
@@ -3240,7 +3246,6 @@
Id = UnMangledId.
% Id = name_mangle(UnMangledId).
-
% If an mlds__var is not an argument or a local, what is it?
% We assume the given variable is a static field;
% either a compiler-generated static,
@@ -3388,8 +3393,6 @@
ModuleName = ModuleName0
).
-
-
:- pred mangle_dataname(mlds__data_name, string).
:- mode mangle_dataname(in, out) is det.
@@ -3436,7 +3439,6 @@
string__format("%s_%d", [s(Name), i(Num)]).
mangle_mlds_var_name(mlds__var_name(Name, no)) = Name.
-
:- pred mlds_to_il__sym_name_to_string(sym_name, string).
:- mode mlds_to_il__sym_name_to_string(in, out) is det.
mlds_to_il__sym_name_to_string(SymName, String) :-
@@ -3497,7 +3499,6 @@
)
).
-
:- pred sym_name_to_class_name(sym_name, list(ilds__id)).
:- mode sym_name_to_class_name(in, out) is det.
sym_name_to_class_name(SymName, Ids) :-
@@ -3510,14 +3511,11 @@
sym_name_to_class_name_2(ModuleSpec, Modules).
sym_name_to_class_name_2(unqualified(Name), [Name]).
-
-
%-----------------------------------------------------------------------------%
%
% Predicates for checking various attributes of variables.
%
-
:- pred is_argument(ilds__id, il_info).
:- mode is_argument(in, in) is semidet.
is_argument(VarName, Info) :-
@@ -3631,7 +3629,6 @@
MethodRef = methoddef(call_conv(no, default), ReturnParam,
MemberName, TypeParams).
-
% Assumed to be a field of a class
:- pred data_addr_constant_to_fieldref(mlds__data_addr, fieldref).
:- mode data_addr_constant_to_fieldref(in, out) is det.
@@ -3642,7 +3639,6 @@
ClassName = mlds_module_name_to_class_name(NewModuleName),
FieldRef = make_fieldref(il_object_array_type, ClassName, FieldName).
-
%-----------------------------------------------------------------------------%
% when we generate mercury terms using classes, we should use
@@ -4170,7 +4166,8 @@
newobj_constructor(CtorMemberName, ArgTypes) =
newobj(get_constructor_methoddef(CtorMemberName, ArgTypes)).
-:- func get_constructor_methoddef(ilds__class_name, list(ilds__type)) = methodref.
+:- func get_constructor_methoddef(ilds__class_name, list(ilds__type))
+ = methodref.
get_constructor_methoddef(CtorMemberName, ArgTypes) =
get_instance_methodref(CtorMemberName, ctor, void, ArgTypes).
@@ -4195,8 +4192,6 @@
make_fieldref(ILType, ClassName, Id) =
fieldref(ILType, class_member_name(ClassName, id(Id))).
-
-
:- func runtime_initialization_instrs = list(instr).
runtime_initialization_instrs = [
call(get_static_methodref(runtime_init_module_name,
@@ -4206,7 +4201,8 @@
:- func runtime_init_module_name = ilds__class_name.
runtime_init_module_name =
structured_name(assembly("mercury"),
- ["mercury", "private_builtin__cpp_code", wrapper_class_name], []).
+ ["mercury", "private_builtin__cpp_code", wrapper_class_name],
+ []).
:- func runtime_init_method_name = ilds__member_name.
runtime_init_method_name = id("init_runtime").
@@ -4251,7 +4247,6 @@
il_info, il_info).
:- mode il_info_new_method(in, in, in, in, out) is det.
-
il_info_new_method(ILArgs, ILSignature, MethodName) -->
=(Info),
( yes(SomeLang) =^ method_foreign_lang ->
@@ -4271,7 +4266,6 @@
^ method_name := MethodName,
^ signature := ILSignature.
-
:- pred il_info_set_arguments(assoc_list(ilds__id, mlds__type),
il_info, il_info).
:- mode il_info_set_arguments(in, in, out) is det.
@@ -4409,7 +4403,6 @@
term__context_file(ProgContext, FileName),
term__context_line(ProgContext, LineNumber).
-
% Use this to make instructions into trees easily.
:- func instr_node(instr) = instr_tree.
instr_node(I) = node([I]).
Index: compiler/mlds_to_java.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds_to_java.m,v
retrieving revision 1.41
diff -u -b -r1.41 mlds_to_java.m
--- compiler/mlds_to_java.m 14 May 2003 18:49:50 -0000 1.41
+++ compiler/mlds_to_java.m 26 May 2003 08:20:28 -0000
@@ -169,11 +169,25 @@
:- mode type_is_object(in) is semidet.
type_is_object(Type) :-
- Type = mercury_type(_, Builtin, _),
- ( Builtin = enum_type
- ; Builtin = polymorphic_type
- ; Builtin = user_type
- ).
+ Type = mercury_type(_, TypeCategory, _),
+ type_category_is_object(TypeCategory) = yes.
+
+:- func type_category_is_object(type_category) = bool.
+
+type_category_is_object(int_type) = no.
+type_category_is_object(char_type) = no.
+type_category_is_object(str_type) = no.
+type_category_is_object(float_type) = no.
+type_category_is_object(higher_order_type) = no.
+type_category_is_object(tuple_type) = no.
+type_category_is_object(enum_type) = yes.
+type_category_is_object(variable_type) = yes.
+type_category_is_object(type_info_type) = yes.
+type_category_is_object(type_ctor_info_type) = yes.
+type_category_is_object(typeclass_info_type) = yes.
+type_category_is_object(base_typeclass_info_type) = yes.
+type_category_is_object(void_type) = no.
+type_category_is_object(user_ctor_type) = yes.
% Given an lval, return its type.
%
@@ -1342,11 +1356,17 @@
get_java_type_initializer(mercury_type(_, char_type, _)) = "0".
get_java_type_initializer(mercury_type(_, float_type, _)) = "0".
get_java_type_initializer(mercury_type(_, str_type, _)) = "null".
-get_java_type_initializer(mercury_type(_, pred_type, _)) = "null".
+get_java_type_initializer(mercury_type(_, void_type, _)) = "0".
+get_java_type_initializer(mercury_type(_, type_info_type, _)) = "null".
+get_java_type_initializer(mercury_type(_, type_ctor_info_type, _)) = "null".
+get_java_type_initializer(mercury_type(_, typeclass_info_type, _)) = "null".
+get_java_type_initializer(mercury_type(_, base_typeclass_info_type, _))
+ = "null".
+get_java_type_initializer(mercury_type(_, higher_order_type, _)) = "null".
get_java_type_initializer(mercury_type(_, tuple_type, _)) = "null".
get_java_type_initializer(mercury_type(_, enum_type, _)) = "null".
-get_java_type_initializer(mercury_type(_, polymorphic_type, _)) = "null".
-get_java_type_initializer(mercury_type(_, user_type, _)) = "null".
+get_java_type_initializer(mercury_type(_, variable_type, _)) = "null".
+get_java_type_initializer(mercury_type(_, user_ctor_type, _)) = "null".
get_java_type_initializer(mlds__mercury_array_type(_)) = "null".
get_java_type_initializer(mlds__cont_type(_)) = "null".
get_java_type_initializer(mlds__commit_type) = "null".
@@ -1714,7 +1734,7 @@
).
output_type(mercury_array_type(ElementType)) -->
- ( { ElementType = mlds__mercury_type(_, polymorphic_type, _) } ->
+ ( { ElementType = mlds__mercury_type(_, variable_type, _) } ->
% We can't use `java.lang.Object []', since we want
% a generic type that is capable of holding any kind
% of array, including e.g. `int []'.
@@ -1782,7 +1802,7 @@
output_type(mlds__unknown_type) -->
{ unexpected(this_file, "output_type: unknown type") }.
-:- pred output_mercury_type(mercury_type, builtin_type,
+:- pred output_mercury_type(mercury_type, type_category,
io__state, io__state).
:- mode output_mercury_type(in, in, di, uo) is det.
@@ -1800,23 +1820,39 @@
{ TypeCategory = float_type },
io__write_string("double")
;
- { TypeCategory = polymorphic_type },
+ { TypeCategory = void_type },
+ % Shouldn't matter what we put here.
+ io__write_string("int")
+ ;
+ { TypeCategory = type_info_type },
+ output_mercury_user_type(Type, user_ctor_type)
+ ;
+ { TypeCategory = type_ctor_info_type },
+ output_mercury_user_type(Type, user_ctor_type)
+ ;
+ { TypeCategory = typeclass_info_type },
+ output_mercury_user_type(Type, user_ctor_type)
+ ;
+ { TypeCategory = base_typeclass_info_type },
+ output_mercury_user_type(Type, user_ctor_type)
+ ;
+ { TypeCategory = variable_type },
io__write_string("java.lang.Object")
;
{ TypeCategory = tuple_type },
io__write_string("java.lang.Object")
;
- { TypeCategory = pred_type },
+ { TypeCategory = higher_order_type },
io__write_string("java.lang.Object[]")
;
{ TypeCategory = enum_type },
output_mercury_user_type(Type, TypeCategory)
;
- { TypeCategory = user_type },
+ { TypeCategory = user_ctor_type },
output_mercury_user_type(Type, TypeCategory)
).
-:- pred output_mercury_user_type(mercury_type, builtin_type,
+:- pred output_mercury_user_type(mercury_type, type_category,
io__state, io__state).
:- mode output_mercury_user_type(in, in, di, uo) is det.
@@ -2607,7 +2643,7 @@
),
(
{ Type = mlds__array_type(_Type)
- ; Type = mlds__mercury_type(_Type, pred_type, _)
+ ; Type = mlds__mercury_type(_Type, higher_order_type, _)
}
->
%
Index: compiler/modecheck_unify.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/modecheck_unify.m,v
retrieving revision 1.57
diff -u -b -r1.57 modecheck_unify.m
--- compiler/modecheck_unify.m 13 May 2003 23:56:17 -0000 1.57
+++ compiler/modecheck_unify.m 15 May 2003 02:31:39 -0000
@@ -601,7 +601,7 @@
% them with `fail'.
%
(
- Unification = construct(_, _, _, _, _, _, _),
+ Unification = construct(_, _, _, _, _, _, _, _),
LiveX = dead
->
Goal = conj([]),
@@ -1037,16 +1037,24 @@
Unification, ModeInfo) :-
% if we are re-doing mode analysis, preserve the existing cons_id
list__length(ArgVars, Arity),
- ( Unification0 = construct(_, ConsId0, _, _, _, _, AditiInfo0) ->
+ (
+ Unification0 = construct(_, ConsId0, _, _, _, _,
+ AditiInfo0, MaybeSize0)
+ ->
AditiInfo = AditiInfo0,
+ MaybeSize = MaybeSize0,
ConsId = ConsId0
- ; Unification0 = deconstruct(_, ConsId1, _, _, _, _) ->
+ ;
+ Unification0 = deconstruct(_, ConsId1, _, _, _, _)
+ ->
AditiInfo = no,
+ MaybeSize = no,
ConsId = ConsId1
;
% the real cons_id will be computed by lambda.m;
% we just put in a dummy one for now
AditiInfo = no,
+ MaybeSize = no,
ConsId = cons(unqualified("__LambdaGoal__"), Arity)
),
mode_info_get_module_info(ModeInfo0, ModuleInfo),
@@ -1093,7 +1101,8 @@
RHS = RHS0
),
Unification = construct(X, ConsId, ArgVars, ArgModes,
- construct_dynamically, cell_is_unique, AditiInfo),
+ construct_dynamically, cell_is_unique, AditiInfo,
+ MaybeSize),
ModeInfo = ModeInfo0
;
instmap__is_reachable(InstMap)
@@ -1135,11 +1144,14 @@
mode_info_get_module_info(ModeInfo0, ModuleInfo),
map__lookup(VarTypes, X, TypeOfX),
% if we are re-doing mode analysis, preserve the existing cons_id
- ( Unification0 = construct(_, ConsId0, _, _, _, _, _) ->
+ ( Unification0 = construct(_, ConsId0, _, _, _, _, _, MaybeSize0) ->
+ MaybeSize = MaybeSize0,
ConsId = ConsId0
; Unification0 = deconstruct(_, ConsId1, _, _, _, _) ->
+ MaybeSize = no,
ConsId = ConsId1
;
+ MaybeSize = no,
ConsId = NewConsId
),
mode_util__modes_to_uni_modes(ModeOfXArgs, ArgModes0,
@@ -1150,7 +1162,8 @@
% It's a construction.
RLExprnId = no,
Unification = construct(X, ConsId, ArgVars, ArgModes,
- construct_dynamically, cell_is_unique, RLExprnId),
+ construct_dynamically, cell_is_unique, RLExprnId,
+ MaybeSize),
% For existentially quantified data types,
% check that any type_info or type_class_info variables in the
Index: compiler/modules.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/modules.m,v
retrieving revision 1.273
diff -u -b -r1.273 modules.m
--- compiler/modules.m 26 May 2003 10:23:57 -0000 1.273
+++ compiler/modules.m 26 May 2003 13:03:43 -0000
@@ -831,6 +831,7 @@
mercury_std_library_module("table_builtin").
mercury_std_library_module("term").
mercury_std_library_module("term_io").
+mercury_std_library_module("term_size_prof_builtin").
mercury_std_library_module("time").
mercury_std_library_module("tree234").
mercury_std_library_module("type_desc").
@@ -1798,8 +1799,8 @@
% list of imported modules
globals__io_get_globals(Globals),
{ add_implicit_imports(Items1, Globals,
- IntImportedModules1, IntUsedModules1,
- IntImportedModules2, IntUsedModules2) },
+ IntImportedModules1, IntImportedModules2,
+ IntUsedModules1, IntUsedModules2) },
% We add a pseudo-declaration `:- imported(ancestor)' at the
% end of the item list. Uses of the items with declarations
@@ -1882,8 +1883,8 @@
% Add `builtin' and `private_builtin' to the imported modules.
globals__io_get_globals(Globals),
- { add_implicit_imports(Items0, Globals, IntImportDeps0, IntUseDeps0,
- IntImportDeps1, IntUseDeps1) },
+ { add_implicit_imports(Items0, Globals,
+ IntImportDeps0, IntImportDeps1, IntUseDeps0, IntUseDeps1) },
%
% Get the .int3s and .int0s that the current module depends on.
@@ -1994,22 +1995,21 @@
%-----------------------------------------------------------------------------%
get_implicit_dependencies(Items, Globals, ImportDeps, UseDeps) :-
- add_implicit_imports(Items, Globals, [], [], ImportDeps, UseDeps).
+ add_implicit_imports(Items, Globals, [], ImportDeps, [], UseDeps).
-:- pred add_implicit_imports(item_list, globals,
- list(module_name), list(module_name),
- list(module_name), list(module_name)).
-:- mode add_implicit_imports(in, in, in, in, out, out) is det.
+:- pred add_implicit_imports(item_list::in, globals::in,
+ list(module_name)::in, list(module_name)::out,
+ list(module_name)::in, list(module_name)::out) is det.
-add_implicit_imports(Items, Globals, ImportDeps0, UseDeps0,
- ImportDeps, UseDeps) :-
+add_implicit_imports(Items, Globals, !ImportDeps, !UseDeps) :-
mercury_public_builtin_module(MercuryPublicBuiltin),
mercury_private_builtin_module(MercuryPrivateBuiltin),
mercury_table_builtin_module(MercuryTableBuiltin),
mercury_profiling_builtin_module(MercuryProfilingBuiltin),
+ mercury_term_size_prof_builtin_module(MercuryTermSizeProfBuiltin),
aditi_private_builtin_module(AditiPrivateBuiltin),
- ImportDeps = [MercuryPublicBuiltin | ImportDeps0],
- UseDeps1 = [MercuryPrivateBuiltin | UseDeps0],
+ !:ImportDeps = [MercuryPublicBuiltin | !.ImportDeps],
+ !:UseDeps = [MercuryPrivateBuiltin | !.UseDeps],
(
%
% We should include MercuryTableBuiltin if the Items contain
@@ -2021,19 +2021,32 @@
; globals__lookup_bool_option(Globals, trace_table_io, yes)
)
->
- UseDeps2 = [MercuryTableBuiltin | UseDeps1]
+ !:UseDeps = [MercuryTableBuiltin | !.UseDeps]
;
- UseDeps2 = UseDeps1
+ true
),
( globals__lookup_bool_option(Globals, profile_deep, yes) ->
- UseDeps3 = [MercuryProfilingBuiltin | UseDeps2]
+ !:UseDeps = [MercuryProfilingBuiltin | !.UseDeps]
+ ;
+ true
+ ),
+ (
+ (
+ globals__lookup_bool_option(Globals,
+ record_term_sizes_as_words, yes)
+ ;
+ globals__lookup_bool_option(Globals,
+ record_term_sizes_as_cells, yes)
+ )
+ ->
+ !:UseDeps = [MercuryTermSizeProfBuiltin | !.UseDeps]
;
- UseDeps3 = UseDeps2
+ true
),
( globals__lookup_bool_option(Globals, aditi, yes) ->
- UseDeps = [AditiPrivateBuiltin | UseDeps3]
+ !:UseDeps = [AditiPrivateBuiltin | !.UseDeps]
;
- UseDeps = UseDeps3
+ true
).
:- pred contains_tabling_pragma(item_list::in) is semidet.
@@ -5225,16 +5238,16 @@
ParentDeps = get_ancestors(ModuleName),
get_dependencies(Items, ImplImportDeps0, ImplUseDeps0),
- add_implicit_imports(Items, Globals, ImplImportDeps0, ImplUseDeps0,
- ImplImportDeps, ImplUseDeps),
+ add_implicit_imports(Items, Globals, ImplImportDeps0, ImplImportDeps,
+ ImplUseDeps0, ImplUseDeps),
list__append(ImplImportDeps, ImplUseDeps, ImplementationDeps),
get_interface(Items, InterfaceItems),
get_dependencies(InterfaceItems, InterfaceImportDeps0,
InterfaceUseDeps0),
add_implicit_imports(InterfaceItems, Globals,
- InterfaceImportDeps0, InterfaceUseDeps0,
- InterfaceImportDeps, InterfaceUseDeps),
+ InterfaceImportDeps0, InterfaceImportDeps,
+ InterfaceUseDeps0, InterfaceUseDeps),
list__append(InterfaceImportDeps, InterfaceUseDeps,
InterfaceDeps),
Index: compiler/opt_debug.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/opt_debug.m,v
retrieving revision 1.132
diff -u -b -r1.132 opt_debug.m
--- compiler/opt_debug.m 26 May 2003 09:00:03 -0000 1.132
+++ compiler/opt_debug.m 26 May 2003 09:12:11 -0000
@@ -317,10 +317,19 @@
opt_debug__dump_const(code_addr_const(CodeAddr), Str) :-
opt_debug__dump_code_addr(CodeAddr, C_str),
string__append_list(["code_addr_const(", C_str, ")"], Str).
-opt_debug__dump_const(data_addr_const(DataAddr), Str) :-
+opt_debug__dump_const(data_addr_const(DataAddr, MaybeOffset), Str) :-
opt_debug__dump_data_addr(DataAddr, DataAddr_str),
+ (
+ MaybeOffset = no,
+ string__append_list(
+ ["data_addr_const(", DataAddr_str, ")"], Str)
+ ;
+ MaybeOffset = yes(Offset),
+ string__int_to_string(Offset, Offset_str),
string__append_list(
- ["data_addr_const(", DataAddr_str, ")"], Str).
+ ["data_addr_const(", DataAddr_str, ", ",
+ Offset_str, ")"], Str)
+ ).
opt_debug__dump_const(label_entry(Label), Str) :-
opt_debug__dump_label(Label, LabelStr),
string__append_list(["label_entry(", LabelStr, ")"], Str).
@@ -673,7 +682,7 @@
opt_debug__dump_rval(Rval, R_str),
opt_debug__dump_code_addr(CodeAddr, C_str),
string__append_list(["if_val(", R_str, ", ", C_str, ")"], Str).
-opt_debug__dump_instr(incr_hp(Lval, MaybeTag, Size, _), Str) :-
+opt_debug__dump_instr(incr_hp(Lval, MaybeTag, MaybeOffset, Size, _), Str) :-
opt_debug__dump_lval(Lval, L_str),
(
MaybeTag = no,
@@ -682,9 +691,16 @@
MaybeTag = yes(Tag),
string__int_to_string(Tag, T_str)
),
+ (
+ MaybeOffset = no,
+ O_str = "no"
+ ;
+ MaybeOffset = yes(Offset),
+ string__int_to_string(Offset, O_str)
+ ),
opt_debug__dump_rval(Size, S_str),
- string__append_list(["incr_hp(", L_str, ", ", T_str, ", ", S_str, ")"],
- Str).
+ string__append_list(["incr_hp(", L_str, ", ", T_str, ", ", O_str,
+ ", ", S_str, ")"], Str).
opt_debug__dump_instr(mark_hp(Lval), Str) :-
opt_debug__dump_lval(Lval, L_str),
string__append_list(["mark_hp(", L_str, ")"], Str).
Index: compiler/opt_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/opt_util.m,v
retrieving revision 1.121
diff -u -b -r1.121 opt_util.m
--- compiler/opt_util.m 26 May 2003 09:00:03 -0000 1.121
+++ compiler/opt_util.m 26 May 2003 09:24:29 -0000
@@ -752,7 +752,7 @@
Between = [Instr0 | Between0]
)
;
- Uinstr0 = incr_hp(Lval, _, Rval, _),
+ Uinstr0 = incr_hp(Lval, _, _, Rval, _),
opt_util__lval_refers_stackvars(Lval, no),
opt_util__rval_refers_stackvars(Rval, no),
opt_util__no_stackvars_til_decr_sp(Instrs0, FrameSize,
@@ -817,7 +817,7 @@
Need = no
)
;
- Uinstr0 = incr_hp(Lval, _, Rval, _),
+ Uinstr0 = incr_hp(Lval, _, _, Rval, _),
opt_util__lval_refers_stackvars(Lval, Use1),
opt_util__rval_refers_stackvars(Rval, Use2),
bool__or(Use1, Use2, Use),
@@ -996,7 +996,7 @@
opt_util__can_instr_branch_away(computed_goto(_, _), yes).
opt_util__can_instr_branch_away(c_code(_, _), no).
opt_util__can_instr_branch_away(if_val(_, _), yes).
-opt_util__can_instr_branch_away(incr_hp(_, _, _, _), no).
+opt_util__can_instr_branch_away(incr_hp(_, _, _, _, _), no).
opt_util__can_instr_branch_away(mark_hp(_), no).
opt_util__can_instr_branch_away(restore_hp(_), no).
opt_util__can_instr_branch_away(free_heap(_), no).
@@ -1064,7 +1064,7 @@
opt_util__can_instr_fall_through(computed_goto(_, _), no).
opt_util__can_instr_fall_through(c_code(_, _), yes).
opt_util__can_instr_fall_through(if_val(_, _), yes).
-opt_util__can_instr_fall_through(incr_hp(_, _, _, _), yes).
+opt_util__can_instr_fall_through(incr_hp(_, _, _, _, _), yes).
opt_util__can_instr_fall_through(mark_hp(_), yes).
opt_util__can_instr_fall_through(restore_hp(_), yes).
opt_util__can_instr_fall_through(free_heap(_), yes).
@@ -1110,7 +1110,7 @@
opt_util__can_use_livevals(computed_goto(_, _), no).
opt_util__can_use_livevals(c_code(_, _), no).
opt_util__can_use_livevals(if_val(_, _), yes).
-opt_util__can_use_livevals(incr_hp(_, _, _, _), no).
+opt_util__can_use_livevals(incr_hp(_, _, _, _, _), no).
opt_util__can_use_livevals(mark_hp(_), no).
opt_util__can_use_livevals(restore_hp(_), no).
opt_util__can_use_livevals(free_heap(_), no).
@@ -1173,7 +1173,7 @@
opt_util__instr_labels_2(computed_goto(_, Labels), Labels, []).
opt_util__instr_labels_2(c_code(_, _), [], []).
opt_util__instr_labels_2(if_val(_, Addr), [], [Addr]).
-opt_util__instr_labels_2(incr_hp(_, _, _, _), [], []).
+opt_util__instr_labels_2(incr_hp(_, _, _, _, _), [], []).
opt_util__instr_labels_2(mark_hp(_), [], []).
opt_util__instr_labels_2(restore_hp(_), [], []).
opt_util__instr_labels_2(free_heap(_), [], []).
@@ -1221,7 +1221,7 @@
;
Targets = []
).
-opt_util__possible_targets(incr_hp(_, _, _, _), []).
+opt_util__possible_targets(incr_hp(_, _, _, _, _), []).
opt_util__possible_targets(mark_hp(_), []).
opt_util__possible_targets(restore_hp(_), []).
opt_util__possible_targets(free_heap(_), []).
@@ -1286,7 +1286,7 @@
opt_util__instr_rvals_and_lvals(computed_goto(Rval, _), [Rval], []).
opt_util__instr_rvals_and_lvals(c_code(_, _), [], []).
opt_util__instr_rvals_and_lvals(if_val(Rval, _), [Rval], []).
-opt_util__instr_rvals_and_lvals(incr_hp(Lval, _, Rval, _), [Rval], [Lval]).
+opt_util__instr_rvals_and_lvals(incr_hp(Lval, _, _, Rval, _), [Rval], [Lval]).
opt_util__instr_rvals_and_lvals(mark_hp(Lval), [], [Lval]).
opt_util__instr_rvals_and_lvals(restore_hp(Rval), [Rval], []).
opt_util__instr_rvals_and_lvals(free_heap(Rval), [Rval], []).
@@ -1415,7 +1415,7 @@
opt_util__count_temps_instr(if_val(Rval, _), R0, R, F0, F) :-
opt_util__count_temps_rval(Rval, R0, R, F0, F).
opt_util__count_temps_instr(c_code(_, _), R, R, F, F).
-opt_util__count_temps_instr(incr_hp(Lval, _, Rval, _), R0, R, F0, F) :-
+opt_util__count_temps_instr(incr_hp(Lval, _, _, Rval, _), R0, R, F0, F) :-
opt_util__count_temps_lval(Lval, R0, R1, F0, F1),
opt_util__count_temps_rval(Rval, R1, R, F1, F).
opt_util__count_temps_instr(mark_hp(Lval), R0, R, F0, F) :-
@@ -1542,7 +1542,7 @@
opt_util__touches_nondet_ctrl_lval(Lval, TouchLval),
opt_util__touches_nondet_ctrl_rval(Rval, TouchRval),
bool__or(TouchLval, TouchRval, Touch)
- ; Uinstr = incr_hp(Lval, _, Rval, _) ->
+ ; Uinstr = incr_hp(Lval, _, _, Rval, _) ->
opt_util__touches_nondet_ctrl_lval(Lval, TouchLval),
opt_util__touches_nondet_ctrl_rval(Rval, TouchRval),
bool__or(TouchLval, TouchRval, Touch)
@@ -1687,7 +1687,7 @@
opt_util__count_incr_hp_2([], N, N).
opt_util__count_incr_hp_2([Uinstr0 - _ | Instrs], N0, N) :-
- ( Uinstr0 = incr_hp(_, _, _, _) ->
+ ( Uinstr0 = incr_hp(_, _, _, _, _) ->
N1 = N0 + 1
;
N1 = N0
@@ -1803,8 +1803,8 @@
Rval = Rval0
),
opt_util__replace_labels_code_addr(Target0, ReplMap, Target).
-opt_util__replace_labels_instr(incr_hp(Lval0, MaybeTag, Rval0, Msg), ReplMap,
- ReplData, incr_hp(Lval, MaybeTag, Rval, Msg)) :-
+opt_util__replace_labels_instr(incr_hp(Lval0, MaybeTag, MO, Rval0, Msg),
+ ReplMap, ReplData, incr_hp(Lval, MaybeTag, MO, Rval, Msg)) :-
(
ReplData = yes,
opt_util__replace_labels_lval(Lval0, ReplMap, Lval),
@@ -2037,8 +2037,8 @@
opt_util__replace_labels_rval_const(code_addr_const(Addr0), ReplMap,
code_addr_const(Addr)) :-
opt_util__replace_labels_code_addr(Addr0, ReplMap, Addr).
-opt_util__replace_labels_rval_const(data_addr_const(DataAddr), _,
- data_addr_const(DataAddr)).
+opt_util__replace_labels_rval_const(data_addr_const(DataAddr, MaybeOffset), _,
+ data_addr_const(DataAddr, MaybeOffset)).
opt_util__replace_labels_rval_const(label_entry(Label), _, label_entry(Label)).
:- pred opt_util__replace_labels_code_addr(code_addr::in, map(label, label)::in,
Index: compiler/options.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/options.m,v
retrieving revision 1.413
diff -u -b -r1.413 options.m
--- compiler/options.m 26 May 2003 09:00:03 -0000 1.413
+++ compiler/options.m 26 May 2003 09:12:12 -0000
@@ -226,9 +226,11 @@
; use_zeroing_for_ho_cycles
; use_lots_of_ho_specialization
% We should always handle tail recursion
- % specially in deep profiling; the options is
+ % specially in deep profiling; the option is
% only for benchmarks for the paper.
; deep_profile_tail_recursion
+ ; record_term_sizes_as_words
+ ; record_term_sizes_as_cells
% (c) Miscellaneous
; gc
@@ -858,6 +860,8 @@
- bool(no),
deep_profile_tail_recursion
- bool(yes),
+ record_term_sizes_as_words - bool(no),
+ record_term_sizes_as_cells - bool(no),
% (c) Miscellaneous optional features
gc - string("boehm"),
parallel - bool(no),
@@ -1488,6 +1492,8 @@
use_lots_of_ho_specialization).
long_option("deep-profile-tail-recursion",
deep_profile_tail_recursion).
+long_option("record-term-sizes-as-words", record_term_sizes_as_words).
+long_option("record-term-sizes-as-cells", record_term_sizes_as_cells).
% (c) miscellanous optional features
long_option("gc", gc).
long_option("garbage-collection", gc).
@@ -2989,6 +2995,10 @@
"--profile-memory\t\t(grade modifier: `.profmem')",
"\tSimilar to `--memory-profiling', except that it only gathers",
"\tmemory usage information, not call counts.",
+% "--record-term-sizes-as-words\t\t(grade modifier: `.tsw')",
+% "\tAugment each heap cells with its size in words.",
+% "--record-term-sizes-as-cells\t\t(grade modifier: `.tsc')",
+% "\tAugment each heap cells with its size in cells.",
********************/
]),
io__write_string(" Miscellaneous optional features\n"),
Index: compiler/par_conj_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/par_conj_gen.m,v
retrieving revision 1.12
diff -u -b -r1.12 par_conj_gen.m
--- compiler/par_conj_gen.m 26 May 2003 09:00:04 -0000 1.12
+++ compiler/par_conj_gen.m 26 May 2003 09:12:13 -0000
@@ -158,7 +158,7 @@
{ MakeTerm = node([
assign(SpSlot, lval(sp))
- "save the parent stack pointer",
- incr_hp(RegLval, no, const(int_const(STSize)),
+ incr_hp(RegLval, no, no, const(int_const(STSize)),
"synchronization vector")
- "allocate a synchronization vector",
init_sync_term(RegLval, NumGoals)
Index: compiler/pd_cost.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/pd_cost.m,v
retrieving revision 1.16
diff -u -b -r1.16 pd_cost.m
--- compiler/pd_cost.m 26 May 2003 09:00:04 -0000 1.16
+++ compiler/pd_cost.m 26 May 2003 09:12:13 -0000
@@ -120,7 +120,7 @@
pd_cost__unify(_, simple_test(_, _), Cost) :-
pd_cost__simple_test(Cost).
-pd_cost__unify(NonLocals, construct(Var, _, Args, _, _, _, _), Cost) :-
+pd_cost__unify(NonLocals, construct(Var, _, Args, _, _, _, _, _), Cost) :-
( set__member(Var, NonLocals) ->
list__length(Args, Arity),
pd_cost__heap_incr(Cost1),
Index: compiler/pd_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/pd_util.m,v
retrieving revision 1.25
diff -u -b -r1.25 pd_util.m
--- compiler/pd_util.m 26 May 2003 09:00:05 -0000 1.25
+++ compiler/pd_util.m 26 May 2003 09:12:15 -0000
@@ -1063,9 +1063,9 @@
NewArgs = [NewVar1, NewVar2]
;
OldUnification = construct(OldVar, ConsId,
- OldArgs1, _, _, _, _),
+ OldArgs1, _, _, _, _, _),
NewUnification = construct(NewVar, ConsId,
- NewArgs1, _, _, _, _),
+ NewArgs1, _, _, _, _, _),
OldArgs = [OldVar | OldArgs1],
NewArgs = [NewVar | NewArgs1]
;
Index: compiler/polymorphism.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/polymorphism.m,v
retrieving revision 1.236
diff -u -b -r1.236 polymorphism.m
--- compiler/polymorphism.m 26 May 2003 09:00:05 -0000 1.236
+++ compiler/polymorphism.m 26 May 2003 09:12:15 -0000
@@ -166,7 +166,7 @@
:- import_module hlds__special_pred.
:- import_module parse_tree__prog_data.
-:- import_module io, list, term, map.
+:- import_module io, list, term, map, std_util.
% Run the polymorphism pass over the whole HLDS.
@@ -258,10 +258,10 @@
:- mode polymorphism__typeclass_info_class_constraint(in, out) is semidet.
% 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.
+ % the type_info or type_ctor_info carries information, failing if the
+ % type is not a valid type_info or type_ctor_info type.
+:- pred polymorphism__type_info_or_ctor_type((type), (type)).
+:- mode polymorphism__type_info_or_ctor_type(in, out) is semidet.
% Construct the type of the type_info for the given type.
:- pred polymorphism__build_type_info_type((type), (type)).
@@ -295,6 +295,57 @@
:- mode convert_pred_to_lambda_goal(in, in, in, in, in, in, in, in,
in, in, in, in, in, out, out, out) is det.
+ % init_type_info_var(Type, ArgVars, TypeInfoVar, TypeInfoGoal,
+ % VarSet0, VarSet, VarTypes0, VarTypes) :-
+ %
+ % Create the unification the constructs the second cell of a type_info
+ % for Type. ArgVars should contain the arguments of this unification.
+ %
+ % This unification WILL lead to the creation of cells on the heap
+ % at runtime.
+ %
+ % The first variable in ArgVars should be bound to the type_ctor_info
+ % for Type's principal type constructor. If that type constructor is
+ % variable arity, the next variable in ArgVars should be bound to an
+ % integer giving Type's actual arity. The remaining variables in
+ % ArgVars should be bound to the type_infos or type_ctor_infos giving
+ % Type's argument types.
+
+:- pred polymorphism__init_type_info_var((type)::in, list(prog_var)::in,
+ maybe(prog_var)::in, prog_var::out, hlds_goal::out,
+ prog_varset::in, prog_varset::out,
+ map(prog_var, type)::in, map(prog_var, type)::out) is det.
+
+ % init_const_type_ctor_info_var(Type, TypeCtor,
+ % TypeCtorInfoVar, TypeCtorInfoGoal, ModuleInfo,
+ % VarSet0, VarSet, VarTypes0, VarTypes):
+ %
+ % Create the unification (returned as TypeCtorInfoGoal) that binds a
+ % new variable (returned as TypeCtorInfoVar) to the type_ctor_info
+ % representing TypeCtor.
+ %
+ % This unification WILL NOT lead to the creation of a cell on the
+ % heap at runtime; it will cause TypeCtorInfoVar to refer to the
+ % statically allocated type_ctor_info cell for the type, allocated
+ % in the module that defines the type.
+ %
+ % We take Type as input for historical reasons: we record Type as
+ % the type whose type constructor TypeCtor is, in the type of
+ % TypeCtorInfoVar.
+
+:- pred polymorphism__init_const_type_ctor_info_var((type)::in, type_ctor::in,
+ prog_var::out, hlds_goal::out, module_info::in,
+ prog_varset::in, prog_varset::out,
+ map(prog_var, type)::in, map(prog_var, type)::out) is det.
+
+:- type type_info_kind
+ ---> type_info
+ ; type_ctor_info.
+
+:- pred polymorphism__new_type_info_var_raw((type)::in, type_info_kind::in,
+ prog_var::out, prog_varset::in, prog_varset::out,
+ map(prog_var, type)::in, map(prog_var, type)::out) is det.
+
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -323,7 +374,7 @@
:- import_module parse_tree__prog_util.
:- import_module bool, int, string, set, map.
-:- import_module term, varset, std_util, require, assoc_list.
+:- import_module term, varset, require, assoc_list.
%-----------------------------------------------------------------------------%
@@ -1118,7 +1169,6 @@
% these should have been expanded out by now
{ error("polymorphism__process_goal_expr: unexpected shorthand") }.
-
% type_info_vars prepends a comma seperated list of variables
% onto a string of variables.
% It places an & at the start of the variable name if variable
@@ -2383,7 +2433,7 @@
% even though its declaration is polymorphic.
goal_util__generate_simple_call(mercury_private_builtin_module,
- "superclass_from_typeclass_info",
+ "superclass_from_typeclass_info", predicate,
[SubClassVar, IndexVar, Var], only_mode, det, no,
[], ModuleInfo, term__context_init, SuperClassGoal),
@@ -2442,7 +2492,7 @@
% create the construction unification to initialize the variable
RLExprnId = no,
BaseUnification = construct(BaseVar, ConsId, [], [],
- construct_dynamically, cell_is_shared, RLExprnId),
+ construct_dynamically, cell_is_shared, RLExprnId, no),
BaseUnifyMode = (free -> ground(shared, none)) -
(ground(shared, none) -> ground(shared, none)),
BaseUnifyContext = unify_context(explicit, []),
@@ -2475,8 +2525,8 @@
ground(shared, none) - ground(shared, none)),
list__length(NewArgVars, NumArgVars),
list__duplicate(NumArgVars, UniMode, UniModes),
- Unification = construct(NewVar, NewConsId, NewArgVars,
- UniModes, construct_dynamically, cell_is_unique, RLExprnId),
+ Unification = construct(NewVar, NewConsId, NewArgVars, UniModes,
+ construct_dynamically, cell_is_unique, RLExprnId, no),
UnifyMode = (free -> ground(shared, none)) -
(ground(shared, none) -> ground(shared, none)),
UnifyContext = unify_context(explicit, []),
@@ -2642,40 +2692,24 @@
% First handle statically known types
% (i.e. types which are not type variables)
%
- (
- (
- % XXX FIXME (RTTI for higher-order impure code)
- % we should not ignore Purity here;
- % it should get included in the RTTI.
- type_is_higher_order(Type, _Purity, PredOrFunc, _,
- TypeArgs0)
- ->
- TypeArgs = TypeArgs0,
- hlds_out__pred_or_func_to_str(PredOrFunc,
- PredOrFuncStr),
- TypeCtor = unqualified(PredOrFuncStr) - 0
- ; type_is_tuple(Type, TypeArgs1) ->
- TypeArgs = TypeArgs1,
- TypeCtor = unqualified("tuple") - 0
- ;
- fail
- )
- ->
+ ( type_has_variable_arity_ctor(Type, TypeCtor, TypeArgs) ->
% This occurs for code where a predicate calls a polymorphic
- % predicate with a known higher-order or tuple value of the
- % type variable.
+ % predicate with a type whose type constructor is of variable
+ % arity.
% The transformation we perform is basically the same as
- % in the first-order case below, except that we map
+ % in the usual case below, except that we map
% pred types to pred/0, func types to func/0 and tuple
% types to tuple/0 for the purposes of creating type_infos.
% To allow univ_to_type to check the type_infos
- % correctly, the actual arity of the pred is added to
- % the type_info of higher-order types.
+ % correctly, the actual arity is added to the type_info
+ % we create.
+ %
+ % XXX FIXME (RTTI for higher-order impure code)
+ % we should not ignore the purity of higher order procs;
+ % it should get included in the RTTI.
polymorphism__construct_type_info(Type, TypeCtor, TypeArgs,
yes, Context, Var, ExtraGoals, Info0, Info)
- ;
- type_to_ctor_and_args(Type, TypeCtor, TypeArgs)
- ->
+ ; type_to_ctor_and_args(Type, TypeCtor, TypeArgs) ->
% This occurs for code where a predicate calls a polymorphic
% predicate with a known value of the type variable.
% The transformation we perform is shown in the comment
@@ -2726,8 +2760,8 @@
% the typeclass_info is created.
%
type_util__var(Type, TypeVar),
- polymorphism__new_type_info_var(Type, "type_info",
- typeinfo_prefix, Var, Info0, Info1),
+ polymorphism__new_type_info_var(Type, type_info,
+ Var, Info0, Info1),
TypeInfoLocn = type_info(Var),
map__det_insert(TypeInfoMap0, TypeVar, TypeInfoLocn,
TypeInfoMap),
@@ -2741,7 +2775,7 @@
in, out) is det.
polymorphism__construct_type_info(Type, TypeCtor, TypeArgs,
- IsHigherOrderOrTuple, Context, Var, ExtraGoals, Info0, Info) :-
+ TypeCtorIsVarArity, Context, Var, ExtraGoals, Info0, Info) :-
% Create the typeinfo vars for the arguments
polymorphism__make_type_info_vars(TypeArgs, Context,
@@ -2751,75 +2785,114 @@
poly_info_get_var_types(Info1, VarTypes1),
poly_info_get_module_info(Info1, ModuleInfo),
- polymorphism__init_const_type_ctor_info_var(Type,
- TypeCtor, ModuleInfo, VarSet1, VarTypes1,
- BaseVar, BaseGoal, VarSet2, VarTypes2),
- polymorphism__maybe_init_second_cell(ArgTypeInfoVars,
- ArgTypeInfoGoals, Type, IsHigherOrderOrTuple,
- BaseVar, VarSet2, VarTypes2, [BaseGoal],
- Var, VarSet, VarTypes, ExtraGoals),
+ polymorphism__init_const_type_ctor_info_var(Type, TypeCtor,
+ TypeCtorVar, TypeCtorGoal, ModuleInfo,
+ VarSet1, VarSet2, VarTypes1, VarTypes2),
+ polymorphism__maybe_init_second_cell(Type, TypeCtorVar,
+ TypeCtorIsVarArity, ArgTypeInfoVars, Context, Var,
+ VarSet2, VarSet, VarTypes2, VarTypes,
+ ArgTypeInfoGoals, [TypeCtorGoal], ExtraGoals),
poly_info_set_varset_and_types(VarSet, VarTypes, Info1, Info).
- % Create a unification for the two-cell type_info
- % variable for this type if the type arity is not zero:
- % TypeInfoVar = type_info(BaseVar,
- % ArgTypeInfoVars...).
- % For closures, we add the actual arity before the
- % arguments, because all closures have a BaseVar
- % of "pred/0".
- % TypeInfoVar = type_info(BaseVar, Arity,
- % ArgTypeInfoVars...).
-
-:- pred polymorphism__maybe_init_second_cell(list(prog_var), list(hlds_goal),
- type, bool, prog_var, prog_varset, map(prog_var, type), list(hlds_goal),
- prog_var, prog_varset, map(prog_var, type), list(hlds_goal)).
-:- mode polymorphism__maybe_init_second_cell(in, in, in, in, in, in, in, in,
- out, out, out, out) is det.
-
-polymorphism__maybe_init_second_cell(ArgTypeInfoVars, ArgTypeInfoGoals, Type,
- IsHigherOrderOrTuple, BaseVar, VarSet0, VarTypes0, ExtraGoals0,
- Var, VarSet, VarTypes, ExtraGoals) :-
- % Unfortunately, if we have higher order terms, we
- % can no longer just optimise them to be the actual
- % type_ctor_info
- ( IsHigherOrderOrTuple = yes ->
- list__length(ArgTypeInfoVars, PredArity),
- make_int_const_construction(PredArity, yes("PredArity"),
- ArityGoal, ArityVar, VarTypes0, VarTypes1,
- VarSet0, VarSet1),
+ % maybe_init_second_cell(Type, TypeCtorVar, TypeCtorIsVarArity,
+ % ArgTypeInfoVars, Context, Var, VarSet0, VarSet,
+ % VarTypes0, VarTypes, ArgTypeInfoGoals, ExtraGoals0, ExtraGoals):
+ %
+ % Create a unification the constructs the second cell of a type_info
+ % for Type if necessary. This cell will usually be of the form:
+ %
+ % TypeInfoVar = type_info(TypeCtorVar, ArgTypeInfoVars...)
+ %
+ % However, if TypeCtorIsVarArity is true, then it will be of the form
+ %
+ % TypeInfoVar = type_info(TypeCtorVar, Arity, ArgTypeInfoVars...)
+ %
+ % TypeCtorVar should be the variable holding the type_ctor_info for the
+ % principal type constructor of Type, and TypeCtorIsVarArity should be
+ % true iff the type constructor it represents has a variable arity.
+ %
+ % ArgTypeInfoVars should be variables holding the type_infos (or
+ % type_ctor_infos for zero-arity types) of the argument types of Type.
+ %
+ % The returned Var will be bound to the type_info cell of Type if such
+ % a cell had to be allocated, and to the type_ctor_info of Type's only
+ % type constructor if it didn't. The returned ExtraGoals is a
+ % concatenation of ArgTypeInfoGoals, ExtraGoals0, and any goals needed
+ % to construct Var.
+
+:- pred polymorphism__maybe_init_second_cell((type)::in, prog_var::in,
+ bool::in, list(prog_var)::in, prog_context::in, prog_var::out,
+ prog_varset::in, prog_varset::out,
+ map(prog_var, type)::in, map(prog_var, type)::out,
+ list(hlds_goal)::in, list(hlds_goal)::in, list(hlds_goal)::out) is det.
+
+polymorphism__maybe_init_second_cell(Type, TypeCtorVar, TypeCtorIsVarArity,
+ ArgTypeInfoVars, _Context, Var, !VarSet, !VarTypes,
+ ArgTypeInfoGoals, ExtraGoals0, ExtraGoals) :-
+ (
+ TypeCtorIsVarArity = yes,
+ % Unfortunately, if the type's type constructor has variable
+ % arity, we cannot use a one-cell representation for that type.
+ list__length(ArgTypeInfoVars, ActualArity),
+ make_int_const_construction(ActualArity, yes("ActualArity"),
+ ArityGoal, ArityVar, !VarTypes, !VarSet),
polymorphism__init_type_info_var(Type,
- [BaseVar, ArityVar | ArgTypeInfoVars], "type_info",
- VarSet1, VarTypes1, Var, TypeInfoGoal,
- VarSet, VarTypes),
+ [TypeCtorVar, ArityVar | ArgTypeInfoVars],
+ no, Var, TypeInfoGoal,
+ !VarSet, !VarTypes),
list__append([ArityGoal | ArgTypeInfoGoals], [TypeInfoGoal],
ExtraGoals1),
list__append(ExtraGoals0, ExtraGoals1, ExtraGoals)
- ; ArgTypeInfoVars = [_ | _] ->
+ ;
+ TypeCtorIsVarArity = no,
+ (
+ ArgTypeInfoVars = [_ | _],
polymorphism__init_type_info_var(Type,
- [BaseVar | ArgTypeInfoVars], "type_info",
- VarSet0, VarTypes0, Var, TypeInfoGoal,
- VarSet, VarTypes),
- list__append(ArgTypeInfoGoals, [TypeInfoGoal], ExtraGoals1),
+ [TypeCtorVar | ArgTypeInfoVars], no, Var,
+ TypeInfoGoal, !VarSet, !VarTypes),
+ list__append(ArgTypeInfoGoals, [TypeInfoGoal],
+ ExtraGoals1),
list__append(ExtraGoals0, ExtraGoals1, ExtraGoals)
;
- Var = BaseVar,
-
+ ArgTypeInfoVars = [],
% Since this type_ctor_info is pretending to be
% a type_info, we need to adjust its type.
% Since type_ctor_info_const cons_ids are handled
% specially, this should not cause problems.
- polymorphism__build_type_info_type(Type, NewBaseVarType),
- map__det_update(VarTypes0, BaseVar, NewBaseVarType, VarTypes),
-
- VarSet = VarSet0,
- ExtraGoals = ExtraGoals0
+ polymorphism__build_type_info_type(type_info, Type,
+ TypeInfoType),
+ map__det_update(!.VarTypes, TypeCtorVar, TypeInfoType,
+ !:VarTypes),
+ Var = TypeCtorVar,
+ list__append(ArgTypeInfoGoals, ExtraGoals0, ExtraGoals)
+
+ % The type_info to represent Type is just a
+ % type_ctor_info. We used to simply change the type
+ % of TypeCtorVar from type_ctor_info(Type) to
+ % type_info(Type), but that would confuse size_prof.m.
+ % We cannot leave its type as it is without extending
+ % type_util.type_unify to consider type_ctor_info and
+ % type_info interchangeable. We therefore create a
+ % new variable of type type_info(Type), and cast
+ % TypeCtorVar to it.
+ %
+ % polymorphism__new_type_info_var_raw(Type, type_info,
+ % Var, !VarSet, !VarTypes),
+ % generate_unsafe_cast(TypeCtorVar, Var, Context,
+ % CastGoal),
+ % list__append(ArgTypeInfoGoals, [CastGoal],
+ % ExtraGoals1),
+ % list__append(ExtraGoals0, ExtraGoals1, ExtraGoals)
+ )
).
polymorphism__get_special_proc(Type, SpecialPredId, ModuleInfo,
PredName, PredId, ProcId) :-
- classify_type(Type, ModuleInfo, TypeCategory),
- ( ( TypeCategory = user_type ; TypeCategory = enum_type ) ->
+ TypeCategory = classify_type(ModuleInfo, Type),
+ polymorphism__get_category_name(TypeCategory) = MaybeCategoryName,
+ (
+ MaybeCategoryName = no,
module_info_get_special_pred_map(ModuleInfo, SpecialPredMap),
( type_to_ctor_and_args(Type, TypeCtor, _TypeArgs) ->
map__search(SpecialPredMap, SpecialPredId - TypeCtor,
@@ -2835,61 +2908,53 @@
special_pred_mode_num(SpecialPredId, ProcInt),
proc_id_to_int(ProcId, ProcInt)
;
- polymorphism__get_category_name(TypeCategory, CategoryName),
+ MaybeCategoryName = yes(CategoryName),
special_pred_name_arity(SpecialPredId, SpecialName, _, Arity),
string__append_list(
["builtin_", SpecialName, "_", CategoryName], Name),
lookup_builtin_pred_proc_id(ModuleInfo,
- mercury_private_builtin_module, Name, Arity,
- only_mode, PredId, ProcId),
+ mercury_private_builtin_module, Name, predicate,
+ Arity, only_mode, PredId, ProcId),
PredName = qualified(mercury_private_builtin_module, Name)
).
-:- pred polymorphism__get_category_name(builtin_type, string).
-:- mode polymorphism__get_category_name(in, out) is det.
+:- func polymorphism__get_category_name(type_category) = maybe(string).
-polymorphism__get_category_name(int_type, "int").
-polymorphism__get_category_name(char_type, "int").
-polymorphism__get_category_name(enum_type, "int").
-polymorphism__get_category_name(float_type, "float").
-polymorphism__get_category_name(str_type, "string").
-polymorphism__get_category_name(pred_type, "pred").
-polymorphism__get_category_name(tuple_type, "tuple").
-polymorphism__get_category_name(polymorphic_type, _) :-
- error("polymorphism__get_category_name: polymorphic type").
-polymorphism__get_category_name(user_type, _) :-
- error("polymorphism__get_category_name: user_type").
-
- % Create a unification for a type_info or type_ctor_info variable:
- %
- % TypeInfoVar = type_info(CountVar,
- % SpecialPredVars...,
- % ArgTypeInfoVars...)
- %
- % or
- %
- % TypeCtorInfoVar = type_ctor_info(CountVar,
- % SpecialPredVars...)
- %
- % 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,
- 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__get_category_name(int_type) = yes("int").
+polymorphism__get_category_name(char_type) = yes("int").
+polymorphism__get_category_name(enum_type) = no.
+polymorphism__get_category_name(float_type) = yes("float").
+polymorphism__get_category_name(str_type) = yes("string").
+polymorphism__get_category_name(higher_order_type) = yes("pred").
+polymorphism__get_category_name(tuple_type) = yes("tuple").
+polymorphism__get_category_name(variable_type) = _ :-
+ error("polymorphism__get_category_name: variable type").
+polymorphism__get_category_name(void_type) = _ :-
+ error("polymorphism__get_category_name: void_type").
+polymorphism__get_category_name(user_ctor_type) = no.
+polymorphism__get_category_name(type_info_type) = no.
+polymorphism__get_category_name(type_ctor_info_type) = no.
+polymorphism__get_category_name(typeclass_info_type) = no.
+polymorphism__get_category_name(base_typeclass_info_type) = no.
-polymorphism__init_type_info_var(Type, ArgVars, Symbol, VarSet0, VarTypes0,
- TypeInfoVar, TypeInfoGoal, VarSet, VarTypes) :-
+polymorphism__init_type_info_var(Type, ArgVars, MaybePreferredVar, TypeInfoVar,
+ TypeInfoGoal, VarSet0, VarSet, VarTypes0, VarTypes) :-
PrivateBuiltin = mercury_private_builtin_module,
+ Symbol = "type_info",
ConsId = cons(qualified(PrivateBuiltin, Symbol), 1),
TypeInfoTerm = functor(ConsId, no, ArgVars),
% introduce a new variable
- polymorphism__new_type_info_var_raw(Type, Symbol, typeinfo_prefix,
- VarSet0, VarTypes0, TypeInfoVar, VarSet, VarTypes),
+ (
+ MaybePreferredVar = yes(TypeInfoVar),
+ VarSet = VarSet0,
+ VarTypes = VarTypes0
+ ;
+ MaybePreferredVar = no,
+ polymorphism__new_type_info_var_raw(Type, type_info,
+ TypeInfoVar, VarSet0, VarSet, VarTypes0, VarTypes)
+ ),
% create the construction unification to initialize the variable
UniMode = (free - ground(shared, none) ->
@@ -2898,7 +2963,7 @@
list__duplicate(NumArgVars, UniMode, UniModes),
RLExprnId = no,
Unification = construct(TypeInfoVar, ConsId, ArgVars, UniModes,
- construct_dynamically, cell_is_unique, RLExprnId),
+ construct_dynamically, cell_is_unique, RLExprnId, no),
UnifyMode = (free -> ground(shared, none)) -
(ground(shared, none) -> ground(shared, none)),
UnifyContext = unify_context(explicit, []),
@@ -2920,25 +2985,9 @@
TypeInfoGoal = Unify - GoalInfo.
- % Create a unification for a type_info or type_ctor_info variable:
- %
- % TypeCtorInfoVar = type_ctor_info(CountVar,
- % SpecialPredVars...)
- %
- % This unification will NOT lead to the creation of a cell on the
- % heap at runtime; it will cause TypeCtorInfoVar to refer to the
- % statically allocated type_ctor_info cell for the type, allocated
- % in the module that defines the type.
-
-:- pred polymorphism__init_const_type_ctor_info_var(type, type_ctor,
- module_info, prog_varset, map(prog_var, type), prog_var, hlds_goal,
- prog_varset, map(prog_var, type)).
-:- mode polymorphism__init_const_type_ctor_info_var(in, in, in, in, in,
- out, out, out, out) is det.
-
polymorphism__init_const_type_ctor_info_var(Type, TypeCtor,
- ModuleInfo, VarSet0, VarTypes0, TypeCtorInfoVar,
- TypeCtorInfoGoal, VarSet, VarTypes) :-
+ TypeCtorInfoVar, TypeCtorInfoGoal, ModuleInfo,
+ VarSet0, VarSet, VarTypes0, VarTypes) :-
type_util__type_ctor_module(ModuleInfo, TypeCtor, ModuleName),
type_util__type_ctor_name(ModuleInfo, TypeCtor, TypeName),
@@ -2947,14 +2996,13 @@
TypeInfoTerm = functor(ConsId, no, []),
% introduce a new variable
- polymorphism__new_type_info_var_raw(Type, "type_ctor_info",
- typectorinfo_prefix, VarSet0, VarTypes0,
- TypeCtorInfoVar, VarSet, VarTypes),
+ polymorphism__new_type_info_var_raw(Type, type_ctor_info,
+ TypeCtorInfoVar, VarSet0, VarSet, VarTypes0, VarTypes),
% create the construction unification to initialize the variable
RLExprnId = no,
Unification = construct(TypeCtorInfoVar, ConsId, [], [],
- construct_dynamically, cell_is_shared, RLExprnId),
+ construct_dynamically, cell_is_shared, RLExprnId, no),
UnifyMode = (free -> ground(shared, none)) -
(ground(shared, none) -> ground(shared, none)),
UnifyContext = unify_context(explicit, []),
@@ -2979,8 +3027,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", typeinfo_prefix,
- Var),
+ polymorphism__new_type_info_var(Type, type_info, Var),
( { varset__search_name(TypeVarSet, TypeVar, TypeVarName) } ->
=(Info0),
{ poly_info_get_varset(Info0, VarSet0) },
@@ -2993,31 +3040,33 @@
{ TypeInfoVars = [Var | TypeInfoVars1] },
polymorphism__make_head_vars(TypeVars, TypeVarSet, TypeInfoVars1).
-:- pred polymorphism__new_type_info_var(type, string, string, prog_var,
+:- pred polymorphism__new_type_info_var(type, type_info_kind, prog_var,
poly_info, poly_info).
-:- mode polymorphism__new_type_info_var(in, in, in, out, in, out) is det.
+:- mode polymorphism__new_type_info_var(in, in, out, in, out) is det.
-polymorphism__new_type_info_var(Type, Symbol, Prefix, Var, Info0, Info) :-
+polymorphism__new_type_info_var(Type, Kind, Var, Info0, Info) :-
poly_info_get_varset(Info0, VarSet0),
poly_info_get_var_types(Info0, VarTypes0),
- polymorphism__new_type_info_var_raw(Type, Symbol, Prefix,
- VarSet0, VarTypes0, Var, VarSet, VarTypes),
+ polymorphism__new_type_info_var_raw(Type, Kind, Var,
+ VarSet0, VarSet, VarTypes0, VarTypes),
poly_info_set_varset_and_types(VarSet, VarTypes, Info0, Info).
-:- pred polymorphism__new_type_info_var_raw(type, string, string, prog_varset,
- map(prog_var, type), prog_var, prog_varset, map(prog_var, type)).
-:- mode polymorphism__new_type_info_var_raw(in, in, in, in, in, out, out, out)
- is det.
-
-polymorphism__new_type_info_var_raw(Type, Symbol, Prefix, VarSet0, VarTypes0,
- Var, VarSet, VarTypes) :-
+polymorphism__new_type_info_var_raw(Type, Kind, Var,
+ VarSet0, VarSet, VarTypes0, VarTypes) :-
% introduce new variable
varset__new_var(VarSet0, Var, VarSet1),
term__var_to_int(Var, VarNum),
string__int_to_string(VarNum, VarNumStr),
+ (
+ Kind = type_info,
+ Prefix = typeinfo_prefix
+ ;
+ Kind = type_ctor_info,
+ Prefix = typectorinfo_prefix
+ ),
string__append(Prefix, VarNumStr, Name),
varset__name_var(VarSet1, Var, Name, VarSet),
- polymorphism__build_type_info_type(Symbol, Type, TypeInfoType),
+ polymorphism__build_type_info_type(Kind, Type, TypeInfoType),
map__set(VarTypes0, Var, TypeInfoType, VarTypes).
:- func typeinfo_prefix = string.
@@ -3073,12 +3122,11 @@
make_int_const_construction(Index, yes("TypeInfoIndex"),
IndexGoal, IndexVar, VarTypes0, VarTypes1, VarSet0, VarSet1),
- polymorphism__new_type_info_var_raw(term__variable(TypeVar),
- "type_info", typeinfo_prefix, VarSet1, VarTypes1,
- TypeInfoVar, VarSet, VarTypes),
+ polymorphism__new_type_info_var_raw(term__variable(TypeVar), type_info,
+ TypeInfoVar, VarSet1, VarSet, VarTypes1, VarTypes),
goal_util__generate_simple_call(mercury_private_builtin_module,
- "type_info_from_typeclass_info",
+ "type_info_from_typeclass_info", predicate,
[TypeClassInfoVar, IndexVar, TypeInfoVar], only_mode, det, no,
[TypeInfoVar - ground(shared, none)], ModuleInfo,
term__context_init, CallGoal),
@@ -3242,20 +3290,44 @@
sym_name_and_args(ClassNameTerm, ClassName, []),
Constraint = constraint(ClassName, ArgTypes).
-polymorphism__type_info_type(TypeInfoType, Type) :-
+polymorphism__type_info_or_ctor_type(TypeInfoType, Type) :-
type_to_ctor_and_args(TypeInfoType,
- qualified(mercury_private_builtin_module, "type_info") - 1,
- [Type]).
+ qualified(mercury_private_builtin_module, TypeName) - 1,
+ [Type]),
+ ( TypeName = "type_info" ; TypeName = "type_ctor_info" ).
polymorphism__build_type_info_type(Type, TypeInfoType) :-
- polymorphism__build_type_info_type("type_info", Type, TypeInfoType).
+ ( type_has_variable_arity_ctor(Type, _, _) ->
+ % We cannot use a plain type_ctor_info because we need to
+ % record the arity.
+ Kind = type_info
+ ; type_to_ctor_and_args(Type, _Ctor, Args) ->
+ (
+ Args = [],
+ Kind = type_ctor_info
+ ;
+ Args = [_ | _],
+ Kind = type_info
+ )
+ ;
+ % The type is variable, which means we have a type_info for it.
+ % That type_info may actually be a type_ctor_info, but the code
+ % of the current predicate won't treat it as such.
+ Kind = type_info
+ ),
+ polymorphism__build_type_info_type(Kind, Type, TypeInfoType).
-:- pred polymorphism__build_type_info_type(string, (type), (type)).
+:- pred polymorphism__build_type_info_type(type_info_kind, (type), (type)).
:- mode polymorphism__build_type_info_type(in, in, out) is det.
-polymorphism__build_type_info_type(Symbol, Type, TypeInfoType) :-
- construct_type(qualified(mercury_private_builtin_module, Symbol) - 1,
- [Type], TypeInfoType).
+polymorphism__build_type_info_type(Kind, Type, TypeInfoType) :-
+ (
+ Kind = type_info,
+ TypeInfoType = type_info_type(Type)
+ ;
+ Kind = type_ctor_info,
+ TypeInfoType = type_ctor_info_type(Type)
+ ).
%---------------------------------------------------------------------------%
Index: compiler/post_typecheck.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/post_typecheck.m,v
retrieving revision 1.52
diff -u -b -r1.52 post_typecheck.m
--- compiler/post_typecheck.m 26 May 2003 09:00:06 -0000 1.52
+++ compiler/post_typecheck.m 26 May 2003 09:12:17 -0000
@@ -335,9 +335,7 @@
%
set__to_sorted_list(UnboundTypeVarsSet, UnboundTypeVars),
list__length(UnboundTypeVars, Length),
- term__context_init(InitContext),
- Void = term__functor(term__atom("void"), [], InitContext),
- list__duplicate(Length, Void, Voids),
+ list__duplicate(Length, void_type, Voids),
%
% then create a *substitution* that maps the
Index: compiler/prog_rep.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_rep.m,v
retrieving revision 1.17
diff -u -b -r1.17 prog_rep.m
--- compiler/prog_rep.m 18 Mar 2003 02:43:42 -0000 1.17
+++ compiler/prog_rep.m 22 May 2003 12:52:18 -0000
@@ -132,7 +132,7 @@
term__var_to_int(Source, SourceRep),
AtomicGoalRep = unify_assign_rep(TargetRep, SourceRep)
;
- Uni = construct(Var, ConsId, Args, _, _, _, _),
+ Uni = construct(Var, ConsId, Args, _, _, _, _, _),
term__var_to_int(Var, VarRep),
prog_rep__represent_cons_id(ConsId, ConsIdRep),
list__map(term__var_to_int, Args, ArgsRep),
@@ -208,10 +208,12 @@
AtomicGoalRep = method_call_rep(VarRep, MethodNum, ArgsRep)
;
GenericCall = unsafe_cast,
- mercury_private_builtin_module(ModuleSymName),
- prog_out__sym_name_to_string(ModuleSymName, ModuleName),
- AtomicGoalRep = plain_call_rep(ModuleName,
- "unsafe_type_cast", ArgsRep)
+ ( ArgsRep = [InputArgRep, OutputArgRep] ->
+ AtomicGoalRep = unsafe_cast_rep(OutputArgRep,
+ InputArgRep)
+ ;
+ error("represent_goal_expr: unsafe_cast arity != 2")
+ )
;
GenericCall = aditi_builtin(_, _),
error("Sorry, not yet implemented\n\
Index: compiler/prog_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_util.m,v
retrieving revision 1.63
diff -u -b -r1.63 prog_util.m
--- compiler/prog_util.m 26 May 2003 09:00:07 -0000 1.63
+++ compiler/prog_util.m 26 May 2003 09:12:17 -0000
@@ -51,6 +51,13 @@
:- pred mercury_profiling_builtin_module(sym_name::out) is det.
:- func mercury_profiling_builtin_module = sym_name.
+ % Returns the name of the module containing the builtins for
+ % term size profiling.
+ % This module is automatically imported iff term size profiling is
+ % enabled.
+:- pred mercury_term_size_prof_builtin_module(sym_name::out) is det.
+:- func mercury_term_size_prof_builtin_module = sym_name.
+
% Returns the name of the module containing the public builtins
% used by the Aditi transaction interface, currently "aditi".
% This module is not automatically imported (XXX should it be?).
@@ -73,6 +80,18 @@
:- pred any_mercury_builtin_module(sym_name).
:- mode any_mercury_builtin_module(in) is semidet.
+ % Returns the name of the module containing the facilities for
+ % handling type descriptors.
+ % This module is not automatically imported.
+:- pred mercury_type_desc_module(sym_name::out) is det.
+:- func mercury_type_desc_module = sym_name.
+
+ % Returns the name of the module containing the facilities for
+ % handling machine integers.
+ % This module is not automatically imported.
+:- pred mercury_int_module(sym_name::out) is det.
+:- func mercury_int_module = sym_name.
+
%-----------------------------------------------------------------------------%
% Given a symbol name, return its unqualified name.
@@ -237,11 +256,17 @@
mercury_table_builtin_module = unqualified("table_builtin").
mercury_table_builtin_module(mercury_table_builtin_module).
mercury_profiling_builtin_module = unqualified("profiling_builtin").
-mercury_profiling_builtin_module(mercury_profiling_builtin_module).
+mercury_profiling_builtin_module(mercury_term_size_prof_builtin_module).
+mercury_term_size_prof_builtin_module = unqualified("term_size_prof_builtin").
+mercury_term_size_prof_builtin_module(mercury_term_size_prof_builtin_module).
aditi_public_builtin_module = unqualified("aditi").
aditi_public_builtin_module(aditi_public_builtin_module).
aditi_private_builtin_module = unqualified("aditi_private_builtin").
aditi_private_builtin_module(aditi_private_builtin_module).
+mercury_type_desc_module = unqualified("type_desc").
+mercury_type_desc_module(mercury_type_desc_module).
+mercury_int_module = unqualified("int").
+mercury_int_module(mercury_int_module).
any_mercury_builtin_module(Module) :-
( mercury_public_builtin_module(Module)
Index: compiler/pseudo_type_info.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/pseudo_type_info.m,v
retrieving revision 1.11
diff -u -b -r1.11 pseudo_type_info.m
--- compiler/pseudo_type_info.m 15 Mar 2003 03:09:08 -0000 1.11
+++ compiler/pseudo_type_info.m 30 Mar 2003 19:58:20 -0000
@@ -236,26 +236,6 @@
%---------------------------------------------------------------------------%
-:- pred canonicalize_type_args(type_ctor::in, list(type)::in, list(type)::out)
- is det.
-
-canonicalize_type_args(TypeCtor, TypeArgs0, TypeArgs) :-
- (
- % The argument to typeclass_info types is not
- % a type - it encodes the class constraint.
- % So we replace the argument with type `void'.
- mercury_private_builtin_module(PrivateBuiltin),
- TypeCtor = qualified(PrivateBuiltin, TypeName) - 1,
- ( TypeName = "typeclass_info"
- ; TypeName = "base_typeclass_info"
- )
- ->
- construct_type(unqualified("void") - 0, [], ArgType),
- TypeArgs = [ArgType]
- ;
- TypeArgs = TypeArgs0
- ).
-
% Type_infos and pseudo_type_infos whose principal type
% constructor is a variable arity type constructor
% must be handled specially, in that they must include
Index: compiler/quantification.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/quantification.m,v
retrieving revision 1.85
diff -u -b -r1.85 quantification.m
--- compiler/quantification.m 15 Mar 2003 03:09:08 -0000 1.85
+++ compiler/quantification.m 26 Mar 2003 08:54:36 -0000
@@ -451,25 +451,41 @@
quantification__get_lambda_outside(LambdaOutsideVars),
{ quantification__get_unify_typeinfos(Unification0, TypeInfoVars) },
- {
- Unification0 = construct(_, _, _, _,
- reuse_cell(CellToReuse0), _, _)
- ->
- CellToReuse = yes(CellToReuse0)
+ { Unification0 = construct(_, _, _, _, How, _, _, MaybeSize) ->
+ ( How = reuse_cell(cell_to_reuse(ReuseVar0, _, SetArgs)) ->
+ MaybeSetArgs = yes(SetArgs),
+ MaybeReuseVar = yes(ReuseVar0)
+ ;
+ MaybeSetArgs = no,
+ MaybeReuseVar = no
+ ),
+ ( MaybeSize = yes(dynamic_size(SizeVar0)) ->
+ MaybeSizeVar = yes(SizeVar0)
;
- CellToReuse = no
+ MaybeSizeVar = no
+ )
+ ;
+ MaybeSetArgs = no,
+ MaybeReuseVar = no,
+ MaybeSizeVar = no
},
- implicitly_quantify_unify_rhs(UnifyRHS0, CellToReuse,
+ implicitly_quantify_unify_rhs(UnifyRHS0, MaybeSetArgs,
Unification0, Context, UnifyRHS, Unification),
quantification__get_nonlocals(VarsUnifyRHS),
{ insert(VarsUnifyRHS, Var, GoalVars0) },
{ insert_list(GoalVars0, TypeInfoVars, GoalVars1) },
- { CellToReuse = yes(cell_to_reuse(ReuseVar, _, _)) ->
- insert(GoalVars1, ReuseVar, GoalVars)
+ { MaybeReuseVar = yes(ReuseVar) ->
+ insert(GoalVars1, ReuseVar, GoalVars2)
+ ;
+ GoalVars2 = GoalVars1
+ },
+
+ { MaybeSizeVar = yes(SizeVar) ->
+ insert(GoalVars2, SizeVar, GoalVars)
;
- GoalVars = GoalVars1
+ GoalVars = GoalVars2
},
quantification__update_seen_vars(GoalVars),
@@ -599,7 +615,7 @@
{ union(NonLocals1, NonLocals2, NonLocals) },
quantification__set_nonlocals(NonLocals).
-:- pred implicitly_quantify_unify_rhs(unify_rhs, maybe(cell_to_reuse),
+:- pred implicitly_quantify_unify_rhs(unify_rhs, maybe(list(bool)),
unification, prog_context, unify_rhs, unification,
quant_info, quant_info).
:- mode implicitly_quantify_unify_rhs(in, in, in, in,
@@ -609,12 +625,12 @@
var(X), Unification) -->
{ singleton_set(Vars, X) },
quantification__set_nonlocals(Vars).
-implicitly_quantify_unify_rhs(functor(_, _, ArgVars) @ RHS, Reuse,
+implicitly_quantify_unify_rhs(functor(_, _, ArgVars) @ RHS, ReuseArgs,
Unification, _, RHS, Unification) -->
quantification__get_nonlocals_to_recompute(NonLocalsToRecompute),
{
NonLocalsToRecompute = code_gen_nonlocals,
- Reuse = yes(cell_to_reuse(_, _, SetArgs))
+ ReuseArgs = yes(SetArgs)
->
% The fields taken from the reused cell aren't
% counted as code-gen nonlocals.
@@ -713,13 +729,14 @@
%
{
Unification0 = construct(ConstructVar, ConsId, Args0,
- ArgModes0, HowToConstruct, Uniq, AditiInfo)
+ ArgModes0, HowToConstruct, Uniq, AditiInfo, Size)
->
+ require(unify(Size, no), "lambda term has size info"),
map__from_corresponding_lists(Args0, ArgModes0, ArgModesMap),
to_sorted_list(NonLocals, Args),
map__apply_to_list(Args, ArgModesMap, ArgModes),
Unification = construct(ConstructVar, ConsId, Args,
- ArgModes, HowToConstruct, Uniq, AditiInfo)
+ ArgModes, HowToConstruct, Uniq, AditiInfo, Size)
;
% after mode analysis, unifications with lambda variables
% should always be construction unifications, but
@@ -919,24 +936,28 @@
unify(A, B, _, Unification, _), Set0, LambdaSet0,
Set, LambdaSet) :-
insert(Set0, A, Set1),
- ( Unification = construct(_, _, _, _, reuse_cell(Reuse0), _, _) ->
- Reuse = yes(Reuse0)
+ ( Unification = construct(_, _, _, _, How, _, _, Size) ->
+ ( How = reuse_cell(cell_to_reuse(ReuseVar, _, SetArgs)) ->
+ MaybeSetArgs = yes(SetArgs),
+ insert(Set1, ReuseVar, Set2)
;
- Reuse = no
+ MaybeSetArgs = no,
+ Set2 = Set1
),
- (
- Reuse = yes(cell_to_reuse(ReuseVar, _, _))
- ->
- insert(Set1, ReuseVar, Set2)
+ ( Size = yes(dynamic_size(SizeVar)) ->
+ insert(Set2, SizeVar, Set3)
;
- Unification = complicated_unify(_, _, TypeInfoVars)
- ->
- insert_list(Set1, TypeInfoVars, Set2)
+ Set3 = Set2
+ )
+ ; Unification = complicated_unify(_, _, TypeInfoVars) ->
+ MaybeSetArgs = no,
+ insert_list(Set1, TypeInfoVars, Set3)
;
- Set2 = Set1
+ MaybeSetArgs = no,
+ Set3 = Set1
),
- quantification__unify_rhs_vars(NonLocalsToRecompute, B, Reuse,
- Set2, LambdaSet0, Set, LambdaSet).
+ quantification__unify_rhs_vars(NonLocalsToRecompute, B, MaybeSetArgs,
+ Set3, LambdaSet0, Set, LambdaSet).
quantification__goal_vars_2(_, generic_call(GenericCall, ArgVars1, _, _),
Set0, LambdaSet, Set, LambdaSet) :-
@@ -1025,7 +1046,7 @@
:- pred quantification__unify_rhs_vars(nonlocals_to_recompute,
- unify_rhs, maybe(cell_to_reuse), set_of_var, set_of_var,
+ unify_rhs, maybe(list(bool)), set_of_var, set_of_var,
set_of_var, set_of_var).
:- mode quantification__unify_rhs_vars(in, in, in, in, in, out, out) is det.
@@ -1033,11 +1054,11 @@
Set0, LambdaSet, Set, LambdaSet) :-
insert(Set0, Y, Set).
quantification__unify_rhs_vars(NonLocalsToRecompute,
- functor(_Functor, _, ArgVars), Reuse,
+ functor(_Functor, _, ArgVars), MaybeSetArgs,
Set0, LambdaSet, Set, LambdaSet) :-
(
NonLocalsToRecompute = code_gen_nonlocals,
- Reuse = yes(cell_to_reuse(_, _, SetArgs))
+ MaybeSetArgs = yes(SetArgs)
->
% Ignore the fields taken from the reused cell.
quantification__get_updated_fields(SetArgs, ArgVars,
Index: compiler/reassign.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/reassign.m,v
retrieving revision 1.5
diff -u -b -r1.5 reassign.m
--- compiler/reassign.m 15 Mar 2003 03:09:08 -0000 1.5
+++ compiler/reassign.m 3 Apr 2003 14:35:27 -0000
@@ -222,7 +222,7 @@
KnownContentsMap = KnownContentsMap0,
DepLvalMap = DepLvalMap0
;
- Uinstr0 = incr_hp(Target, _, _, _),
+ Uinstr0 = incr_hp(Target, _, _, _, _),
RevInstrs1 = [Instr0 | RevInstrs0],
clobber_dependents(Target,
KnownContentsMap0, KnownContentsMap1,
Index: compiler/rl.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/rl.m,v
retrieving revision 1.23
diff -u -b -r1.23 rl.m
--- compiler/rl.m 26 May 2003 09:00:07 -0000 1.23
+++ compiler/rl.m 26 May 2003 09:12:17 -0000
@@ -1250,9 +1250,9 @@
rl__gather_type(ModuleInfo, Parents, Type, GatheredTypes0, GatheredTypes,
RecursiveTypes0, RecursiveTypes, Decls0, Decls, ThisType) :-
- classify_type(Type, ModuleInfo, ClassifiedType0),
+ ClassifiedType0 = classify_type(ModuleInfo, Type),
( ClassifiedType0 = enum_type ->
- ClassifiedType = user_type
+ ClassifiedType = user_ctor_type
;
ClassifiedType = ClassifiedType0
),
@@ -1261,8 +1261,8 @@
% this is converted to user_type above
error("rl__gather_type: enum type")
;
- ClassifiedType = polymorphic_type,
- error("rl__gather_type: polymorphic type")
+ ClassifiedType = variable_type,
+ error("rl__gather_type: variable type")
;
ClassifiedType = char_type,
GatheredTypes = GatheredTypes0,
@@ -1293,10 +1293,25 @@
GatheredTypes, RecursiveTypes0, RecursiveTypes,
Decls0, Decls, ThisType)
;
- ClassifiedType = pred_type,
- error("rl__gather_type: pred type")
+ ClassifiedType = void_type,
+ error("rl__gather_type: void type")
;
- ClassifiedType = user_type,
+ ClassifiedType = type_info_type,
+ error("rl__gather_type: type_info type")
+ ;
+ ClassifiedType = type_ctor_info_type,
+ error("rl__gather_type: type_ctor_info type")
+ ;
+ ClassifiedType = typeclass_info_type,
+ error("rl__gather_type: typeclass_info type")
+ ;
+ ClassifiedType = base_typeclass_info_type,
+ error("rl__gather_type: base_typeclass_info type")
+ ;
+ ClassifiedType = higher_order_type,
+ error("rl__gather_type: higher_order type")
+ ;
+ ClassifiedType = user_ctor_type,
% We can't handle abstract types here. magic_util.m
% checks that there are none.
rl__gather_du_type(ModuleInfo, Parents, Type, GatheredTypes0,
Index: compiler/rl_exprn.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/rl_exprn.m,v
retrieving revision 1.30
diff -u -b -r1.30 rl_exprn.m
--- compiler/rl_exprn.m 26 May 2003 09:00:08 -0000 1.30
+++ compiler/rl_exprn.m 26 May 2003 09:12:17 -0000
@@ -1107,7 +1107,7 @@
byte_tree::in, byte_tree::out,
rl_exprn_info::in, rl_exprn_info::out) is det.
-rl_exprn__unify(construct(Var, ConsId, Args, UniModes, _, _, _),
+rl_exprn__unify(construct(Var, ConsId, Args, UniModes, _, _, _, _),
GoalInfo, _Fail, Code) -->
rl_exprn_info_lookup_var_type(Var, Type),
rl_exprn_info_lookup_var(Var, VarReg),
Index: compiler/rl_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/rl_gen.m,v
retrieving revision 1.11
diff -u -b -r1.11 rl_gen.m
--- compiler/rl_gen.m 26 May 2003 09:00:08 -0000 1.11
+++ compiler/rl_gen.m 26 May 2003 09:12:24 -0000
@@ -1018,7 +1018,7 @@
% Only closure constructions can come
% between two Aditi calls.
Goal = unify(_, _, _, Uni, _) - _,
- Uni = construct(_, ConsId, _, _, _, _, _),
+ Uni = construct(_, ConsId, _, _, _, _, _, _),
ConsId = pred_const(_, _, _)
->
rl_gen__find_aditi_call(ModuleInfo, Goals,
@@ -1039,7 +1039,7 @@
rl_gen__setup_var_rels([BetweenGoal | BetweenGoals]) -->
(
{ BetweenGoal = unify(_, _, _, Uni, _) - _ },
- { Uni = construct(Var, ConsId, CurriedArgs, _, _, _, _) },
+ { Uni = construct(Var, ConsId, CurriedArgs, _, _, _, _, _) },
{ ConsId = pred_const(PredId, ProcId, _EvalMethod) }
->
{ Closure = closure_pred(CurriedArgs,
Index: compiler/rl_key.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/rl_key.m,v
retrieving revision 1.13
diff -u -b -r1.13 rl_key.m
--- compiler/rl_key.m 15 Mar 2003 03:09:09 -0000 1.13
+++ compiler/rl_key.m 22 May 2003 12:52:32 -0000
@@ -130,9 +130,9 @@
list__member(ArgBound, ArgBounds),
ArgBound \= var - _
),
- classify_type(Type, ModuleInfo, TypeClass),
- ( TypeClass = user_type
- ; TypeClass = enum_type
+ TypeCategory = classify_type(ModuleInfo, Type),
+ ( TypeCategory = user_ctor_type
+ ; TypeCategory = enum_type
),
module_info_types(ModuleInfo, Types),
type_to_ctor_and_args(Type, TypeCtor, _),
@@ -797,7 +797,7 @@
rl_key__unify_var_var(Var1, Var2).
rl_key__extract_key_range_unify(assign(Var1, Var2)) -->
rl_key__unify_var_var(Var1, Var2).
-rl_key__extract_key_range_unify(construct(Var, ConsId, Args, _, _, _, _)) -->
+rl_key__extract_key_range_unify(construct(Var, ConsId, Args, _, _, _, _, _)) -->
rl_key__unify_functor(Var, ConsId, Args).
rl_key__extract_key_range_unify(
deconstruct(Var, ConsId, Args, _, _, _)) -->
Index: compiler/saved_vars.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/saved_vars.m,v
retrieving revision 1.36
diff -u -b -r1.36 saved_vars.m
--- compiler/saved_vars.m 15 May 2003 03:44:57 -0000 1.36
+++ compiler/saved_vars.m 16 May 2003 06:58:08 -0000
@@ -172,7 +172,7 @@
Goals, SlotInfo) :-
(
Goal0 = unify(_, _, _, Unif, _) - GoalInfo,
- Unif = construct(Var, _, [], _, _, _, _),
+ Unif = construct(Var, _, [], _, _, _, _, _),
skip_constant_constructs(Goals0, Constants, Others),
Others = [First | _Rest],
can_push(Var, First),
@@ -220,7 +220,7 @@
skip_constant_constructs([Goal0 | Goals0], Constants, Others) :-
(
Goal0 = unify(_, _, _, Unif, _) - _,
- Unif = construct(_, _, [], _, _, _, _)
+ Unif = construct(_, _, [], _, _, _, _, _)
->
skip_constant_constructs(Goals0, Constants1, Others),
Constants = [Goal0 | Constants1]
Index: compiler/simplify.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/simplify.m,v
retrieving revision 1.117
diff -u -b -r1.117 simplify.m
--- compiler/simplify.m 26 May 2003 09:00:09 -0000 1.117
+++ compiler/simplify.m 26 May 2003 09:12:25 -0000
@@ -1169,8 +1169,8 @@
Unique = ground(unique, none),
ArgInsts = [R - Unique],
- goal_util__generate_simple_call(BuiltinModule, "compare", Args,
- mode_no(ModeNo), det, no, ArgInsts, ModuleInfo, Context,
+ goal_util__generate_simple_call(BuiltinModule, "compare", predicate,
+ Args, mode_no(ModeNo), det, no, ArgInsts, ModuleInfo, Context,
CmpGoal0),
CmpGoal0 = CmpExpr - CmpInfo0,
goal_info_get_nonlocals(CmpInfo0, CmpNonLocals0),
@@ -1386,8 +1386,9 @@
%
{ goal_info_get_context(GoalInfo0, GContext) },
{ generate_simple_call(mercury_private_builtin_module,
- "builtin_unify_pred", [XVar, YVar], mode_no(0),
- semidet, no, [], ModuleInfo, GContext, Call0 - _) },
+ "builtin_unify_pred", predicate, [XVar, YVar],
+ mode_no(0), semidet, no, [], ModuleInfo,
+ GContext, Call0 - _) },
simplify__goal_2(Call0, GoalInfo0, Call1, GoalInfo),
{ Call = Call1 - GoalInfo },
{ ExtraGoals = [] }
@@ -1462,7 +1463,7 @@
ArgVars = [TypeInfoVar, XVar, YVar],
goal_info_get_context(GoalInfo, Context),
goal_util__generate_simple_call(mercury_public_builtin_module,
- "unify", ArgVars, mode_no(0), semidet, no, [],
+ "unify", predicate, ArgVars, mode_no(0), semidet, no, [],
ModuleInfo, Context, Call).
:- pred simplify__call_specific_unify(type_ctor::in, list(prog_var)::in,
Index: compiler/special_pred.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/special_pred.m,v
retrieving revision 1.36
diff -u -b -r1.36 special_pred.m
--- compiler/special_pred.m 15 Mar 2003 03:09:10 -0000 1.36
+++ compiler/special_pred.m 22 May 2003 12:38:52 -0000
@@ -165,11 +165,11 @@
special_pred_description(index, "indexing predicate").
special_pred_is_generated_lazily(ModuleInfo, TypeCtor) :-
- classify_type_ctor(ModuleInfo, TypeCtor, Class),
+ TypeCategory = classify_type_ctor(ModuleInfo, TypeCtor),
(
- Class = tuple_type
+ TypeCategory = tuple_type
;
- ( Class = user_type ; Class = enum_type ),
+ ( TypeCategory = user_ctor_type ; TypeCategory = enum_type ),
module_info_types(ModuleInfo, Types),
map__search(Types, TypeCtor, TypeDefn),
hlds_data__get_type_defn_body(TypeDefn, Body),
@@ -179,11 +179,11 @@
).
special_pred_is_generated_lazily(ModuleInfo, TypeCtor, Body, Status) :-
- classify_type_ctor(ModuleInfo, TypeCtor, Class),
+ TypeCategory = classify_type_ctor(ModuleInfo, TypeCtor),
(
- Class = tuple_type
+ TypeCategory = tuple_type
;
- ( Class = user_type ; Class = enum_type ),
+ ( TypeCategory = user_ctor_type ; TypeCategory = enum_type ),
special_pred_is_generated_lazily_2(ModuleInfo,
TypeCtor, Body, Status)
).
Index: compiler/stack_layout.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/stack_layout.m,v
retrieving revision 1.82
diff -u -b -r1.82 stack_layout.m
--- compiler/stack_layout.m 9 May 2003 05:51:52 -0000 1.82
+++ compiler/stack_layout.m 9 May 2003 06:14:53 -0000
@@ -158,12 +158,6 @@
ProcLabel = special_proc(_, _, _, _, _, _)
).
-:- pred stack_layout__data_addr_to_maybe_rval(data_addr::in, maybe(rval)::out)
- is det.
-
-stack_layout__data_addr_to_maybe_rval(DataAddr, yes(Rval)) :-
- Rval = const(data_addr_const(DataAddr)).
-
%---------------------------------------------------------------------------%
% concat_string_list appends a list of strings together,
@@ -799,7 +793,7 @@
;
stack_layout__construct_tvar_rvals(TVarLocnMap, Vector),
add_static_cell(Vector, DataAddr, !StaticCellInfo),
- TypeParamRval = const(data_addr_const(DataAddr))
+ TypeParamRval = const(data_addr_const(DataAddr, no))
).
:- pred stack_layout__construct_tvar_rvals(map(tvar, set(layout_locn))::in,
@@ -978,7 +972,7 @@
stack_layout__get_static_cell_info(StaticCellInfo0),
{ add_static_cell(TypeLocnVectorRvalsTypes, TypeLocnVectorAddr,
StaticCellInfo0, StaticCellInfo1) },
- { TypeLocnVector = const(data_addr_const(TypeLocnVectorAddr)) },
+ { TypeLocnVector = const(data_addr_const(TypeLocnVectorAddr, no)) },
stack_layout__set_static_cell_info(StaticCellInfo1),
stack_layout__get_trace_stack_layout(TraceStackLayout),
@@ -992,7 +986,7 @@
{ add_static_cell(VarNumRvalsTypes, NumVectorAddr,
StaticCellInfo2, StaticCellInfo) },
stack_layout__set_static_cell_info(StaticCellInfo),
- { NumVector = const(data_addr_const(NumVectorAddr)) }
+ { NumVector = const(data_addr_const(NumVectorAddr, no)) }
;
{ NumVector = const(int_const(0)) }
).
@@ -1087,7 +1081,7 @@
closure_proc_id(CallerProcLabel, SeqNo, ClosureProcLabel)),
Data = layout_data(closure_proc_id_data(CallerProcLabel, SeqNo,
ClosureProcLabel, ModuleName, FileName, LineNumber, GoalPath)),
- ProcIdRvalType = const(data_addr_const(DataAddr)) - data_ptr,
+ ProcIdRvalType = const(data_addr_const(DataAddr, no)) - data_ptr,
ClosureLayoutInfo = closure_layout_info(ClosureArgs, TVarLocnMap),
stack_layout__construct_closure_arg_rvals(ClosureArgs,
ClosureArgRvalsTypes, !StaticCellInfo),
@@ -1166,7 +1160,7 @@
list__map_foldl(stack_layout__construct_table_arg_pti_rval,
Args, PTIRvalsTypes, !StaticCellInfo),
add_static_cell(PTIRvalsTypes, PTIVectorAddr, !StaticCellInfo),
- PTIVectorRval = const(data_addr_const(PTIVectorAddr)),
+ PTIVectorRval = const(data_addr_const(PTIVectorAddr, no)),
map__map_values(stack_layout__convert_slot_to_locn_map,
TVarSlotMap, TVarLocnMap),
stack_layout__construct_tvar_vector(TVarLocnMap, TVarVectorRval,
@@ -1253,7 +1247,7 @@
stack_layout__represent_special_live_value_type(SpecialTypeName, Rval) :-
RttiTypeCtor = rtti_type_ctor(unqualified(""), SpecialTypeName, 0),
DataAddr = rtti_addr(ctor_rtti_id(RttiTypeCtor, type_ctor_info)),
- Rval = const(data_addr_const(DataAddr)).
+ Rval = const(data_addr_const(DataAddr, no)).
%---------------------------------------------------------------------------%
Index: compiler/stack_opt.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/stack_opt.m,v
retrieving revision 1.8
diff -u -b -r1.8 stack_opt.m
--- compiler/stack_opt.m 22 May 2003 05:54:38 -0000 1.8
+++ compiler/stack_opt.m 23 May 2003 05:33:40 -0000
@@ -508,7 +508,7 @@
{ Goal = unify(_, _, _, Unification, _) },
(
{ Unification = construct(CellVar, _ConsId, ArgVars, _,
- HowToConstruct, _, _) },
+ HowToConstruct, _, _, _) },
{ HowToConstruct = reuse_cell(_) ->
error("optimize_live_sets_in_goal: reuse")
;
Index: compiler/static_term.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/static_term.m,v
retrieving revision 1.6
diff -u -b -r1.6 static_term.m
--- compiler/static_term.m 9 May 2003 05:51:52 -0000 1.6
+++ compiler/static_term.m 9 May 2003 06:18:19 -0000
@@ -11,6 +11,8 @@
% into rvals we can give to llds_out.m in order to make those terms available
% at runtime in the program being compiled.
%
+% XXX At the moment, the constructed term never has term_size slots.
+%
%---------------------------------------------------------------------------%
:- module ll_backend__static_term.
@@ -68,14 +70,14 @@
!StaticCellInfo),
add_static_cell_natural_types([SectagRval | ArgRvals],
DataAddr, !StaticCellInfo),
- Rval = mkword(Ptag, const(data_addr_const(DataAddr)))
+ Rval = mkword(Ptag, const(data_addr_const(DataAddr, no)))
;
FunctorInfo = functor_unshared(Ptag, Args),
list__map_foldl(static_term__term_to_rval, Args, ArgRvals,
!StaticCellInfo),
add_static_cell_natural_types(ArgRvals, DataAddr,
!StaticCellInfo),
- Rval = mkword(Ptag, const(data_addr_const(DataAddr)))
+ Rval = mkword(Ptag, const(data_addr_const(DataAddr, no)))
;
FunctorInfo = functor_notag(Univ),
static_term__term_to_rval(Univ, Rval, !StaticCellInfo)
Index: compiler/stratify.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/stratify.m,v
retrieving revision 1.29
diff -u -b -r1.29 stratify.m
--- compiler/stratify.m 15 Mar 2003 03:09:10 -0000 1.29
+++ compiler/stratify.m 17 Mar 2003 07:53:54 -0000
@@ -783,7 +783,7 @@
% currently when this pass is run the construct/4
% case will not happen as higher order constants have
% been transformed to lambda goals. see above
- Unification = construct(_Var2, ConsId, _, _, _, _, _)
+ Unification = construct(_Var2, ConsId, _, _, _, _, _, _)
->
(
(
@@ -884,7 +884,7 @@
% currently when this pass is run the construct/4
% case will not happen as higher order constants have
% been transformed to lambda goals see above
- Unification = construct(_Var2, ConsId, _, _, _, _, _)
+ Unification = construct(_Var2, ConsId, _, _, _, _, _, _)
->
(
(
Index: compiler/string_switch.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/string_switch.m,v
retrieving revision 1.43
diff -u -b -r1.43 string_switch.m
--- compiler/string_switch.m 9 May 2003 05:51:52 -0000 1.43
+++ compiler/string_switch.m 9 May 2003 06:15:33 -0000
@@ -97,10 +97,11 @@
(
add_static_cell_natural_types(NextSlots, NextSlotsTableAddr,
!CodeInfo),
- NextSlotsTable = const(data_addr_const(NextSlotsTableAddr)),
+ NextSlotsTable = const(
+ data_addr_const(NextSlotsTableAddr, no)),
add_static_cell_natural_types(Strings, StringTableAddr,
!CodeInfo),
- StringTable = const(data_addr_const(StringTableAddr)),
+ StringTable = const(data_addr_const(StringTableAddr, no)),
HashLookupCode = node([
comment("hashed string switch") -
"",
Index: compiler/switch_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/switch_gen.m,v
retrieving revision 1.81
diff -u -b -r1.81 switch_gen.m
--- compiler/switch_gen.m 15 Mar 2003 07:11:56 -0000 1.81
+++ compiler/switch_gen.m 22 May 2003 08:06:15 -0000
@@ -189,7 +189,7 @@
switch_gen__determine_category(CaseVar, SwitchCategory) -->
code_info__variable_type(CaseVar, Type),
code_info__get_module_info(ModuleInfo),
- { classify_type(Type, ModuleInfo, TypeCategory) },
+ { classify_type(ModuleInfo, Type) = TypeCategory },
{ switch_util__type_cat_to_switch_cat(TypeCategory, SwitchCategory) }.
%---------------------------------------------------------------------------%
Index: compiler/switch_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/switch_util.m,v
retrieving revision 1.12
diff -u -b -r1.12 switch_util.m
--- compiler/switch_util.m 26 May 2003 09:00:10 -0000 1.12
+++ compiler/switch_util.m 26 May 2003 09:12:25 -0000
@@ -39,7 +39,7 @@
; tag_switch
; other_switch.
-:- pred switch_util__type_cat_to_switch_cat(builtin_type, switch_category).
+:- pred switch_util__type_cat_to_switch_cat(type_category, switch_category).
:- mode switch_util__type_cat_to_switch_cat(in, out) is det.
% Return the priority of a constructor test.
@@ -55,7 +55,7 @@
% Fail if the type isn't the sort of type that has a range
% or if the type's range is too big to switch on (e.g. int).
%
-:- pred switch_util__type_range(builtin_type, type, module_info, int, int).
+:- pred switch_util__type_range(type_category, type, module_info, int, int).
:- mode switch_util__type_range(in, in, in, out, out) is semidet.
%-----------------------------------------------------------------------------%
@@ -270,10 +270,20 @@
switch_util__type_cat_to_switch_cat(char_type, atomic_switch).
switch_util__type_cat_to_switch_cat(float_type, other_switch).
switch_util__type_cat_to_switch_cat(str_type, string_switch).
-switch_util__type_cat_to_switch_cat(pred_type, other_switch).
-switch_util__type_cat_to_switch_cat(user_type, tag_switch).
-switch_util__type_cat_to_switch_cat(polymorphic_type, other_switch).
+switch_util__type_cat_to_switch_cat(higher_order_type, other_switch).
+switch_util__type_cat_to_switch_cat(user_ctor_type, tag_switch).
+switch_util__type_cat_to_switch_cat(variable_type, other_switch).
switch_util__type_cat_to_switch_cat(tuple_type, other_switch).
+switch_util__type_cat_to_switch_cat(void_type, _) :-
+ error("switch_util__type_cat_to_switch_cat: void").
+switch_util__type_cat_to_switch_cat(type_info_type, _) :-
+ error("switch_util__type_cat_to_switch_cat: type_info").
+switch_util__type_cat_to_switch_cat(type_ctor_info_type, _) :-
+ error("switch_util__type_cat_to_switch_cat: type_ctor_info").
+switch_util__type_cat_to_switch_cat(typeclass_info_type, _) :-
+ error("switch_util__type_cat_to_switch_cat: typeclass_info").
+switch_util__type_cat_to_switch_cat(base_typeclass_info_type, _) :-
+ error("switch_util__type_cat_to_switch_cat: base_typeclass_info").
% Return the priority of a constructor test.
% A low number here indicates a high priority.
Index: compiler/table_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/table_gen.m,v
retrieving revision 1.50
diff -u -b -r1.50 table_gen.m
--- compiler/table_gen.m 13 May 2003 09:24:41 -0000 1.50
+++ compiler/table_gen.m 22 May 2003 18:28:39 -0000
@@ -1293,7 +1293,7 @@
[Step | Steps]) :-
ModuleInfo = !.TableInfo ^ table_module_info,
map__lookup(!.VarTypes, Var, VarType),
- classify_type(VarType, ModuleInfo, TypeCat),
+ classify_type(ModuleInfo, VarType) = TypeCat,
gen_lookup_call_for_type(TypeCat, VarType, TableVar0, Var, Context,
!VarTypes, !VarSet, !TableInfo, TableVar1, Goal0, Step),
(
@@ -1330,14 +1330,14 @@
[Goal | RestGoals]) :-
ModuleInfo = !.TableInfo ^ table_module_info,
map__lookup(!.VarTypes, Var, VarType),
- classify_type(VarType, ModuleInfo, TypeCat),
+ classify_type(ModuleInfo, VarType) = TypeCat,
gen_lookup_call_for_type(TypeCat, VarType, TableVar0, Var, Context,
!VarTypes, !VarSet, !TableInfo, TableVar1, Goal, _),
generate_answer_table_lookup_goals(Vars, Context,
TableVar1, TableTipVar, !VarTypes, !VarSet,
!TableInfo, RestGoals).
-:- pred gen_lookup_call_for_type(builtin_type::in, (type)::in,
+:- pred gen_lookup_call_for_type(type_category::in, (type)::in,
prog_var::in, prog_var::in, term__context::in,
map(prog_var, type)::in, map(prog_var, type)::out,
prog_varset::in, prog_varset::out, table_info::in, table_info::out,
@@ -1384,12 +1384,9 @@
generate_new_table_var("TableNodeVar", trie_node_type,
!VarTypes, !VarSet, NextTableVar),
InstMapAL = [NextTableVar - ground(unique, none)],
+ lookup_tabling_category(TypeCat, MaybeCatStringStep),
(
- ( TypeCat = pred_type
- ; TypeCat = polymorphic_type
- ; TypeCat = user_type
- )
- ->
+ MaybeCatStringStep = no,
( type_util__vars(Type, []) ->
LookupPredName = "table_lookup_insert_user",
Step = table_trie_step_user(Type)
@@ -1407,7 +1404,7 @@
CallGoal = _ - GoalInfo,
conj_list_to_goal(ConjList, GoalInfo, Goal)
;
- builtin_type_lookup_category(TypeCat, CatString, Step),
+ MaybeCatStringStep = yes(CatString - Step),
string__append("table_lookup_insert_", CatString,
LookupPredName),
generate_call(LookupPredName,
@@ -1517,14 +1514,14 @@
!VarSet, OffsetVar, OffsetUnifyGoal),
ModuleInfo = !.TableInfo ^ table_module_info,
map__lookup(!.VarTypes, Var, VarType),
- classify_type(VarType, ModuleInfo, TypeCat),
+ classify_type(ModuleInfo, VarType) = TypeCat,
gen_save_call_for_type(TypeCat, VarType, TableVar, Var, OffsetVar,
Context, !VarTypes, !VarSet, !TableInfo, CallGoal),
generate_save_goals(NumberedRest, TableVar, Context,
!VarTypes, !VarSet, !TableInfo, RestGoals),
Goals = [OffsetUnifyGoal, CallGoal | RestGoals].
-:- pred gen_save_call_for_type(builtin_type::in, (type)::in,
+:- pred gen_save_call_for_type(type_category::in, (type)::in,
prog_var::in, prog_var::in, prog_var::in, term__context::in,
map(prog_var, type)::in, map(prog_var, type)::out,
prog_varset::in, prog_varset::out, table_info::in, table_info::out,
@@ -1537,7 +1534,7 @@
LookupPredName = "table_save_io_state_ans",
generate_call(LookupPredName, [TableVar, OffsetVar, Var],
det, yes(impure), [], ModuleInfo, Context, Goal)
- ; not_builtin_type(TypeCat) ->
+ ; builtin_type(TypeCat) = no ->
make_type_info_var(Type, Context, !VarTypes, !VarSet,
!TableInfo, TypeInfoVar, ExtraGoals),
@@ -1630,13 +1627,13 @@
gen_int_construction("OffsetVar", Offset, !VarTypes, !VarSet,
OffsetVar, OffsetUnifyGoal),
map__lookup(!.VarTypes, Var, VarType),
- classify_type(VarType, ModuleInfo, TypeCat),
+ classify_type(ModuleInfo, VarType) = TypeCat,
gen_restore_call_for_type(TypeCat, VarType, AnswerBlockVar, Var,
OffsetVar, ModuleInfo, Context, CallGoal),
generate_restore_goals(NumberedRest, AnswerBlockVar, ModuleInfo,
Context, !VarTypes, !VarSet, RestGoals).
-:- pred gen_restore_call_for_type(builtin_type::in, (type)::in,
+:- pred gen_restore_call_for_type(type_category::in, (type)::in,
prog_var::in, prog_var::in, prog_var::in, module_info::in,
term__context::in, hlds_goal::out) is det.
@@ -1644,7 +1641,7 @@
ModuleInfo, Context, Goal) :-
( type_util__type_is_io_state(Type) ->
LookupPredName = "table_restore_io_state_ans"
- ; not_builtin_type(TypeCat) ->
+ ; builtin_type(TypeCat) = no ->
LookupPredName = "table_restore_any_ans"
;
type_save_category(TypeCat, CatString),
@@ -1739,8 +1736,8 @@
generate_call(PredName, Args, Detism, MaybeFeature, InstMap,
ModuleInfo, Context, CallGoal) :-
mercury_table_builtin_module(BuiltinModule),
- goal_util__generate_simple_call(BuiltinModule, PredName, Args,
- only_mode, Detism, MaybeFeature, InstMap, ModuleInfo,
+ goal_util__generate_simple_call(BuiltinModule, PredName, predicate,
+ Args, only_mode, Detism, MaybeFeature, InstMap, ModuleInfo,
Context, CallGoal).
:- pred append_fail(hlds_goal::in, hlds_goal::out) is det.
@@ -1830,51 +1827,77 @@
create_instmap_delta(Rest, IMD1),
instmap_delta_apply_instmap_delta(IMD0, IMD1, IMD).
-:- pred not_builtin_type(builtin_type::in) is semidet.
+:- func builtin_type(type_category) = bool.
-not_builtin_type(pred_type).
-not_builtin_type(enum_type).
-not_builtin_type(polymorphic_type).
-not_builtin_type(tuple_type).
-not_builtin_type(user_type).
+% For backward compatibility, we treat type_info_type as user_type. However,
+% this makes the tabling of type_infos more expensive than necessary, since
+% we essentially table the information in the type_info twice, once by tabling
+% the type represented by the type_info (since this is the value of the type
+% argument of the type constructor private_builtin.type_info/1, and then
+% tabling the type_info itself.
+
+builtin_type(int_type) = yes.
+builtin_type(char_type) = yes.
+builtin_type(str_type) = yes.
+builtin_type(float_type) = yes.
+builtin_type(void_type) = yes.
+builtin_type(type_info_type) = no.
+builtin_type(type_ctor_info_type) = yes.
+builtin_type(typeclass_info_type) = yes.
+builtin_type(base_typeclass_info_type) = yes.
+builtin_type(higher_order_type) = no.
+builtin_type(enum_type) = no.
+builtin_type(variable_type) = no.
+builtin_type(tuple_type) = no.
+builtin_type(user_ctor_type) = no.
% Figure out what kind of data structure implements the lookup table for values
% of a given builtin type.
-:- pred builtin_type_lookup_category(builtin_type::in, string::out,
- table_trie_step::out) is det.
+:- pred lookup_tabling_category(type_category::in,
+ maybe(pair(string, table_trie_step))::out) is det.
-builtin_type_lookup_category(int_type, "int", table_trie_step_int).
-builtin_type_lookup_category(char_type, "char", table_trie_step_char).
-builtin_type_lookup_category(str_type, "string", table_trie_step_string).
-builtin_type_lookup_category(float_type, "float", table_trie_step_float).
-builtin_type_lookup_category(enum_type, _, _) :-
- error("builtin_type_lookup_category: non-builtin-type").
-builtin_type_lookup_category(pred_type, _, _) :-
- error("builtin_type_lookup_category: non-builtin-type").
-builtin_type_lookup_category(tuple_type,_, _) :-
- error("builtin_type_lookup_category: non-builtin-type").
-builtin_type_lookup_category(polymorphic_type, _, _) :-
- error("builtin_type_lookup_category: non-builtin-type").
-builtin_type_lookup_category(user_type, _, _) :-
- error("builtin_type_lookup_category: non-builtin-type").
+lookup_tabling_category(int_type, yes("int" - table_trie_step_int)).
+lookup_tabling_category(char_type, yes("char" - table_trie_step_char)).
+lookup_tabling_category(str_type, yes("string" - table_trie_step_string)).
+lookup_tabling_category(float_type, yes("float" - table_trie_step_float)).
+lookup_tabling_category(void_type, _) :-
+ error("lookup_tabling_category: void").
+lookup_tabling_category(type_info_type, no).
+lookup_tabling_category(type_ctor_info_type, no).
+lookup_tabling_category(typeclass_info_type, no).
+lookup_tabling_category(base_typeclass_info_type, no).
+lookup_tabling_category(enum_type, no).
+lookup_tabling_category(higher_order_type, no).
+lookup_tabling_category(tuple_type, no).
+lookup_tabling_category(variable_type, no).
+lookup_tabling_category(user_ctor_type, no).
% Figure out which save and restore predicates in library/table_builtin.m
% we need to use for values of types belonging the type category given by
% the first argument. The returned value replaces CAT in table_save_CAT_ans
% and table_restore_CAT_ans.
-:- pred type_save_category(builtin_type::in, string::out) is det.
+:- pred type_save_category(type_category::in, string::out) is det.
type_save_category(enum_type, "enum").
type_save_category(int_type, "int").
type_save_category(char_type, "char").
type_save_category(str_type, "string").
type_save_category(float_type, "float").
-type_save_category(pred_type, "pred").
+type_save_category(higher_order_type, "pred").
type_save_category(tuple_type, "any").
-type_save_category(polymorphic_type, "any").
-type_save_category(user_type, "any").
+type_save_category(user_ctor_type, "any"). % could do better
+type_save_category(variable_type, "any"). % could do better
+type_save_category(void_type, _) :-
+ error("type_save_category: void").
+type_save_category(type_info_type, "any"). % could do better
+type_save_category(type_ctor_info_type, _) :-
+ error("type_save_category: type_ctor_info").
+type_save_category(typeclass_info_type, _) :-
+ error("type_save_category: typeclass_info").
+type_save_category(base_typeclass_info_type, _) :-
+ error("type_save_category: base_typeclass_info").
%-----------------------------------------------------------------------------%
Index: compiler/term_traversal.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/term_traversal.m,v
retrieving revision 1.23
diff -u -b -r1.23 term_traversal.m
--- compiler/term_traversal.m 26 May 2003 09:00:10 -0000 1.23
+++ compiler/term_traversal.m 26 May 2003 09:12:26 -0000
@@ -124,7 +124,7 @@
traverse_goal_2(unify(_Var, _RHS, _UniMode, Unification, _Context),
_GoalInfo, Params, Info0, Info) :-
(
- Unification = construct(OutVar, ConsId, Args, Modes, _, _, _),
+ Unification = construct(OutVar, ConsId, Args, Modes, _,_,_,_),
(
unify_change(OutVar, ConsId, Args, Modes, Params,
Gamma, InVars, OutVars0)
Index: compiler/term_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/term_util.m,v
retrieving revision 1.25
diff -u -b -r1.25 term_util.m
--- compiler/term_util.m 26 May 2003 09:00:10 -0000 1.25
+++ compiler/term_util.m 26 May 2003 09:12:26 -0000
@@ -589,21 +589,26 @@
).
zero_size_type(Type, Module) :-
- classify_type(Type, Module, TypeCategory),
- zero_size_type_category(TypeCategory, Type, Module, yes).
+ classify_type(Module, Type) = TypeCategory,
+ zero_size_type_category(TypeCategory, yes).
-:- pred zero_size_type_category(builtin_type, type, module_info, bool).
-:- mode zero_size_type_category(in, in, in, out) is det.
+:- pred zero_size_type_category(type_category, bool).
+:- mode zero_size_type_category(in, out) is det.
-zero_size_type_category(int_type, _, _, yes).
-zero_size_type_category(char_type, _, _, yes).
-zero_size_type_category(str_type, _, _, yes).
-zero_size_type_category(float_type, _, _, yes).
-zero_size_type_category(pred_type, _, _, no).
-zero_size_type_category(tuple_type, _, _, no).
-zero_size_type_category(enum_type, _, _, yes).
-zero_size_type_category(polymorphic_type, _, _, no).
-zero_size_type_category(user_type, _, _, no).
+zero_size_type_category(int_type, yes).
+zero_size_type_category(char_type, yes).
+zero_size_type_category(str_type, yes).
+zero_size_type_category(float_type, yes).
+zero_size_type_category(void_type, yes).
+zero_size_type_category(type_info_type, yes).
+zero_size_type_category(type_ctor_info_type, yes).
+zero_size_type_category(typeclass_info_type, yes).
+zero_size_type_category(base_typeclass_info_type, yes).
+zero_size_type_category(higher_order_type, no).
+zero_size_type_category(tuple_type, no).
+zero_size_type_category(enum_type, yes).
+zero_size_type_category(variable_type, no).
+zero_size_type_category(user_ctor_type, no).
%-----------------------------------------------------------------------------%
Index: compiler/transform_hlds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/transform_hlds.m,v
retrieving revision 1.5
diff -u -b -r1.5 transform_hlds.m
--- compiler/transform_hlds.m 15 Mar 2003 03:09:12 -0000 1.5
+++ compiler/transform_hlds.m 31 Mar 2003 08:17:29 -0000
@@ -50,6 +50,7 @@
:- include_module dead_proc_elim.
:- include_module const_prop.
:- include_module loop_inv.
+:- include_module size_prof.
:- include_module mmc_analysis.
Index: compiler/type_ctor_info.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/type_ctor_info.m,v
retrieving revision 1.39
diff -u -b -r1.39 type_ctor_info.m
--- compiler/type_ctor_info.m 14 May 2003 00:10:03 -0000 1.39
+++ compiler/type_ctor_info.m 15 May 2003 02:31:42 -0000
@@ -162,8 +162,8 @@
Compare = proc(ComparePredId, CompareProcId)
;
lookup_builtin_pred_proc_id(ModuleInfo,
- mercury_private_builtin_module, "unused", 0,
- only_mode, PredId, ProcId),
+ mercury_private_builtin_module, "unused",
+ predicate, 0, only_mode, PredId, ProcId),
Unused = proc(PredId, ProcId),
Unify = Unused,
Compare = Unused
Index: compiler/type_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/type_util.m,v
retrieving revision 1.117
diff -u -b -r1.117 type_util.m
--- compiler/type_util.m 26 May 2003 09:00:11 -0000 1.117
+++ compiler/type_util.m 26 May 2003 10:33:40 -0000
@@ -52,6 +52,13 @@
:- pred type_is_tuple(type, list(type)).
:- mode type_is_tuple(in, out) is semidet.
+ % type_has_variable_arity_ctor(Type, TypeCtor, TypeArgs)
+ % Check if the principal type constructor of Type is of variable arity.
+ % If yes, return the type constructor as TypeCtor and its args as
+ % TypeArgs. If not, fail.
+:- pred type_has_variable_arity_ctor((type)::in, type_ctor::out,
+ list(type)::out) is semidet.
+
% type_ctor_is_higher_order(TypeCtor, PredOrFunc) succeeds iff
% TypeCtor is a higher-order predicate or function type.
:- pred type_ctor_is_higher_order(type_ctor, purity, pred_or_func,
@@ -113,6 +120,11 @@
:- pred is_introduced_type_info_type(type).
:- mode is_introduced_type_info_type(in) is semidet.
+:- pred is_introduced_type_info_type_ctor(type_ctor).
+:- mode is_introduced_type_info_type_ctor(in) is semidet.
+
+:- func is_introduced_type_info_type_category(type_category) = bool.
+
% Given a list of variables, return the permutation
% of that list which has all the type_info-related variables
% preceding the non-type_info-related variables (with the relative
@@ -130,23 +142,28 @@
:- mode remove_new_prefix(in, out) is semidet.
:- mode remove_new_prefix(out, in) is det.
- % Given a type, determine what sort of type it is.
-:- pred classify_type(type, module_info, builtin_type).
-:- mode classify_type(in, in, out) is det.
+ % Given a type, determine what category its principal constructor
+ % falls into.
+:- func classify_type(module_info, type) = type_category.
- % Given a type_ctor, determine what sort of type it is.
-:- pred classify_type_ctor(module_info, type_ctor, builtin_type).
-:- mode classify_type_ctor(in, in, out) is det.
+ % Given a type_ctor, determine what sort it is.
+:- func classify_type_ctor(module_info, type_ctor) = type_category.
-:- type builtin_type ---> int_type
+:- type type_category
+ ---> int_type
; char_type
; str_type
; float_type
- ; pred_type
+ ; higher_order_type
; tuple_type
; enum_type
- ; polymorphic_type
- ; user_type.
+ ; variable_type
+ ; type_info_type
+ ; type_ctor_info_type
+ ; typeclass_info_type
+ ; base_typeclass_info_type
+ ; void_type
+ ; user_ctor_type.
% Given a non-variable type, return its type-id and argument types.
@@ -159,6 +176,9 @@
:- mode type_util__var(in, out) is semidet.
:- mode type_util__var(out, in) is det.
+:- pred canonicalize_type_args(type_ctor::in, list(type)::in, list(type)::out)
+ is det.
+
% Given a type_ctor and a list of argument types,
% construct a type.
@@ -182,12 +202,17 @@
:- func string_type = (type).
:- func float_type = (type).
:- func char_type = (type).
+:- func void_type = (type).
:- func c_pointer_type = (type).
:- func heap_pointer_type = (type).
:- func sample_type_info_type = (type).
:- func sample_typeclass_info_type = (type).
:- func comparison_result_type = (type).
+ % Construct type_infos and type_ctor_infos for the given types.
+:- func type_info_type(type) = (type).
+:- func type_ctor_info_type(type) = (type).
+
% Given a constant and an arity, return a type_ctor.
% Fails if the constant is not an atom.
@@ -258,7 +283,6 @@
:- pred type_util__get_cons_defn(module_info::in, type_ctor::in, cons_id::in,
hlds_cons_defn::out) is semidet.
-
% Given a type and a cons_id, look up the definition of that
% constructor; if it is existentially typed, return its definition,
% otherwise fail.
@@ -502,6 +526,7 @@
:- import_module backend_libs__foreign.
:- import_module check_hlds__purity.
+:- import_module hlds__hlds_out.
:- import_module libs__globals.
:- import_module libs__options.
:- import_module parse_tree__prog_io.
@@ -524,11 +549,25 @@
type_ctor_is_atomic(TypeCtor, ModuleInfo).
type_ctor_is_atomic(TypeCtor, ModuleInfo) :-
- classify_type_ctor(ModuleInfo, TypeCtor, BuiltinType),
- BuiltinType \= polymorphic_type,
- BuiltinType \= tuple_type,
- BuiltinType \= pred_type,
- BuiltinType \= user_type.
+ TypeCategory = classify_type_ctor(ModuleInfo, TypeCtor),
+ type_category_is_atomic(TypeCategory) = yes.
+
+:- func type_category_is_atomic(type_category) = bool.
+
+type_category_is_atomic(int_type) = yes.
+type_category_is_atomic(char_type) = yes.
+type_category_is_atomic(str_type) = yes.
+type_category_is_atomic(float_type) = yes.
+type_category_is_atomic(higher_order_type) = no.
+type_category_is_atomic(tuple_type) = no.
+type_category_is_atomic(enum_type) = yes.
+type_category_is_atomic(variable_type) = no.
+type_category_is_atomic(type_info_type) = no.
+type_category_is_atomic(type_ctor_info_type) = no.
+type_category_is_atomic(typeclass_info_type) = no.
+type_category_is_atomic(base_typeclass_info_type) = no.
+type_category_is_atomic(void_type) = yes.
+type_category_is_atomic(user_ctor_type) = no.
type_ctor_is_array(qualified(unqualified("array"), "array") - 1).
@@ -544,14 +583,32 @@
mercury_private_builtin_module(PB).
is_introduced_type_info_type(Type) :-
- sym_name_and_args(Type, TypeName, _),
- TypeName = qualified(PrivateBuiltin, Name),
+ type_to_ctor_and_args(Type, TypeCtor, _),
+ is_introduced_type_info_type_ctor(TypeCtor).
+
+is_introduced_type_info_type_ctor(TypeCtor) :-
+ TypeCtor = qualified(PrivateBuiltin, Name) - 1,
+ mercury_private_builtin_module(PrivateBuiltin),
( Name = "type_info"
; Name = "type_ctor_info"
; Name = "typeclass_info"
; Name = "base_typeclass_info"
- ),
- mercury_private_builtin_module(PrivateBuiltin).
+ ).
+
+is_introduced_type_info_type_category(int_type) = no.
+is_introduced_type_info_type_category(char_type) = no.
+is_introduced_type_info_type_category(str_type) = no.
+is_introduced_type_info_type_category(float_type) = no.
+is_introduced_type_info_type_category(higher_order_type) = no.
+is_introduced_type_info_type_category(tuple_type) = no.
+is_introduced_type_info_type_category(enum_type) = no.
+is_introduced_type_info_type_category(variable_type) = no.
+is_introduced_type_info_type_category(type_info_type) = yes.
+is_introduced_type_info_type_category(type_ctor_info_type) = yes.
+is_introduced_type_info_type_category(typeclass_info_type) = yes.
+is_introduced_type_info_type_category(base_typeclass_info_type) = yes.
+is_introduced_type_info_type_category(void_type) = no.
+is_introduced_type_info_type_category(user_ctor_type) = no.
put_typeinfo_vars_first(VarsList, VarTypes) =
TypeInfoVarsList ++ NonTypeInfoVarsList :-
@@ -569,30 +626,41 @@
% Given a type, determine what sort of type it is.
-classify_type(VarType, ModuleInfo, Type) :-
+classify_type(ModuleInfo, VarType) = TypeCategory :-
( type_to_ctor_and_args(VarType, TypeCtor, _) ->
- classify_type_ctor(ModuleInfo, TypeCtor, Type)
+ TypeCategory = classify_type_ctor(ModuleInfo, TypeCtor)
;
- Type = polymorphic_type
+ TypeCategory = variable_type
).
-classify_type_ctor(ModuleInfo, TypeCtor, Type) :-
+classify_type_ctor(ModuleInfo, TypeCtor) = TypeCategory :-
+ PrivateBuiltin = mercury_private_builtin_module,
( TypeCtor = unqualified("character") - 0 ->
- Type = char_type
+ TypeCategory = char_type
; TypeCtor = unqualified("int") - 0 ->
- Type = int_type
+ TypeCategory = int_type
; TypeCtor = unqualified("float") - 0 ->
- Type = float_type
+ TypeCategory = float_type
; TypeCtor = unqualified("string") - 0 ->
- Type = str_type
+ TypeCategory = str_type
+ ; TypeCtor = unqualified("void") - 0 ->
+ TypeCategory = void_type
+ ; TypeCtor = qualified(PrivateBuiltin, "type_info") - 1 ->
+ TypeCategory = type_info_type
+ ; TypeCtor = qualified(PrivateBuiltin, "type_ctor_info") - 1 ->
+ TypeCategory = type_ctor_info_type
+ ; TypeCtor = qualified(PrivateBuiltin, "typeclass_info") - 1 ->
+ TypeCategory = typeclass_info_type
+ ; TypeCtor = qualified(PrivateBuiltin, "base_typeclass_info") - 1 ->
+ TypeCategory = base_typeclass_info_type
; type_ctor_is_higher_order(TypeCtor, _, _, _) ->
- Type = pred_type
+ TypeCategory = higher_order_type
; type_ctor_is_tuple(TypeCtor) ->
- Type = tuple_type
+ TypeCategory = tuple_type
; type_ctor_is_enumeration(TypeCtor, ModuleInfo) ->
- Type = enum_type
+ TypeCategory = enum_type
;
- Type = user_type
+ TypeCategory = user_ctor_type
).
type_is_higher_order(Type, Purity, PredOrFunc, EvalMethod, PredArgTypes) :-
@@ -653,6 +721,24 @@
)
).
+type_has_variable_arity_ctor(Type, TypeCtor, TypeArgs) :-
+ (
+ type_is_higher_order(Type, _Purity, PredOrFunc, _,
+ TypeArgs0)
+ ->
+ TypeArgs = TypeArgs0,
+ hlds_out__pred_or_func_to_str(PredOrFunc,
+ PredOrFuncStr),
+ TypeCtor = unqualified(PredOrFuncStr) - 0
+ ;
+ type_is_tuple(Type, TypeArgs1)
+ ->
+ TypeArgs = TypeArgs1,
+ TypeCtor = unqualified("tuple") - 0
+ ;
+ fail
+ ).
+
type_ctor_is_higher_order(SymName - _Arity, Purity, PredOrFunc, EvalMethod) :-
get_purity_and_eval_method(SymName, Purity, EvalMethod, PorFStr),
(
@@ -834,6 +920,22 @@
list__length(Args, Arity)
).
+canonicalize_type_args(TypeCtor, TypeArgs0, TypeArgs) :-
+ (
+ % The arguments of typeclass_info/base_typeclass_info types
+ % are not a type - they encode class constraints.
+ % The arguments of type_ctor_info types are not types;
+ % they are type constructors.
+ % The arguments of type_info types are not true arguments:
+ % they specify the type the type_info represents.
+ % So we replace all these arguments with type `void'.
+ is_introduced_type_info_type_ctor(TypeCtor)
+ ->
+ TypeArgs = [void_type]
+ ;
+ TypeArgs = TypeArgs0
+ ).
+
construct_type(TypeCtor, Args, Type) :-
(
type_ctor_is_higher_order(TypeCtor, Purity, PredOrFunc,
@@ -909,6 +1011,9 @@
char_type = Type :-
construct_type(unqualified("character") - 0, [], Type).
+void_type = Type :-
+ construct_type(unqualified("void") - 0, [], Type).
+
c_pointer_type = Type :-
mercury_public_builtin_module(BuiltinModule),
construct_type(qualified(BuiltinModule, "c_pointer") - 0, [], Type).
@@ -932,6 +1037,16 @@
construct_type(qualified(BuiltinModule,
"comparison_result") - 0, [], Type).
+type_info_type(ForType) = Type :-
+ mercury_private_builtin_module(BuiltinModule),
+ construct_type(qualified(BuiltinModule, "type_info") - 1,
+ [ForType], Type).
+
+type_ctor_info_type(ForType) = Type :-
+ mercury_private_builtin_module(BuiltinModule),
+ construct_type(qualified(BuiltinModule, "type_ctor_info") - 1,
+ [ForType], Type).
+
%-----------------------------------------------------------------------------%
% Given a constant and an arity, return a type_ctor.
@@ -1072,7 +1187,6 @@
assoc_list__values(Args, ArgTypes0),
term__apply_substitution_to_list(ArgTypes0, TSubst, ArgTypes).
-
type_util__is_existq_cons(ModuleInfo, VarType, ConsId) :-
type_util__is_existq_cons(ModuleInfo, VarType, ConsId, _).
@@ -1296,7 +1410,6 @@
map__init(TypeSubst0),
type_unify_list(TypesA, TypesB, TypesBVars, TypeSubst0, TypeSubst).
-
arg_type_list_subsumes(TVarSet, ArgTypes, CalleeTVarSet,
CalleeExistQVars0, CalleeArgTypes0) :-
@@ -1433,8 +1546,8 @@
list__length(AsX, ArityX),
list__length(AsY, ArityY),
(
- FX = FY,
- ArityX = ArityY
+ ArityX = ArityY,
+ FX = FY
->
type_unify_list(AsX, AsY, HeadTypeParams, Bindings0, Bindings)
;
@@ -1582,7 +1695,6 @@
apply_substitutions_to_var_map_2(TVars, VarMap0,
TRenaming, TSubst, Subst, NewVarMap, VarMap)
).
-
:- pred apply_substitutions_to_var_map_2(list(tvar)::in, map(tvar,
type_info_locn)::in, tsubst::in, map(tvar, type)::in,
Index: compiler/typecheck.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/typecheck.m,v
retrieving revision 1.338
diff -u -b -r1.338 typecheck.m
--- compiler/typecheck.m 26 May 2003 09:00:11 -0000 1.338
+++ compiler/typecheck.m 26 May 2003 09:12:27 -0000
@@ -682,8 +682,9 @@
CalleeName = "no_clauses"
),
pred_info_context(PredInfo, Context),
- generate_simple_call(PrivateBuiltin, CalleeName, [PredNameVar],
- only_mode, det, no, [], ModuleInfo, Context, CallGoal),
+ generate_simple_call(PrivateBuiltin, CalleeName, predicate,
+ [PredNameVar], only_mode, det, no, [], ModuleInfo,
+ Context, CallGoal),
%
% Combine the unification and call into a conjunction
%
Index: compiler/unify_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/unify_gen.m,v
retrieving revision 1.129
diff -u -b -r1.129 unify_gen.m
--- compiler/unify_gen.m 26 May 2003 09:00:12 -0000 1.129
+++ compiler/unify_gen.m 26 May 2003 09:12:27 -0000
@@ -83,10 +83,11 @@
{ Code = empty }
)
;
- { Uni = construct(Var, ConsId, Args, Modes, _, _, AditiInfo) },
+ { Uni = construct(Var, ConsId, Args, Modes, _, _, AditiInfo,
+ Size) },
( code_info__variable_is_forward_live(Var) ->
- unify_gen__generate_construction(Var, ConsId,
- Args, Modes, AditiInfo, GoalInfo, Code)
+ unify_gen__generate_construction(Var, ConsId, Args,
+ Modes, AditiInfo, Size, GoalInfo, Code)
;
{ Code = empty }
)
@@ -337,30 +338,30 @@
:- pred unify_gen__generate_construction(prog_var::in, cons_id::in,
list(prog_var)::in, list(uni_mode)::in, maybe(rl_exprn_id)::in,
- hlds_goal_info::in, code_tree::out, code_info::in, code_info::out)
- is det.
+ maybe(term_size_value)::in, hlds_goal_info::in, code_tree::out,
+ code_info::in, code_info::out) is det.
-unify_gen__generate_construction(Var, Cons, Args, Modes, AditiInfo, GoalInfo,
- Code) -->
+unify_gen__generate_construction(Var, Cons, Args, Modes, AditiInfo, Size,
+ GoalInfo, Code) -->
code_info__cons_id_to_tag(Var, Cons, Tag),
unify_gen__generate_construction_2(Tag, Var, Args,
- Modes, AditiInfo, GoalInfo, Code).
+ Modes, AditiInfo, Size, GoalInfo, Code).
:- pred unify_gen__generate_construction_2(cons_tag::in, prog_var::in,
list(prog_var)::in, list(uni_mode)::in, maybe(rl_exprn_id)::in,
- hlds_goal_info::in, code_tree::out, code_info::in, code_info::out)
- is det.
+ maybe(term_size_value)::in, hlds_goal_info::in, code_tree::out,
+ code_info::in, code_info::out) is det.
unify_gen__generate_construction_2(string_constant(String),
- Var, _Args, _Modes, _, _, empty) -->
+ Var, _Args, _Modes, _, _, _, empty) -->
code_info__assign_const_to_var(Var, const(string_const(String))).
unify_gen__generate_construction_2(int_constant(Int),
- Var, _Args, _Modes, _, _, empty) -->
+ Var, _Args, _Modes, _, _, _, empty) -->
code_info__assign_const_to_var(Var, const(int_const(Int))).
unify_gen__generate_construction_2(float_constant(Float),
- Var, _Args, _Modes, _, _, empty) -->
+ Var, _Args, _Modes, _, _, _, empty) -->
code_info__assign_const_to_var(Var, const(float_const(Float))).
-unify_gen__generate_construction_2(no_tag, Var, Args, Modes, _, _, Code) -->
+unify_gen__generate_construction_2(no_tag, Var, Args, Modes, _, _, _, Code) -->
( { Args = [Arg], Modes = [Mode] } ->
code_info__variable_type(Arg, Type),
unify_gen__generate_sub_unify(ref(Var), ref(Arg),
@@ -370,21 +371,21 @@
"unify_gen__generate_construction_2: no_tag: arity != 1") }
).
unify_gen__generate_construction_2(single_functor,
- Var, Args, Modes, AditiInfo, GoalInfo, Code) -->
+ Var, Args, Modes, AditiInfo, Size, GoalInfo, Code) -->
% treat single_functor the same as unshared_tag(0)
unify_gen__generate_construction_2(unshared_tag(0),
- Var, Args, Modes, AditiInfo, GoalInfo, Code).
+ Var, Args, Modes, AditiInfo, Size, GoalInfo, Code).
unify_gen__generate_construction_2(unshared_tag(Ptag),
- Var, Args, Modes, _, _, Code) -->
+ Var, Args, Modes, _, Size, _, Code) -->
code_info__get_module_info(ModuleInfo),
unify_gen__var_types(Args, ArgTypes),
{ unify_gen__generate_cons_args(Args, ArgTypes, Modes, ModuleInfo,
Rvals) },
code_info__variable_type(Var, VarType),
{ unify_gen__var_type_msg(VarType, VarTypeMsg) },
- code_info__assign_cell_to_var(Var, Ptag, Rvals, VarTypeMsg, Code).
+ code_info__assign_cell_to_var(Var, Ptag, Rvals, Size, VarTypeMsg, Code).
unify_gen__generate_construction_2(shared_remote_tag(Ptag, Sectag),
- Var, Args, Modes, _, _, Code) -->
+ Var, Args, Modes, _, Size, _, Code) -->
code_info__get_module_info(ModuleInfo),
unify_gen__var_types(Args, ArgTypes),
{ unify_gen__generate_cons_args(Args, ArgTypes, Modes, ModuleInfo,
@@ -393,13 +394,13 @@
{ Rvals = [yes(const(int_const(Sectag))) | Rvals0] },
code_info__variable_type(Var, VarType),
{ unify_gen__var_type_msg(VarType, VarTypeMsg) },
- code_info__assign_cell_to_var(Var, Ptag, Rvals, VarTypeMsg, Code).
+ code_info__assign_cell_to_var(Var, Ptag, Rvals, Size, VarTypeMsg, Code).
unify_gen__generate_construction_2(shared_local_tag(Bits1, Num1),
- Var, _Args, _Modes, _, _, empty) -->
+ Var, _Args, _Modes, _, _, _, empty) -->
code_info__assign_const_to_var(Var,
mkword(Bits1, unop(mkbody, const(int_const(Num1))))).
unify_gen__generate_construction_2(type_ctor_info_constant(ModuleName,
- TypeName, TypeArity), Var, Args, _Modes, _, _, empty) -->
+ TypeName, TypeArity), Var, Args, _Modes, _, _, _, empty) -->
( { Args = [] } ->
[]
;
@@ -407,19 +408,21 @@
),
{ RttiTypeCtor = rtti_type_ctor(ModuleName, TypeName, TypeArity) },
{ DataAddr = rtti_addr(ctor_rtti_id(RttiTypeCtor, type_ctor_info)) },
- code_info__assign_const_to_var(Var, const(data_addr_const(DataAddr))).
+ code_info__assign_const_to_var(Var,
+ const(data_addr_const(DataAddr, no))).
unify_gen__generate_construction_2(base_typeclass_info_constant(ModuleName,
- ClassId, Instance), Var, Args, _Modes, _, _, empty) -->
+ ClassId, Instance), Var, Args, _Modes, _, _, _, empty) -->
( { Args = [] } ->
[]
;
{ error("unify_gen: typeclass-info constant has args") }
),
- code_info__assign_const_to_var(Var, const(data_addr_const(
- rtti_addr(tc_rtti_id(base_typeclass_info(ModuleName, ClassId,
- Instance)))))).
+ code_info__assign_const_to_var(Var,
+ const(data_addr_const(rtti_addr(tc_rtti_id(
+ base_typeclass_info(ModuleName, ClassId, Instance))),
+ no))).
unify_gen__generate_construction_2(tabling_pointer_constant(PredId, ProcId),
- Var, Args, _Modes, _, _, empty) -->
+ Var, Args, _Modes, _, _, _, empty) -->
( { Args = [] } ->
[]
;
@@ -429,28 +432,31 @@
{ ProcLabel = make_proc_label(ModuleInfo, PredId, ProcId) },
{ module_info_name(ModuleInfo, ModuleName) },
{ DataAddr = data_addr(ModuleName, tabling_pointer(ProcLabel)) },
- code_info__assign_const_to_var(Var, const(data_addr_const(DataAddr))).
+ code_info__assign_const_to_var(Var,
+ const(data_addr_const(DataAddr, no))).
unify_gen__generate_construction_2(
deep_profiling_proc_static_tag(RttiProcLabel),
- Var, Args, _Modes, _, _, empty) -->
+ Var, Args, _Modes, _, _, _, empty) -->
( { Args = [] } ->
[]
;
{ error("unify_gen: deep_profiling_proc_static has args") }
),
{ DataAddr = layout_addr(proc_static(RttiProcLabel)) },
- code_info__assign_const_to_var(Var, const(data_addr_const(DataAddr))).
+ code_info__assign_const_to_var(Var,
+ const(data_addr_const(DataAddr, no))).
unify_gen__generate_construction_2(table_io_decl_tag(RttiProcLabel),
- Var, Args, _Modes, _, _, empty) -->
+ Var, Args, _Modes, _, _, _, empty) -->
( { Args = [] } ->
[]
;
{ error("unify_gen: table_io_decl has args") }
),
{ DataAddr = layout_addr(table_io_decl(RttiProcLabel)) },
- code_info__assign_const_to_var(Var, const(data_addr_const(DataAddr))).
+ code_info__assign_const_to_var(Var,
+ const(data_addr_const(DataAddr, no))).
unify_gen__generate_construction_2(code_addr_constant(PredId, ProcId),
- Var, Args, _Modes, _, _, empty) -->
+ Var, Args, _Modes, _, _, _, empty) -->
( { Args = [] } ->
[]
;
@@ -460,7 +466,7 @@
code_info__make_entry_label(ModuleInfo, PredId, ProcId, no, CodeAddr),
code_info__assign_const_to_var(Var, const(code_addr_const(CodeAddr))).
unify_gen__generate_construction_2(reserved_address(RA),
- Var, Args, _Modes, _, _, empty) -->
+ Var, Args, _Modes, _, _, _, empty) -->
( { Args = [] } ->
[]
;
@@ -470,15 +476,15 @@
unify_gen__generate_reserved_address(RA)).
unify_gen__generate_construction_2(
shared_with_reserved_addresses(_RAs, ThisTag),
- Var, Args, Modes, AditiInfo, GoalInfo, Code) -->
+ Var, Args, Modes, AditiInfo, Size, GoalInfo, Code) -->
% For shared_with_reserved_address, the sharing is only
% important for tag tests, not for constructions,
% so here we just recurse on the real representation.
unify_gen__generate_construction_2(ThisTag,
- Var, Args, Modes, AditiInfo, GoalInfo, Code).
+ Var, Args, Modes, AditiInfo, Size, GoalInfo, Code).
unify_gen__generate_construction_2(
pred_closure_tag(PredId, ProcId, EvalMethod),
- Var, Args, _Modes, _AditiInfo, GoalInfo, Code) -->
+ Var, Args, _Modes, _AditiInfo, _, GoalInfo, Code) -->
% This code constructs or extends a closure.
% The structure of closures is defined in runtime/mercury_ho_call.h.
@@ -563,7 +569,7 @@
assign(NumOldArgs,
lval(field(yes(0), OldClosure, Two)))
- "get number of arguments",
- incr_hp(NewClosure, no,
+ incr_hp(NewClosure, no, no,
binop(+, lval(NumOldArgs),
NumNewArgsPlusThree_Rval), "closure")
- "allocate new closure",
@@ -638,7 +644,7 @@
code_info__add_static_cell_natural_types(AditiCallArgs,
CallArgsDataAddr),
{ CallArgsRval =
- const(data_addr_const(CallArgsDataAddr)) }
+ const(data_addr_const(CallArgsDataAddr, no)) }
;
{ EvalMethod = (aditi_top_down) },
% XXX Need to work out how to encode the procedure
@@ -665,10 +671,12 @@
ClosureLayoutRvalsTypes, Data) },
code_info__set_static_cell_info(StaticCellInfo),
code_info__add_closure_layout(Data),
+ % For now, closures always have zero size, and the size slot
+ % is never looked at.
code_info__add_static_cell(ClosureLayoutRvalsTypes,
ClosureDataAddr),
{ ClosureLayoutRval =
- const(data_addr_const(ClosureDataAddr)) },
+ const(data_addr_const(ClosureDataAddr, no)) },
{ list__length(Args, NumArgs) },
{ proc_info_arg_info(ProcInfo, ArgInfo) },
{ unify_gen__generate_pred_args(Args, ArgInfo, PredArgs) },
@@ -678,7 +686,8 @@
yes(const(int_const(NumArgs)))
| PredArgs
] },
- code_info__assign_cell_to_var(Var, 0, Vector, "closure", Code)
+ code_info__assign_cell_to_var(Var, 0, Vector, no, "closure",
+ Code)
).
:- pred unify_gen__generate_extra_closure_args(list(prog_var)::in, lval::in,
Index: compiler/unify_proc.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/unify_proc.m,v
retrieving revision 1.120
diff -u -b -r1.120 unify_proc.m
--- compiler/unify_proc.m 26 May 2003 09:00:13 -0000 1.120
+++ compiler/unify_proc.m 26 May 2003 09:12:27 -0000
@@ -835,8 +835,8 @@
"Cast_HeadVar", 1, CastVar1),
unify_proc__make_fresh_named_var_from_type(EqvType,
"Cast_HeadVar", 2, CastVar2),
- unify_proc__build_cast(H1, CastVar1, Context, Cast1Goal),
- unify_proc__build_cast(H2, CastVar2, Context, Cast2Goal),
+ { generate_unsafe_cast(H1, CastVar1, Context, Cast1Goal) },
+ { generate_unsafe_cast(H2, CastVar2, Context, Cast2Goal) },
{ create_atomic_unification(CastVar1, var(CastVar2), Context,
explicit, [], UnifyGoal) },
@@ -925,10 +925,10 @@
"Cast_HeadVar", 1, CastVar1),
unify_proc__make_fresh_named_var_from_type(IntType,
"Cast_HeadVar", 2, CastVar2),
- unify_proc__build_cast(H1, CastVar1, Context,
- Cast1Goal),
- unify_proc__build_cast(H2, CastVar2, Context,
- Cast2Goal),
+ { generate_unsafe_cast(H1, CastVar1, Context,
+ Cast1Goal) },
+ { generate_unsafe_cast(H2, CastVar2, Context,
+ Cast2Goal) },
unify_proc__build_call("builtin_compare_int",
[Res, CastVar1, CastVar2], Context,
CompareGoal),
@@ -1007,8 +1007,8 @@
"Cast_HeadVar", 1, CastVar1),
unify_proc__make_fresh_named_var_from_type(EqvType,
"Cast_HeadVar", 2, CastVar2),
- unify_proc__build_cast(H1, CastVar1, Context, Cast1Goal),
- unify_proc__build_cast(H2, CastVar2, Context, Cast2Goal),
+ { generate_unsafe_cast(H1, CastVar1, Context, Cast1Goal) },
+ { generate_unsafe_cast(H2, CastVar2, Context, Cast2Goal) },
unify_proc__build_call("compare", [Res, CastVar1, CastVar2],
Context, CompareGoal),
@@ -1553,15 +1553,6 @@
%-----------------------------------------------------------------------------%
-:- pred unify_proc__build_cast(prog_var, prog_var, prog_context, hlds_goal,
- unify_proc_info, unify_proc_info).
-:- mode unify_proc__build_cast(in, in, in, out, in, out) is det.
-
-unify_proc__build_cast(InArg, OutArg, Context, Goal) -->
- { goal_info_init(Context, GoalInfo) },
- { Goal = generic_call(unsafe_cast, [InArg, OutArg],
- [in_mode, out_mode], det) - GoalInfo }.
-
:- pred unify_proc__build_call(string, list(prog_var), prog_context, hlds_goal,
unify_proc_info, unify_proc_info).
:- mode unify_proc__build_call(in, in, in, out, in, out) is det.
@@ -1579,8 +1570,9 @@
;
MercuryBuiltin = mercury_private_builtin_module
},
- { goal_util__generate_simple_call(MercuryBuiltin, Name, ArgVars,
- mode_no(0), erroneous, no, [], ModuleInfo, Context, Goal) }.
+ { goal_util__generate_simple_call(MercuryBuiltin, Name, predicate,
+ ArgVars, mode_no(0), erroneous, no, [], ModuleInfo,
+ Context, Goal) }.
:- pred unify_proc__build_specific_call((type)::in, special_pred_id::in,
list(prog_var)::in, instmap_delta::in, determinism::in,
Index: compiler/unused_args.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/unused_args.m,v
retrieving revision 1.85
diff -u -b -r1.85 unused_args.m
--- compiler/unused_args.m 26 May 2003 09:00:14 -0000 1.85
+++ compiler/unused_args.m 26 May 2003 09:12:27 -0000
@@ -584,7 +584,7 @@
UseInf = UseInf2
).
-traverse_goal(_, unify(Var1, _, _, construct(_, _, Args, _, _, _, _), _),
+traverse_goal(_, unify(Var1, _, _, construct(_, _, Args, _, _, _, _, _), _),
UseInf0, UseInf) :-
( local_var_is_used(UseInf0, Var1) ->
set_list_vars_used(UseInf0, Args, UseInf)
@@ -1471,7 +1471,7 @@
% LVar unused => we don't need the unification
fixup_unify(_, UnusedVars, no, Unify, Unify) :-
- Unify = construct(LVar, _, _, _, _, _, _),
+ Unify = construct(LVar, _, _, _, _, _, _, _),
\+ list__member(LVar, UnusedVars).
fixup_unify(ModuleInfo, UnusedVars, Changed, Unify, Unify) :-
Index: compiler/use_local_vars.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/use_local_vars.m,v
retrieving revision 1.5
diff -u -b -r1.5 use_local_vars.m
--- compiler/use_local_vars.m 15 Mar 2003 03:09:14 -0000 1.5
+++ compiler/use_local_vars.m 3 Apr 2003 14:36:14 -0000
@@ -213,7 +213,7 @@
Instr0 = Uinstr0 - _Comment0,
(
( Uinstr0 = assign(ToLval, _FromRval)
- ; Uinstr0 = incr_hp(ToLval, _MaybeTag, _SizeRval, _Type)
+ ; Uinstr0 = incr_hp(ToLval, _MaybeTag, _SizeRval, _MO, _Type)
),
base_lval_worth_replacing(NumRealRRegs, ToLval)
->
@@ -359,10 +359,10 @@
require(unify(ToLval, OldLval),
"substitute_lval_in_defn: mismatch in assign"),
Uinstr = assign(NewLval, FromRval)
- ; Uinstr0 = incr_hp(ToLval, MaybeTag, SizeRval, Type) ->
+ ; Uinstr0 = incr_hp(ToLval, MaybeTag, SizeRval, MO, Type) ->
require(unify(ToLval, OldLval),
"substitute_lval_in_defn: mismatch in incr_hp"),
- Uinstr = incr_hp(NewLval, MaybeTag, SizeRval, Type)
+ Uinstr = incr_hp(NewLval, MaybeTag, SizeRval, MO, Type)
;
error("substitute_lval_in_defn: unexpected instruction")
),
@@ -461,7 +461,7 @@
Instr0, Instr, N0, N),
Instrs = Instrs0
;
- Uinstr0 = incr_hp(Lval, _, _, _),
+ Uinstr0 = incr_hp(Lval, _, _, _, _),
( Lval = OldLval ->
% If we alter any lval that occurs in OldLval,
% we must stop the substitutions. At the
Index: compiler/var_locn.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/var_locn.m,v
retrieving revision 1.10
diff -u -b -r1.10 var_locn.m
--- compiler/var_locn.m 9 May 2003 05:51:52 -0000 1.10
+++ compiler/var_locn.m 22 May 2003 06:12:13 -0000
@@ -20,6 +20,7 @@
:- interface.
:- import_module parse_tree__prog_data.
+:- import_module hlds__hlds_goal.
:- import_module hlds__hlds_llds.
:- import_module ll_backend__global_data.
:- import_module ll_backend__llds.
@@ -159,8 +160,8 @@
% and updates the state of VarLocnInfo0 accordingly.
:- pred var_locn__assign_cell_to_var(prog_var::in, tag::in,
- list(maybe(rval))::in, string::in, code_tree::out,
- static_cell_info::in, static_cell_info::out,
+ list(maybe(rval))::in, maybe(term_size_value)::in, string::in,
+ code_tree::out, static_cell_info::in, static_cell_info::out,
var_locn_info::in, var_locn_info::out) is det.
% var_locn__place_var(Var, Lval, Code, VarLocnInfo0, VarLocnInfo)
@@ -678,7 +679,11 @@
(
{ MaybeConstBaseVarRval = yes(BaseVarRval) },
{ BaseVarRval = mkword(Ptag, BaseConst) },
- { BaseConst = const(data_addr_const(DataAddr)) },
+ { BaseConst = const(data_addr_const(DataAddr,
+ MaybeBaseOffset)) },
+ % XXX We could drop the MaybeBaseOffset = no condition,
+ % but this would require more complex code below.
+ { MaybeBaseOffset = no },
{ search_static_cell(StaticCellInfo, DataAddr,
StaticCellArgsTypes) }
->
@@ -790,8 +795,24 @@
%----------------------------------------------------------------------------%
-var_locn__assign_cell_to_var(Var, Ptag, MaybeRvals, TypeMsg, Code,
+var_locn__assign_cell_to_var(Var, Ptag, MaybeRvals0, SizeInfo, TypeMsg, Code,
!StaticCellInfo, !VarLocn) :-
+ (
+ SizeInfo = yes(SizeSource),
+ (
+ SizeSource = known_size(Size),
+ SizeRval = const(int_const(Size))
+ ;
+ SizeSource = dynamic_size(SizeVar),
+ SizeRval = var(SizeVar)
+ ),
+ MaybeRvals = [yes(SizeRval) | MaybeRvals0],
+ MaybeOffset = yes(1)
+ ;
+ SizeInfo = no,
+ MaybeRvals = MaybeRvals0,
+ MaybeOffset = no
+ ),
var_locn__get_var_state_map(VarStateMap, !VarLocn),
var_locn__get_exprn_opts(ExprnOpts, !VarLocn),
(
@@ -799,30 +820,41 @@
MaybeRvals, RvalsTypes)
->
add_static_cell(RvalsTypes, DataAddr, !StaticCellInfo),
- CellRval = mkword(Ptag, const(data_addr_const(DataAddr))),
- var_locn__assign_const_to_var(Var, CellRval, !VarLocn),
+ CellPtrRval = mkword(Ptag, const(
+ data_addr_const(DataAddr, MaybeOffset))),
+ var_locn__assign_const_to_var(Var, CellPtrRval, !VarLocn),
Code = empty
;
var_locn__assign_dynamic_cell_to_var(Var, Ptag, MaybeRvals,
- TypeMsg, Code, !VarLocn)
+ MaybeOffset, TypeMsg, Code, !VarLocn)
).
:- pred var_locn__assign_dynamic_cell_to_var(prog_var::in, tag::in,
- list(maybe(rval))::in, string::in, code_tree::out,
+ list(maybe(rval))::in, maybe(int)::in, string::in, code_tree::out,
var_locn_info::in, var_locn_info::out) is det.
-var_locn__assign_dynamic_cell_to_var(Var, Ptag, Vector, TypeMsg, Code) -->
+var_locn__assign_dynamic_cell_to_var(Var, Ptag, Vector, MaybeOffset,
+ TypeMsg, Code) -->
var_locn__check_var_is_unknown(Var),
var_locn__select_preferred_reg_or_stack(Var, Lval),
var_locn__get_var_name(Var, VarName),
{ list__length(Vector, Size) },
{ CellCode = node([
- incr_hp(Lval, yes(Ptag), const(int_const(Size)), TypeMsg)
+ incr_hp(Lval, yes(Ptag), MaybeOffset, const(int_const(Size)),
+ TypeMsg)
- string__append("Allocating heap for ", VarName)
]) },
var_locn__set_magic_var_location(Var, Lval),
- var_locn__assign_cell_args(Vector, yes(Ptag), lval(Lval), 0, ArgsCode),
+ {
+ MaybeOffset = yes(Offset),
+ StartOffset = -Offset
+ ;
+ MaybeOffset = no,
+ StartOffset = 0
+ },
+ var_locn__assign_cell_args(Vector, yes(Ptag), lval(Lval), StartOffset,
+ ArgsCode),
{ Code = tree(CellCode, ArgsCode) }.
:- pred var_locn__assign_cell_args(list(maybe(rval))::in,
cvs diff: Diffing compiler/notes
Index: compiler/notes/compiler_design.html
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/notes/compiler_design.html,v
retrieving revision 1.85
diff -u -b -r1.85 compiler_design.html
--- compiler/notes/compiler_design.html 7 May 2003 06:32:34 -0000 1.85
+++ compiler/notes/compiler_design.html 9 May 2003 02:11:47 -0000
@@ -691,8 +691,8 @@
<p>
-The last HLDS-to-HLDS transformation implements deep profiling
-(deep_profiling.m).
+The last two HLDS-to-HLDS transformations implement term size profiling
+(size_prof.m) and deep profiling (deep_profiling.m).
<p>
<hr>
cvs diff: Diffing debian
cvs diff: Diffing deep_profiler
cvs diff: Diffing deep_profiler/notes
cvs diff: Diffing doc
Index: doc/Mmakefile
===================================================================
RCS file: /home/mercury1/repository/mercury/doc/Mmakefile,v
retrieving revision 1.34
diff -u -b -r1.34 Mmakefile
--- doc/Mmakefile 24 Jan 2003 07:17:09 -0000 1.34
+++ doc/Mmakefile 25 Mar 2003 13:58:41 -0000
@@ -220,6 +220,8 @@
;; \
$(LIBRARY_DIR)/table_builtin.m) \
;; \
+ $(LIBRARY_DIR)/term_size_prof_builtin.m) \
+ ;; \
*) \
echo "* `basename $$filename .m`::"; \
;; \
@@ -239,6 +241,8 @@
$(LIBRARY_DIR)/rtti_implementation.m) \
;; \
$(LIBRARY_DIR)/table_builtin.m) \
+ ;; \
+ $(LIBRARY_DIR)/term_size_prof_builtin.m) \
;; \
*) \
file="`basename $$filename .m`"; \
Index: doc/user_guide.texi
===================================================================
RCS file: /home/mercury1/repository/mercury/doc/user_guide.texi,v
retrieving revision 1.370
diff -u -b -r1.370 user_guide.texi
--- doc/user_guide.texi 14 May 2003 04:05:44 -0000 1.370
+++ doc/user_guide.texi 26 May 2003 16:19:57 -0000
@@ -3186,6 +3186,14 @@
of the Mercury implementation.
@sp 1
@table @code
+ at c @item term_size @var{name}
+ at c @itemx term_size @var{num}
+ at c @itemx term_size *
+ at c @kindex term_size (mdb command)
+ at c In term size profiling grades, prints the size of the term
+ at c bound to the specified variable(s).
+ at c In other grades, reports an error.
+ at c @sp 1
@item flag @var{flagname}
@kindex flag (mdb command)
Prints the value of the specified runtime lowlevel debugging flag.
@@ -4698,7 +4706,7 @@
r - resume points of goals,
s - store maps of goals,
t - results of termination analysis,
-u - unification categories,
+u - unification categories and other implementation details of unifications,
v - variable numbers in variable names,
A - argument passing information,
C - clause information,
@@ -5086,6 +5094,10 @@
@findex --profiling
@findex --memory-profiling
@findex --deep-profiling
+ at c The following are undocumented because they are not yet useful,
+ at c and thus are not yet for public consumption.
+ at c @findex --record-term-sizes-as-words
+ at c @findex --record-term-sizes-as-cells
@item @samp{none}
@code{--target c --no-gcc-global-registers --no-gcc-nonlocal-gotos --no-asm-labels}.
@@ -5153,6 +5165,14 @@
@item @samp{.tr}
@code{--use-trail}.
+ at c The following are undocumented because they are not yet useful,
+ at c and thus are not yet for public consumption.
+ at c @item @samp{.tsw}
+ at c @code{--record-term-sizes-as-words}.
+ at c
+ at c @item @samp{.tsc}
+ at c @code{--record-term-sizes-as-cells}.
+
@item @samp{.rt}
@code{--reserve-tag}.
@@ -5368,6 +5388,19 @@
is that the former method can give slightly more accurate timing results.
because with the latter method the code inserted to record call counts
has a small effect on the execution speed.
+
+ at ignore
+ The following are not yet useful, and hence undocumented.
+
+ at sp 1
+ at item @code{--record-term-sizes-as-words} (grades: any grade containing @samp{.tsw})
+ at findex --record-term-sizes-as-words
+Record the sizes of terms, using one word as the unit of memory.
+
+ at sp 1
+ at item @code{--record-term-sizes-as-cells} (grades: any grade containing @samp{.tsc})
+ at findex --record-term-sizes-as-cells
+Record the sizes of terms, using one cell as the unit of memory.
@end ignore
cvs diff: Diffing extras
cvs diff: Diffing extras/aditi
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/concurrency
cvs diff: Diffing extras/curs
cvs diff: Diffing extras/curs/samples
cvs diff: Diffing extras/curses
cvs diff: Diffing extras/curses/sample
cvs diff: Diffing extras/dynamic_linking
cvs diff: Diffing extras/error
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/lazy_evaluation
cvs diff: Diffing extras/lex
cvs diff: Diffing extras/lex/samples
cvs diff: Diffing extras/lex/tests
cvs diff: Diffing extras/logged_output
cvs diff: Diffing extras/moose
cvs diff: Diffing extras/moose/samples
cvs diff: Diffing extras/morphine
cvs diff: Diffing extras/morphine/non-regression-tests
cvs diff: Diffing extras/morphine/scripts
cvs diff: Diffing extras/morphine/source
cvs diff: Diffing extras/odbc
cvs diff: Diffing extras/posix
cvs diff: Diffing extras/quickcheck
cvs diff: Diffing extras/quickcheck/tutes
cvs diff: Diffing extras/references
cvs diff: Diffing extras/references/samples
cvs diff: Diffing extras/references/tests
cvs diff: Diffing extras/stream
cvs diff: Diffing extras/trailed_update
cvs diff: Diffing extras/trailed_update/samples
cvs diff: Diffing extras/trailed_update/tests
cvs diff: Diffing extras/xml
cvs diff: Diffing extras/xml/samples
cvs diff: Diffing gcc
cvs diff: Diffing gcc/mercury
cvs diff: Diffing java
cvs diff: Diffing java/library
cvs diff: Diffing java/runtime
cvs diff: Diffing library
Index: library/array.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/array.m,v
retrieving revision 1.122
diff -u -b -r1.122 array.m
--- library/array.m 26 May 2003 09:00:27 -0000 1.122
+++ library/array.m 26 May 2003 09:12:31 -0000
@@ -764,16 +764,17 @@
array__init_2(Size::in, Item::in, Array::array_uo),
[will_not_call_mercury, promise_pure, thread_safe],
"
- MR_incr_hp_msg(Array, Size + 1, MR_PROC_LABEL, ""array:array/1"");
- ML_init_array((MR_ArrayType *)Array, Size, Item);
+ MR_offset_incr_hp_msg(Array, 0, Size + 1,
+ MR_PROC_LABEL, ""array:array/1"");
+ ML_init_array((MR_ArrayType *) Array, Size, Item);
").
:- pragma foreign_proc("C",
array__make_empty_array(Array::array_uo),
[will_not_call_mercury, promise_pure, thread_safe],
"
- MR_incr_hp_msg(Array, 1, MR_PROC_LABEL, ""array:array/1"");
- ML_init_array((MR_ArrayType *)Array, 0, 0);
+ MR_offset_incr_hp_msg(Array, 0, 1, MR_PROC_LABEL, ""array:array/1"");
+ ML_init_array((MR_ArrayType *) Array, 0, 0);
").
:- pragma foreign_proc("C#",
@@ -836,13 +837,13 @@
array__max(Array::array_ui, Max::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
- Max = ((MR_ArrayType *)Array)->size - 1;
+ Max = ((MR_ArrayType *) Array)->size - 1;
").
:- pragma foreign_proc("C",
array__max(Array::in, Max::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
- Max = ((MR_ArrayType *)Array)->size - 1;
+ Max = ((MR_ArrayType *) Array)->size - 1;
").
:- pragma foreign_proc("C#",
array__max(Array::array_ui, Max::out),
@@ -875,13 +876,13 @@
array__size(Array::array_ui, Max::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
- Max = ((MR_ArrayType *)Array)->size;
+ Max = ((MR_ArrayType *) Array)->size;
").
:- pragma foreign_proc("C",
array__size(Array::in, Max::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
- Max = ((MR_ArrayType *)Array)->size;
+ Max = ((MR_ArrayType *) Array)->size;
").
:- pragma foreign_proc("C#",
@@ -944,14 +945,14 @@
array__unsafe_lookup(Array::array_ui, Index::in, Item::out),
[will_not_call_mercury, promise_pure, thread_safe],
"{
- MR_ArrayType *array = (MR_ArrayType *)Array;
+ MR_ArrayType *array = (MR_ArrayType *) Array;
Item = array->elements[Index];
}").
:- pragma foreign_proc("C",
array__unsafe_lookup(Array::in, Index::in, Item::out),
[will_not_call_mercury, promise_pure, thread_safe],
"{
- MR_ArrayType *array = (MR_ArrayType *)Array;
+ MR_ArrayType *array = (MR_ArrayType *) Array;
Item = array->elements[Index];
}").
@@ -985,7 +986,7 @@
Item::in, Array::array_uo),
[will_not_call_mercury, promise_pure, thread_safe],
"{
- MR_ArrayType *array = (MR_ArrayType *)Array0;
+ MR_ArrayType *array = (MR_ArrayType *) Array0;
array->elements[Index] = Item; /* destructive update! */
Array = Array0;
}").
@@ -1048,10 +1049,10 @@
Array::array_uo),
[will_not_call_mercury, promise_pure, thread_safe],
"
- if (((MR_ArrayType *)Array0)->size == Size) {
+ if (((MR_ArrayType *) Array0)->size == Size) {
Array = Array0;
} else {
- MR_incr_hp_msg(Array, Size + 1, MR_PROC_LABEL,
+ MR_offset_incr_hp_msg(Array, 0, Size + 1, MR_PROC_LABEL,
""array:array/1"");
ML_resize_array((MR_ArrayType *) Array,
(MR_ArrayType *) Array0, Size, Item);
@@ -1134,8 +1135,9 @@
array__shrink_2(Array0::array_di, Size::in, Array::array_uo),
[will_not_call_mercury, promise_pure, thread_safe],
"
- MR_incr_hp_msg(Array, Size + 1, MR_PROC_LABEL, ""array:array/1"");
- ML_shrink_array((MR_ArrayType *)Array, (MR_ArrayType *) Array0,
+ MR_offset_incr_hp_msg(Array, 0, Size + 1,
+ MR_PROC_LABEL, ""array:array/1"");
+ ML_shrink_array((MR_ArrayType *) Array, (MR_ArrayType *) Array0,
Size);
").
@@ -1183,7 +1185,8 @@
array__copy(Array0::array_ui, Array::array_uo),
[will_not_call_mercury, promise_pure, thread_safe],
"
- MR_incr_hp_msg(Array, (((const MR_ArrayType *) Array0)->size) + 1,
+ MR_offset_incr_hp_msg(Array, 0,
+ (((const MR_ArrayType *) Array0)->size) + 1,
MR_PROC_LABEL, ""array:array/1"");
ML_copy_array((MR_ArrayType *) Array, (const MR_ArrayType *) Array0);
").
@@ -1192,7 +1195,8 @@
array__copy(Array0::in, Array::array_uo),
[will_not_call_mercury, promise_pure, thread_safe],
"
- MR_incr_hp_msg(Array, (((const MR_ArrayType *) Array0)->size) + 1,
+ MR_offset_incr_hp_msg(Array, 0,
+ (((const MR_ArrayType *) Array0)->size) + 1,
MR_PROC_LABEL, ""array:array/1"");
ML_copy_array((MR_ArrayType *) Array, (const MR_ArrayType *) Array0);
").
Index: library/benchmarking.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/benchmarking.m,v
retrieving revision 1.54
diff -u -b -r1.54 benchmarking.m
--- library/benchmarking.m 22 Feb 2003 11:17:34 -0000 1.54
+++ library/benchmarking.m 9 Apr 2003 07:50:10 -0000
@@ -745,9 +745,12 @@
:- impure pred new_int_reference(int::in, int_reference::out) is det.
:- pragma inline(new_int_reference/2).
:- pragma foreign_proc("C",
- new_int_reference(X::in, Ref::out), [will_not_call_mercury],
+ new_int_reference(X::in, Ref::out),
+ [will_not_call_mercury],
"
- MR_incr_hp(Ref, 1);
+ MR_offset_incr_hp_msg(Ref, MR_SIZE_SLOT_SIZE, MR_SIZE_SLOT_SIZE + 1,
+ MR_PROC_LABEL, ""benchmarking:int_reference/1"");
+ MR_define_size_slot(0, Ref, 1);
* (MR_Integer *) Ref = X;
").
@@ -759,7 +762,8 @@
:- semipure pred ref_value(int_reference::in, int::out) is det.
:- pragma inline(ref_value/2).
:- pragma promise_semipure(ref_value/2).
-:- pragma foreign_proc("C", ref_value(Ref::in, X::out),
+:- pragma foreign_proc("C",
+ ref_value(Ref::in, X::out),
[will_not_call_mercury],
"
X = * (MR_Integer *) Ref;
@@ -768,7 +772,9 @@
:- impure pred update_ref(int_reference::in, T::in) is det.
:- pragma inline(update_ref/2).
:- pragma foreign_proc("C",
- update_ref(Ref::in, X::in), [will_not_call_mercury], "
+ update_ref(Ref::in, X::in),
+ [will_not_call_mercury],
+"
* (MR_Integer *) Ref = X;
").
Index: library/construct.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/construct.m,v
retrieving revision 1.11
diff -u -b -r1.11 construct.m
--- library/construct.m 22 Feb 2003 11:17:34 -0000 1.11
+++ library/construct.m 9 Apr 2003 08:20:03 -0000
@@ -1,3 +1,4 @@
+% vim: ft=mercury ts=4 sw=4 et
%-----------------------------------------------------------------------------%
% Copyright (C) 2002-2003 The University of Melbourne.
% This file may only be copied under the terms of the GNU Library General
@@ -150,8 +151,7 @@
} else {
MR_save_transient_registers();
TypeInfoList = MR_pseudo_type_info_vector_to_type_info_list(
- arity,
- MR_TYPEINFO_GET_FIXED_ARITY_ARG_VECTOR(type_info),
+ arity, MR_TYPEINFO_GET_FIXED_ARITY_ARG_VECTOR(type_info),
construct_info.arg_pseudo_type_infos);
MR_restore_transient_registers();
}
@@ -229,12 +229,13 @@
MR_TYPEINFO_GET_TYPE_CTOR_INFO(type_info)))
{
int i;
+
MR_save_transient_registers();
TypeInfoList = MR_type_params_vector_to_list(Arity,
MR_TYPEINFO_GET_VAR_ARITY_ARG_VECTOR(type_info));
ArgNameList = MR_list_empty();
for (i = 0; i < Arity; i++) {
- ArgNameList = MR_list_cons_msg((MR_Word) NULL,
+ ArgNameList = MR_string_list_cons_msg((MR_Word) NULL,
ArgNameList, MR_PROC_LABEL);
}
MR_restore_transient_registers();
@@ -243,8 +244,8 @@
TypeInfoList = MR_pseudo_type_info_vector_to_type_info_list(
arity, MR_TYPEINFO_GET_FIXED_ARITY_ARG_VECTOR(type_info),
construct_info.arg_pseudo_type_infos);
- ArgNameList = MR_arg_name_vector_to_list(
- arity, construct_info.arg_names);
+ ArgNameList = MR_arg_name_vector_to_list(arity,
+ construct_info.arg_names);
MR_restore_transient_registers();
}
}
@@ -387,8 +388,7 @@
for (i = 0; i < total_reserved_addrs; i++) {
functor_desc = ra_layout->MR_ra_constants[i];
- if (functor_desc->MR_ra_functor_ordinal == FunctorNumber)
- {
+ if (functor_desc->MR_ra_functor_ordinal == FunctorNumber) {
new_data = (MR_Word)
functor_desc->MR_ra_functor_reserved_addr;
@@ -412,6 +412,9 @@
MR_Word arg_list;
MR_Word ptag;
MR_Word arity;
+ MR_Word arg_data;
+ MR_TypeInfo arg_type_info;
+ int size;
int i;
functor_desc = construct_info.functor_info.du_functor_desc;
@@ -423,6 +426,7 @@
arg_list = ArgList;
ptag = functor_desc->MR_du_functor_primary;
switch (functor_desc->MR_du_functor_sectag_locn) {
+
case MR_SECTAG_LOCAL:
new_data = (MR_Word) MR_mkword(ptag,
MR_mkbody((MR_Word)
@@ -432,36 +436,51 @@
case MR_SECTAG_REMOTE:
arity = functor_desc->MR_du_functor_orig_arity;
- MR_tag_incr_hp_msg(new_data, ptag, arity + 1,
+ MR_tag_offset_incr_hp_msg(new_data, ptag,
+ MR_SIZE_SLOT_SIZE, MR_SIZE_SLOT_SIZE + 1 + arity,
MR_PROC_LABEL, ""<created by construct:construct/3>"");
+ size = MR_cell_size(arity);
MR_field(ptag, new_data, 0) =
functor_desc->MR_du_functor_secondary;
for (i = 0; i < arity; i++) {
- MR_field(ptag, new_data, i + 1) =
- MR_field(MR_UNIV_TAG,
+ arg_data = MR_field(MR_UNIV_TAG,
MR_list_head(arg_list),
MR_UNIV_OFFSET_FOR_DATA);
+ arg_type_info = (MR_TypeInfo) MR_field(MR_UNIV_TAG,
+ MR_list_head(arg_list),
+ MR_UNIV_OFFSET_FOR_TYPEINFO);
+ MR_field(ptag, new_data, i + 1) = arg_data;
+ size += MR_term_size(arg_type_info, arg_data);
arg_list = MR_list_tail(arg_list);
}
+ MR_define_size_slot(ptag, new_data, size);
break;
case MR_SECTAG_NONE:
arity = functor_desc->MR_du_functor_orig_arity;
- MR_tag_incr_hp_msg(new_data, ptag, arity,
+ MR_tag_offset_incr_hp_msg(new_data, ptag,
+ MR_SIZE_SLOT_SIZE, MR_SIZE_SLOT_SIZE + arity,
MR_PROC_LABEL, ""<created by construct:construct/3>"");
+ size = MR_cell_size(arity);
for (i = 0; i < arity; i++) {
- MR_field(ptag, new_data, i) =
- MR_field(MR_UNIV_TAG,
+ arg_data = MR_field(MR_UNIV_TAG,
MR_list_head(arg_list),
MR_UNIV_OFFSET_FOR_DATA);
+ arg_type_info = (MR_TypeInfo) MR_field(MR_UNIV_TAG,
+ MR_list_head(arg_list),
+ MR_UNIV_OFFSET_FOR_TYPEINFO);
+ MR_field(ptag, new_data, i) = arg_data;
+ size += MR_term_size(arg_type_info, arg_data);
arg_list = MR_list_tail(arg_list);
}
+ MR_define_size_slot(ptag, new_data, size);
break;
+
case MR_SECTAG_VARIABLE:
MR_fatal_error(""construct(): cannot construct variable"");
}
@@ -476,24 +495,35 @@
{
int arity;
int i;
+ int size;
MR_Word arg_list;
+ MR_Word arg_data;
+ MR_TypeInfo arg_type_info;
arity = MR_TYPEINFO_GET_VAR_ARITY_ARITY(type_info);
if (arity == 0) {
new_data = (MR_Word) NULL;
} else {
- MR_incr_hp_msg(new_data, arity, MR_PROC_LABEL,
+ MR_offset_incr_hp_msg(new_data, MR_SIZE_SLOT_SIZE,
+ MR_SIZE_SLOT_SIZE + arity, MR_PROC_LABEL,
""<created by construct:construct/3>"");
+ size = MR_cell_size(arity);
arg_list = ArgList;
for (i = 0; i < arity; i++) {
- MR_field(MR_mktag(0), new_data, i) =
- MR_field(MR_UNIV_TAG, MR_list_head(arg_list),
+ arg_data = MR_field(MR_UNIV_TAG,
+ MR_list_head(arg_list),
MR_UNIV_OFFSET_FOR_DATA);
+ arg_type_info = (MR_TypeInfo) MR_field(MR_UNIV_TAG,
+ MR_list_head(arg_list),
+ MR_UNIV_OFFSET_FOR_TYPEINFO);
+ MR_field(MR_mktag(0), new_data, i) = arg_data;
+ size += MR_term_size(arg_type_info, arg_data);
arg_list = MR_list_tail(arg_list);
}
+ MR_define_size_slot(MR_mktag(0), new_data, size);
if (! MR_list_is_empty(arg_list)) {
MR_fatal_error(
""excess arguments in construct:construct"");
@@ -531,8 +561,10 @@
"{
MR_TypeInfo type_info;
MR_Word new_data;
- MR_Word arg_value;
int i;
+ MR_Word arg_data;
+ MR_TypeInfo arg_type_info;
+ int size;
/*
** Construct a type_info for the tuple.
@@ -548,15 +580,24 @@
if (Arity == 0) {
new_data = (MR_Word) NULL;
} else {
- MR_incr_hp_msg(new_data, Arity, MR_PROC_LABEL,
+ MR_offset_incr_hp_msg(new_data, MR_SIZE_SLOT_SIZE,
+ MR_SIZE_SLOT_SIZE + Arity, MR_PROC_LABEL,
""<created by construct:construct_tuple/1>"");
+
+ size = MR_cell_size(Arity);
for (i = 0; i < Arity; i++) {
- arg_value = MR_field(MR_UNIV_TAG,
+ arg_data = MR_field(MR_UNIV_TAG,
MR_list_head(Args),
MR_UNIV_OFFSET_FOR_DATA);
- MR_field(MR_mktag(0), new_data, i) = arg_value;
+ arg_type_info = (MR_TypeInfo) MR_field(MR_UNIV_TAG,
+ MR_list_head(Args),
+ MR_UNIV_OFFSET_FOR_TYPEINFO);
+ MR_field(MR_mktag(0), new_data, i) = arg_data;
+ size += MR_term_size(arg_type_info, arg_data);
Args = MR_list_tail(Args);
}
+
+ MR_define_size_slot(MR_mktag(0), new_data, size);
}
/*
Index: library/deconstruct.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/deconstruct.m,v
retrieving revision 1.25
diff -u -b -r1.25 deconstruct.m
--- library/deconstruct.m 30 Apr 2003 10:59:38 -0000 1.25
+++ library/deconstruct.m 9 May 2003 02:10:00 -0000
@@ -1109,9 +1109,8 @@
functor_desc->MR_du_functor_arg_types[i]);
}
- MR_new_univ_on_hp(arg,
- arg_type_info, arg_vector[i]);
- Args = MR_list_cons_msg(arg, Args, MR_PROC_LABEL);
+ MR_new_univ_on_hp(arg, arg_type_info, arg_vector[i]);
+ Args = MR_univ_list_cons_msg(arg, Args, MR_PROC_LABEL);
}
break;
Index: library/io.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/io.m,v
retrieving revision 1.297
diff -u -b -r1.297 io.m
--- library/io.m 26 May 2003 09:00:29 -0000 1.297
+++ library/io.m 26 May 2003 09:12:31 -0000
@@ -1702,8 +1702,8 @@
}
}
if (Res == 0) {
- MR_incr_hp_atomic_msg(MR_LVALUE_CAST(MR_Word, RetString),
- ML_IO_BYTES_TO_WORDS((i + 1) * sizeof(MR_Char)),
+ MR_offset_incr_hp_atomic_msg(MR_LVALUE_CAST(MR_Word, RetString),
+ 0, ML_IO_BYTES_TO_WORDS((i + 1) * sizeof(MR_Char)),
MR_PROC_LABEL, ""string:string/0"");
memcpy(RetString, read_buffer, i * sizeof(MR_Char));
RetString[i] = '\\0';
@@ -2110,7 +2110,7 @@
[will_not_call_mercury, promise_pure, tabled_for_io, thread_safe],
"{
MR_Word buf;
- MR_incr_hp_atomic_msg(buf,
+ MR_offset_incr_hp_atomic_msg(buf, 0,
(Size * sizeof(MR_Char) + sizeof(MR_Word) - 1)
/ sizeof(MR_Word),
MR_PROC_LABEL, ""io:buffer/0"");
@@ -2137,17 +2137,16 @@
#else
if (Buffer0 + OldSize == (MR_Char *) MR_hp) {
MR_Word next;
- MR_incr_hp_atomic_msg(next,
+ MR_offset_incr_hp_atomic_msg(next, 0,
(NewSize * sizeof(MR_Char) + sizeof(MR_Word) - 1)
/ sizeof(MR_Word),
- MR_PROC_LABEL,
- ""io:buffer/0"");
+ MR_PROC_LABEL, ""io:buffer/0"");
assert(Buffer0 + OldSize == (MR_Char *) next);
Buffer = Buffer0;
} else {
/* just have to alloc and copy */
MR_Word buf;
- MR_incr_hp_atomic_msg(buf,
+ MR_offset_incr_hp_atomic_msg(buf, 0,
(NewSize * sizeof(MR_Char) + sizeof(MR_Word) - 1)
/ sizeof(MR_Word),
MR_PROC_LABEL, ""io:buffer/0"");
@@ -5251,8 +5250,10 @@
MR_update_io(IO0, IO);
").
-:- pragma foreign_proc("MC++", io__close_stream(Stream::in, IO0::di, IO::uo),
- [may_call_mercury, promise_pure, tabled_for_io, thread_safe], "
+:- pragma foreign_proc("MC++",
+ io__close_stream(Stream::in, IO0::di, IO::uo),
+ [may_call_mercury, promise_pure, tabled_for_io, thread_safe],
+"
MR_MercuryFile mf = ML_DownCast(MR_MercuryFile,
MR_word_to_c_pointer(Stream));
mercury_close(mf);
@@ -5263,8 +5264,7 @@
:- pragma foreign_proc("C",
io__progname(DefaultProgname::in, PrognameOut::out, IO0::di, IO::uo),
- [will_not_call_mercury, promise_pure, tabled_for_io,
- thread_safe],
+ [will_not_call_mercury, promise_pure, tabled_for_io, thread_safe],
"
if (MR_progname) {
/*
@@ -5286,19 +5286,19 @@
:- pragma foreign_proc("C",
io__command_line_arguments(Args::out, IO0::di, IO::uo),
- [will_not_call_mercury, promise_pure, tabled_for_io,
- thread_safe],
-"
+ [will_not_call_mercury, promise_pure, tabled_for_io, thread_safe],
+"{
+ int i;
+
/* convert mercury_argv from a vector to a list */
- { int i = mercury_argc;
+ i = mercury_argc;
Args = MR_list_empty_msg(MR_PROC_LABEL);
while (--i >= 0) {
- Args = MR_list_cons_msg((MR_Word) mercury_argv[i], Args,
+ Args = MR_string_list_cons_msg((MR_Word) mercury_argv[i], Args,
MR_PROC_LABEL);
}
- }
MR_update_io(IO0, IO);
-").
+}").
:- pragma foreign_proc("C",
io__get_exit_status(ExitStatus::out, IO0::di, IO::uo),
@@ -5404,7 +5404,7 @@
MR_list_nil(Args);
// We don't get the 0th argument: it is the executable name
while (--i > 0) {
- MR_list_cons(Args, arg_vector[i], Args);
+ MR_string_list_cons(Args, arg_vector[i], Args);
}
MR_update_io(IO0, IO);
").
@@ -5615,7 +5615,7 @@
len = strlen(Dir) + 1 + 5 + 3 + 1 + 3 + 1;
/* Dir + / + Prefix + counter_high + . + counter_low + \\0 */
- MR_incr_hp_atomic_msg(MR_LVALUE_CAST(MR_Word, FileName),
+ MR_offset_incr_hp_atomic_msg(MR_LVALUE_CAST(MR_Word, FileName), 0,
(len + sizeof(MR_Word)) / sizeof(MR_Word),
MR_PROC_LABEL, ""string:string/0"");
if (ML_io_tempnam_counter == 0) {
@@ -5729,7 +5729,7 @@
** This is defined as a macro rather than a C function
** to avoid worrying about the `hp' register being
** invalidated by the function call.
-** It also needs to be a macro because MR_incr_hp_atomic_msg()
+** It also needs to be a macro because MR_offset_incr_hp_atomic_msg()
** stringizes the procname argument.
*/
#define ML_maybe_make_err_msg(was_error, msg, procname, error_msg) \\
@@ -5741,7 +5741,7 @@
if (was_error) { \\
errno_msg = strerror(errno); \\
total_len = strlen(msg) + strlen(errno_msg); \\
- MR_incr_hp_atomic_msg(tmp, \\
+ MR_offset_incr_hp_atomic_msg(tmp, 0, \\
(total_len + sizeof(MR_Word)) \\
/ sizeof(MR_Word), \\
procname, \\
Index: library/library.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/library.m,v
retrieving revision 1.68
diff -u -b -r1.68 library.m
--- library/library.m 3 Mar 2003 03:29:37 -0000 1.68
+++ library/library.m 24 Mar 2003 16:13:50 -0000
@@ -30,21 +30,80 @@
% Please keep both parts of this list in alphabetical order.
% The modules intended for application programmers.
-:- import_module array, array2d, assoc_list, bag, benchmarking.
-:- import_module bimap, bintree, bintree_set, bitmap, bool, bt_array, builtin.
-:- import_module char, construct, cord, counter, deconstruct, dir.
-:- import_module enum, eqvclass, exception.
-:- import_module float, gc, getopt, graph, group, hash_table.
-:- import_module int, integer, io, lexer, list, map, math, multi_map, ops.
-:- import_module parser, pprint, pqueue, prolog, queue.
-:- import_module random, rational, rbtree, relation, require.
-:- import_module set, set_bbbtree, set_ordlist, set_unordlist, sparse_bitset.
-:- import_module stack, std_util, store, string.
-:- import_module term, term_io, tree234, time, type_desc, varset.
+:- import_module array.
+:- import_module array2d.
+:- import_module assoc_list.
+:- import_module bag.
+:- import_module benchmarking.
+:- import_module bimap.
+:- import_module bintree.
+:- import_module bintree_set.
+:- import_module bitmap.
+:- import_module bool.
+:- import_module bt_array.
+:- import_module builtin.
+:- import_module char.
+:- import_module construct.
+:- import_module cord.
+:- import_module counter.
+:- import_module deconstruct.
+:- import_module dir.
+:- import_module enum.
+:- import_module eqvclass.
+:- import_module exception.
+:- import_module float.
+:- import_module gc.
+:- import_module getopt.
+:- import_module graph.
+:- import_module group.
+:- import_module hash_table.
+:- import_module int.
+:- import_module integer.
+:- import_module io.
+:- import_module lexer.
+:- import_module list.
+:- import_module map.
+:- import_module math.
+:- import_module multi_map.
+:- import_module ops.
+:- import_module parser.
+:- import_module pprint.
+:- import_module pqueue.
+:- import_module prolog.
+:- import_module queue.
+:- import_module random.
+:- import_module rational.
+:- import_module rbtree.
+:- import_module relation.
+:- import_module require.
+:- import_module set.
+:- import_module set_bbbtree.
+:- import_module set_ordlist.
+:- import_module set_unordlist.
+:- import_module sparse_bitset.
+:- import_module stack.
+:- import_module std_util.
+:- import_module store.
+:- import_module string.
+:- import_module term.
+:- import_module term_io.
+:- import_module time.
+:- import_module tree234.
+:- import_module type_desc.
+:- import_module varset.
% The modules intended for Mercury system implementors.
-:- import_module private_builtin, table_builtin, profiling_builtin.
+:- import_module private_builtin.
+:- import_module profiling_builtin.
:- import_module rtti_implementation.
+:- import_module table_builtin.
+:- import_module term_size_prof_builtin.
+
+% Uncomment this temporarily (in your own workspace) if you need access to
+% unsafe predicates. In MLDS grades, you would also have to add unsafe to
+% the list in mercury_std_library_module in the compiler you use to compile
+% the library.
+% :- import_module unsafe.
% library__version must be implemented using pragma c_code,
% so we can get at the MR_VERSION and MR_FULLARCH configuration
@@ -53,7 +112,8 @@
% might not have a Mercury compiler around to compile library.m with.
:- pragma foreign_proc("C",
- library__version(Version::out), [will_not_call_mercury, promise_pure],
+ library__version(Version::out),
+ [will_not_call_mercury, promise_pure],
"
MR_ConstString version_string =
MR_VERSION "", configured for "" MR_FULLARCH;
@@ -69,7 +129,8 @@
").
:- pragma foreign_proc("MC++",
- library__version(Version::out), [will_not_call_mercury, promise_pure],
+ library__version(Version::out),
+ [will_not_call_mercury, promise_pure],
"
// MR_VERSION and MR_FULLARCH are C string literals.
// We need to paste 'S' to the front of them to make them into .NET
Index: library/private_builtin.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/private_builtin.m,v
retrieving revision 1.119
diff -u -b -r1.119 private_builtin.m
--- library/private_builtin.m 14 May 2003 14:38:46 -0000 1.119
+++ library/private_builtin.m 15 May 2003 02:31:48 -0000
@@ -1104,6 +1104,54 @@
%-----------------------------------------------------------------------------%
+:- pragma foreign_decl("C", "
+
+#include ""mercury_builtin_types.h""
+
+MR_DECLARE_TYPE_CTOR_INFO_STRUCT(MR_TYPE_CTOR_INFO_NAME(list, list, 1));
+MR_DECLARE_TYPE_CTOR_INFO_STRUCT(MR_TYPE_CTOR_INFO_NAME(std_util, univ, 0));
+
+").
+
+:- pragma foreign_code("C", "
+
+const MR_TypeCtorInfo MR_lib_type_ctor_info_for_univ =
+ &MR_TYPE_CTOR_INFO_NAME(std_util, univ, 0);
+
+const MR_FA_TypeInfo_Struct1 MR_lib_type_info_for_type_info = {
+ &MR_TYPE_CTOR_INFO_NAME(private_builtin, type_info, 1),
+ { (MR_TypeInfo) &MR_TYPE_CTOR_INFO_NAME(builtin, void, 0) }
+};
+
+const MR_FA_TypeInfo_Struct1 MR_lib_type_info_for_list_of_univ = {
+ &MR_TYPE_CTOR_INFO_NAME(list, list, 1),
+ { (MR_TypeInfo) &MR_TYPE_CTOR_INFO_NAME(std_util, univ, 0) }
+};
+
+const MR_FA_TypeInfo_Struct1 MR_lib_type_info_for_list_of_int = {
+ &MR_TYPE_CTOR_INFO_NAME(list, list, 1),
+ { (MR_TypeInfo) &MR_TYPE_CTOR_INFO_NAME(builtin, int, 0) }
+};
+
+const MR_FA_TypeInfo_Struct1 MR_lib_type_info_for_list_of_char = {
+ &MR_TYPE_CTOR_INFO_NAME(list, list, 1),
+ { (MR_TypeInfo) &MR_TYPE_CTOR_INFO_NAME(builtin, character, 0) }
+};
+
+const MR_FA_TypeInfo_Struct1 MR_lib_type_info_for_list_of_string = {
+ &MR_TYPE_CTOR_INFO_NAME(list, list, 1),
+ { (MR_TypeInfo) &MR_TYPE_CTOR_INFO_NAME(builtin, string, 0) }
+};
+
+const MR_FA_TypeInfo_Struct1 MR_lib_type_info_for_list_of_type_info = {
+ &MR_TYPE_CTOR_INFO_NAME(list, list, 1),
+ { (MR_TypeInfo) &MR_lib_type_info_for_type_info }
+};
+
+").
+
+%-----------------------------------------------------------------------------%
+
:- interface.
% This section of the module is for miscellaneous predicates
Index: library/sparse_bitset.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/sparse_bitset.m,v
retrieving revision 1.16
diff -u -b -r1.16 sparse_bitset.m
--- library/sparse_bitset.m 23 Jul 2002 08:26:27 -0000 1.16
+++ library/sparse_bitset.m 9 Apr 2003 07:19:29 -0000
@@ -760,7 +760,8 @@
%make_bitset_elem(A, B) = bitset_elem(A, B).
:- pragma foreign_decl("C", "
- #include ""mercury_heap.h"" /* for MR_incr_hp_atomic_msg() */
+ #include ""mercury_heap.h""
+ /* for MR_tag_offset_incr_hp_atomic_msg() */
").
% The bit pattern will often look like a pointer,
@@ -768,14 +769,17 @@
% to avoid unnecessary memory retention.
% Doing this slows down the compiler by about 1%,
% but in a library module it's better to be safe.
-:- pragma foreign_proc("C", make_bitset_elem(A::in, B::in) = (Pair::out),
+:- pragma foreign_proc("C",
+ make_bitset_elem(A::in, B::in) = (Pair::out),
[will_not_call_mercury, promise_pure, thread_safe],
"{
#define ML_BITSET_TAG MR_FIRST_UNRESERVED_RAW_TAG
- MR_tag_incr_hp_atomic_msg(Pair, MR_mktag(ML_BITSET_TAG),
- 2, MR_PROC_LABEL, ""sparse_bitset:bitset_elem/0"");
+ MR_tag_offset_incr_hp_atomic_msg(Pair, MR_mktag(ML_BITSET_TAG),
+ MR_SIZE_SLOT_SIZE, MR_SIZE_SLOT_SIZE + 2,
+ MR_PROC_LABEL, ""sparse_bitset:bitset_elem/0"");
+ MR_define_size_slot(MR_mktag(ML_BITSET_TAG), Pair, 1);
MR_field(MR_mktag(ML_BITSET_TAG), Pair, 0) = A;
MR_field(MR_mktag(ML_BITSET_TAG), Pair, 1) = B;
}").
Index: library/std_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/std_util.m,v
retrieving revision 1.284
diff -u -b -r1.284 std_util.m
--- library/std_util.m 14 May 2003 14:38:47 -0000 1.284
+++ library/std_util.m 15 May 2003 02:31:48 -0000
@@ -1276,15 +1276,19 @@
new_mutvar(X::in, Ref::out),
[will_not_call_mercury, thread_safe],
"
- MR_incr_hp_msg(Ref, 1, MR_PROC_LABEL, ""std_util:mutvar/1"");
- *(MR_Word *) Ref = X;
+ MR_offset_incr_hp_msg(Ref, MR_SIZE_SLOT_SIZE, MR_SIZE_SLOT_SIZE + 1,
+ MR_PROC_LABEL, ""std_util:mutvar/1"");
+ MR_define_size_slot(0, Ref, 1);
+ * (MR_Word *) Ref = X;
").
:- pragma foreign_proc("C",
new_mutvar(X::di, Ref::uo),
[will_not_call_mercury, thread_safe],
"
- MR_incr_hp_msg(Ref, 1, MR_PROC_LABEL, ""std_util:mutvar/1"");
- *(MR_Word *) Ref = X;
+ MR_offset_incr_hp_msg(Ref, MR_SIZE_SLOT_SIZE, MR_SIZE_SLOT_SIZE + 1,
+ MR_PROC_LABEL, ""std_util:mutvar/1"");
+ MR_define_size_slot(0, Ref, 1);
+ * (MR_Word *) Ref = X;
").
:- pragma inline(get_mutvar/2).
@@ -1293,7 +1297,7 @@
get_mutvar(Ref::in, X::uo),
[will_not_call_mercury, thread_safe],
"
- X = *(MR_Word *) Ref;
+ X = * (MR_Word *) Ref;
").
:- pragma inline(set_mutvar/2).
Index: library/store.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/store.m,v
retrieving revision 1.38
diff -u -b -r1.38 store.m
--- library/store.m 14 May 2003 14:38:48 -0000 1.38
+++ library/store.m 15 May 2003 02:31:48 -0000
@@ -287,22 +287,27 @@
I wonder whether it is worth it? Hmm, probably not.
*/
-:- pragma foreign_proc("C", new_mutvar(Val::in, Mutvar::out, S0::di, S::uo),
+:- pragma foreign_proc("C",
+ new_mutvar(Val::in, Mutvar::out, S0::di, S::uo),
[will_not_call_mercury, promise_pure],
"
- MR_incr_hp_msg(Mutvar, 1, MR_PROC_LABEL, ""store:mutvar/2"");
+ MR_offset_incr_hp_msg(Mutvar, MR_SIZE_SLOT_SIZE, MR_SIZE_SLOT_SIZE + 1,
+ MR_PROC_LABEL, ""store:mutvar/2"");
+ MR_define_size_slot(0, Mutvar, 1);
* (MR_Word *) Mutvar = Val;
S = S0;
").
-:- pragma foreign_proc("C", get_mutvar(Mutvar::in, Val::out, S0::di, S::uo),
+:- pragma foreign_proc("C",
+ get_mutvar(Mutvar::in, Val::out, S0::di, S::uo),
[will_not_call_mercury, promise_pure],
"
Val = * (MR_Word *) Mutvar;
S = S0;
").
-:- pragma foreign_proc("C", set_mutvar(Mutvar::in, Val::in, S0::di, S::uo),
+:- pragma foreign_proc("C",
+ set_mutvar(Mutvar::in, Val::in, S0::di, S::uo),
[will_not_call_mercury, promise_pure],
"
* (MR_Word *) Mutvar = Val;
@@ -321,7 +326,9 @@
unsafe_new_uninitialized_mutvar(Mutvar::out, S0::di, S::uo),
[will_not_call_mercury, promise_pure],
"
- MR_incr_hp_msg(Mutvar, 1, MR_PROC_LABEL, ""store:mutvar/2"");
+ MR_offset_incr_hp_msg(Mutvar, MR_SIZE_SLOT_SIZE, MR_SIZE_SLOT_SIZE + 1,
+ MR_PROC_LABEL, ""store:mutvar/2"");
+ MR_define_size_slot(0, Mutvar, 1);
S = S0;
").
@@ -332,10 +339,13 @@
%-----------------------------------------------------------------------------%
-:- pragma foreign_proc("C", new_ref(Val::di, Ref::out, S0::di, S::uo),
+:- pragma foreign_proc("C",
+ new_ref(Val::di, Ref::out, S0::di, S::uo),
[will_not_call_mercury, promise_pure],
"
- MR_incr_hp_msg(Ref, 1, MR_PROC_LABEL, ""store:ref/2"");
+ MR_offset_incr_hp_msg(Ref, MR_SIZE_SLOT_SIZE, MR_SIZE_SLOT_SIZE + 1,
+ MR_PROC_LABEL, ""store:ref/2"");
+ MR_define_size_slot(0, Ref, 1);
* (MR_Word *) Ref = Val;
S = S0;
").
@@ -350,7 +360,8 @@
% value.
:- pred store__unsafe_ref_value(generic_ref(T, S), T, S, S) <= store(S).
:- mode store__unsafe_ref_value(in, uo, di, uo) is det.
-:- pragma foreign_proc("C", unsafe_ref_value(Ref::in, Val::uo, S0::di, S::uo),
+:- pragma foreign_proc("C",
+ unsafe_ref_value(Ref::in, Val::uo, S0::di, S::uo),
[will_not_call_mercury, promise_pure],
"
Val = * (MR_Word *) Ref;
@@ -440,7 +451,9 @@
*/
if (arg_ref == &Val) {
- MR_incr_hp_msg(ArgRef, 1, MR_PROC_LABEL, ""store:ref/2"");
+ MR_offset_incr_hp_msg(ArgRef, MR_SIZE_SLOT_SIZE,
+ MR_SIZE_SLOT_SIZE + 1, MR_PROC_LABEL, ""store:ref/2"");
+ MR_define_size_slot(0, ArgRef, 1);
* (MR_Word *) ArgRef = Val;
} else {
ArgRef = (MR_Word) arg_ref;
@@ -483,8 +496,8 @@
S = S0;
}").
-:- pragma foreign_proc("C", unsafe_new_arg_ref(Val::di, Arg::in, ArgRef::out,
- S0::di, S::uo),
+:- pragma foreign_proc("C",
+ unsafe_new_arg_ref(Val::di, Arg::in, ArgRef::out, S0::di, S::uo),
[will_not_call_mercury, promise_pure],
"{
/* unsafe - does not check type & arity, won't handle no_tag types */
@@ -492,4 +505,3 @@
ArgRef = (MR_Word) &Ptr[Arg];
S = S0;
}").
-
Index: library/string.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/string.m,v
retrieving revision 1.201
diff -u -b -r1.201 string.m
--- library/string.m 26 May 2003 09:00:31 -0000 1.201
+++ library/string.m 26 May 2003 09:12:32 -0000
@@ -931,7 +931,7 @@
CharList = MR_list_empty_msg(MR_PROC_LABEL);
while (p > Str) {
p--;
- CharList = MR_list_cons_msg((MR_UnsignedChar) *p, CharList,
+ CharList = MR_char_list_cons_msg((MR_UnsignedChar) *p, CharList,
MR_PROC_LABEL);
}
}").
@@ -1287,8 +1287,7 @@
%-----------------------------------------------------------------------------%
:- pragma foreign_proc("C",
- string__sub_string_search(WholeString::in, SubString::in,
- Index::out),
+ string__sub_string_search(WholeString::in, SubString::in, Index::out),
[will_not_call_mercury, promise_pure, thread_safe],
"{
char *match;
@@ -1302,8 +1301,7 @@
}").
:- pragma foreign_proc("MC++",
- string__sub_string_search(WholeString::in, SubString::in,
- Index::out),
+ string__sub_string_search(WholeString::in, SubString::in, Index::out),
[will_not_call_mercury, promise_pure, thread_safe],
"{
Index = WholeString->IndexOf(SubString);
@@ -1780,11 +1778,13 @@
:- pred using_sprintf is semidet.
:- pragma foreign_proc("C", using_sprintf,
- [will_not_call_mercury, promise_pure, thread_safe], "
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
SUCCESS_INDICATOR = MR_TRUE;
").
:- pragma foreign_proc("MC++", using_sprintf,
- [will_not_call_mercury, promise_pure, thread_safe], "
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
SUCCESS_INDICATOR = MR_FALSE;
").
@@ -2870,7 +2870,6 @@
string__lowlevel_float_to_string(FloatVal::in, FloatString::uo),
[will_not_call_mercury, promise_pure, thread_safe],
"
-
// The R format string prints the double out such that it
// can be round-tripped.
// XXX According to the documentation it tries the 15 digits of
@@ -2933,7 +2932,7 @@
IntList = MR_list_empty_msg(MR_PROC_LABEL);
while (p > Str) {
p--;
- IntList = MR_list_cons_msg((MR_UnsignedChar) *p, IntList,
+ IntList = MR_int_list_cons_msg((MR_UnsignedChar) *p, IntList,
MR_PROC_LABEL);
}
}").
Index: library/term_size_prof_builtin.m
===================================================================
RCS file: library/term_size_prof_builtin.m
diff -N library/term_size_prof_builtin.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ library/term_size_prof_builtin.m 20 May 2003 17:02:09 -0000
@@ -0,0 +1,117 @@
+%---------------------------------------------------------------------------%
+% Copyright (C) 2003 The University of Melbourne.
+% This file may only be copied under the terms of the GNU Library General
+% Public License - see the file COPYING.LIB in the Mercury distribution.
+%---------------------------------------------------------------------------%
+%
+% File: term_size_prof.m.
+% Author: zs.
+% Stability: low.
+%
+% This file is automatically imported into every module when term size
+% profiling is enabled. It contains support predicates used for term size
+% profiling.
+%
+%---------------------------------------------------------------------------%
+
+:- module term_size_prof_builtin.
+
+:- interface.
+
+ % measure_size(Term, Size): return the size of Term as Size.
+ % The cost of the operation is independent of the size of Term;
+ % if Term points to the heap, it looks up the size stored at the
+ % starts of the cell.
+:- pred measure_size(T::in, int::out) is det.
+
+ % measure_size_acc(Term, Size0, Size): similar to measure_size,
+ % but instead of returning just the size of term, it returns the
+ % size plus Size0.
+:- pred measure_size_acc(T::in, int::in, int::out) is det.
+
+ % increment_size(Term, Incr): Term must be a term on the heap
+ % that is not fully ground, and whose size slot's contents represents
+ % the size of the term in its original binding state. When some of
+ % Term's free arguments are bound, we must increment its recorded size
+ % by Incr, the sum of the sizes of the terms bound to those arguments.
+ % This is what increment_size does. It is impure because it updates
+ % Term destructively.
+:- impure pred increment_size(T::in, int::in) is det.
+
+ % This function is exactly like int__plus, and is also implemented
+ % as a builtin. It is duplicated in this module because only predicates
+ % and functions in builtin modules like this one are immune to dead
+ % procedure elimination.
+:- func term_size_plus(int, int) = int.
+
+%---------------------------------------------------------------------------%
+
+:- implementation.
+
+:- import_module int.
+
+:- pragma foreign_decl("C", "
+#ifdef MR_TERM_SIZE_PROFILING_GUARD
+
+ #ifdef MR_RECORD_TERM_SIZES
+ #include ""mercury_term_size.h""
+ #endif /* MR_RECORD_TERM_SIZES */
+
+#endif /* MR_TERM_SIZE_PROFILING_GUARD */
+").
+
+:- pragma foreign_proc("C",
+ measure_size(Term::in, Size::out),
+ [thread_safe, promise_pure, will_not_call_mercury],
+"{
+#ifdef MR_RECORD_TERM_SIZES
+ Size = MR_term_size(TypeInfo_for_T, Term);
+ #ifdef MR_DEBUG_TERM_SIZES
+ if (MR_heapdebug && MR_lld_print_enabled) {
+ printf(""measure_size: %p -> %d\\n"",
+ (void *) Term, (int) Size);
+ }
+ #endif
+#else
+ MR_fatal_error(""measure_size: term size profiling not enabled"");
+#endif
+}").
+
+:- pragma foreign_proc("C",
+ measure_size_acc(Term::in, Size0::in, Size::out),
+ [thread_safe, promise_pure, will_not_call_mercury],
+"{
+#ifdef MR_RECORD_TERM_SIZES
+ Size = MR_term_size(TypeInfo_for_T, Term) + Size0;
+ #ifdef MR_DEBUG_TERM_SIZES
+ if (MR_heapdebug && MR_lld_print_enabled) {
+ printf(""measure_size_acc: %p + %d -> %d\\n"",
+ (void *) Term, (int) Size0, (int) Size);
+ }
+ #endif
+#else
+ MR_fatal_error(""measure_size_acc: term size profiling not enabled"");
+#endif
+}").
+
+:- pragma foreign_proc("C",
+ increment_size(Term::in, Incr::in),
+ [thread_safe, will_not_call_mercury],
+"{
+#ifdef MR_RECORD_TERM_SIZES
+ #ifdef MR_DEBUG_TERM_SIZES
+ if (MR_heapdebug && MR_lld_print_enabled) {
+ printf(""increment_size: %p + %d\\n"",
+ (void *) Term, (int) Incr);
+ }
+ #endif
+ MR_mask_field(Term, -1) += Incr;
+#else
+ MR_fatal_error(""increment_size: term size profiling not enabled"");
+#endif
+}").
+
+% Temporary definition, until the change to the compiler that makes
+% term_size_prof_builtin__plus a builtin is bootstrapped.
+
+term_size_plus(X, Y) = X + Y.
cvs diff: Diffing profiler
cvs diff: Diffing robdd
cvs diff: Diffing runtime
Index: runtime/Mmakefile
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/Mmakefile,v
retrieving revision 1.102
diff -u -b -r1.102 Mmakefile
--- runtime/Mmakefile 18 Mar 2003 16:38:08 -0000 1.102
+++ runtime/Mmakefile 26 May 2003 12:01:31 -0000
@@ -53,6 +53,7 @@
mercury_minimal_model.h \
mercury_misc.h \
mercury_overflow.h \
+ mercury_proc_id.h \
mercury_prof.h \
mercury_prof_mem.h \
mercury_prof_time.h \
@@ -70,6 +71,7 @@
mercury_tabling.h \
mercury_tabling_macros.h \
mercury_tags.h \
+ mercury_term_size.h \
mercury_thread.h \
mercury_timing.h \
mercury_trace_base.h \
@@ -78,6 +80,7 @@
mercury_type_info.h \
mercury_type_tables.h \
mercury_types.h \
+ mercury_univ.h \
mercury_wrapper.h \
$(LIB_DLL_H)
@@ -161,6 +164,7 @@
mercury_stacks.c \
mercury_string.c \
mercury_tabling.c \
+ mercury_term_size.c \
mercury_thread.c \
mercury_timing.c \
mercury_trace_base.c \
Index: runtime/mercury.c
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury.c,v
retrieving revision 1.42
diff -u -b -r1.42 mercury.c
--- runtime/mercury.c 9 Aug 2002 05:26:47 -0000 1.42
+++ runtime/mercury.c 7 Apr 2003 07:36:00 -0000
@@ -43,7 +43,7 @@
MR_OUTLINE_DEFN(
MR_Word
- MR_create1(MR_Word w1)
+ MR_create1_func(MR_Word w1)
,
{
MR_Word *p = (MR_Word *) MR_new_object(MR_Word,
@@ -55,7 +55,7 @@
MR_OUTLINE_DEFN(
MR_Word
- MR_create2(MR_Word w1, MR_Word w2)
+ MR_create2_func(MR_Word w1, MR_Word w2)
,
{
MR_Word *p = (MR_Word *) MR_new_object(MR_Word,
@@ -68,7 +68,7 @@
MR_OUTLINE_DEFN(
MR_Word
- MR_create3(MR_Word w1, MR_Word w2, MR_Word w3)
+ MR_create3_func(MR_Word w1, MR_Word w2, MR_Word w3)
,
{
MR_Word *p = (MR_Word *) MR_new_object(MR_Word,
Index: runtime/mercury.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury.h,v
retrieving revision 1.65
diff -u -b -r1.65 mercury.h
--- runtime/mercury.h 29 Sep 2002 09:38:41 -0000 1.65
+++ runtime/mercury.h 7 Apr 2003 07:45:28 -0000
@@ -303,8 +303,10 @@
** The #include of mercury_heap.h needs to come *after* the definition
** of MR_new_object(), because mercury_heap.h defines some inline
** functions that reference MR_new_object().
+** mercury_univ.h includes mercury_heap.h.
*/
#include "mercury_heap.h" /* for MR_MAYBE_(UN)BOX_FOREIGN_TYPE() */
+#include "mercury_univ.h"
#endif /* MR_HIGHLEVEL_CODE */
Index: runtime/mercury_conf_param.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_conf_param.h,v
retrieving revision 1.70
diff -u -b -r1.70 mercury_conf_param.h
--- runtime/mercury_conf_param.h 10 Apr 2003 05:51:05 -0000 1.70
+++ runtime/mercury_conf_param.h 10 Apr 2003 06:56:38 -0000
@@ -175,6 +175,12 @@
** Causes the generated code to become bigger and less efficient.
** Slows down compilation.
**
+** MR_DEBUG_HEAP_ALLOC
+** (Implied by MR_LOWLEVEL_DEBUG.)
+** Uses functions to do memory allocation. These functions can generate
+** diagnostic output, enforce invariants, and one can put breakpoints
+** on them.
+**
** MR_DEBUG_AGC_SCHEDULING
** Display debugging information while scheduling accurate garbage
** collection (for the low-level back-end).
@@ -289,6 +295,16 @@
** MR_DEEP_PROFILING
** Enables deep profiling.
**
+** MR_RECORD_TERM_SIZES
+** Augments heap cells with an extra word recording the size of the term.
+** For implementors only.
+**
+** MR_RECORD_TERM_SIZES_AS_CELLS
+** Record the size of the term as the number of heap cells it occupies.
+** If MR_RECORD_TERM_SIZES_AS_CELLS is not defined, the default is
+** to record term sizes as the number of heap words. Meaningful only if
+** MR_RECORD_TERM_SIZES is defined. For implementors only.
+**
** MR_DEEP_PROFILING_PERF_TEST
** Allows the selective performance testing of various aspects of deep
** profiling. For implementors only.
@@ -299,6 +315,19 @@
** profiling paper). For implementors only.
*/
+#ifdef MR_HIGHLEVEL_CODE
+ /*
+ ** Neither deep profiling nor term size profiling are supported on the
+ ** high level C backend (yet).
+ */
+ #ifdef MR_DEEP_PROFILING
+ #error "MR_HIGHLEVEL_CODE and MR_DEEP_PROFILING both defined"
+ #endif
+ #ifdef MR_RECORD_TERM_SIZES
+ #error "MR_HIGHLEVEL_CODE and MR__RECORD_TERM_SIZES both defined"
+ #endif
+#endif
+
/*
** Experimental options:
**
@@ -395,6 +424,7 @@
#ifdef MR_LOWLEVEL_DEBUG
#define MR_DEBUG_GOTOS
#define MR_CHECK_FOR_OVERFLOW
+ #define MR_DEBUG_HEAP_ALLOC
#endif
/*
Index: runtime/mercury_construct.c
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_construct.c,v
retrieving revision 1.11
diff -u -b -r1.11 mercury_construct.c
--- runtime/mercury_construct.c 13 May 2003 08:52:05 -0000 1.11
+++ runtime/mercury_construct.c 15 May 2003 02:31:49 -0000
@@ -20,6 +20,7 @@
#endif
#include "mercury_type_info.h"
#include "mercury_construct.h"
+#include "mercury_univ.h"
#include "mercury_misc.h" /* for MR_fatal_error() */
static int MR_get_functor_info(MR_TypeInfo type_info, int functor_number,
Index: runtime/mercury_debug.c
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_debug.c,v
retrieving revision 1.15
diff -u -b -r1.15 mercury_debug.c
--- runtime/mercury_debug.c 2 Apr 2003 23:22:16 -0000 1.15
+++ runtime/mercury_debug.c 26 May 2003 12:12:51 -0000
@@ -40,6 +40,58 @@
/* debugging messages */
+#ifdef MR_DEBUG_HEAP_ALLOC
+
+void
+MR_unravel_univ_msg(MR_Word univ, MR_TypeInfo type_info, MR_Word value)
+{
+ if (MR_lld_print_enabled && MR_heapdebug) {
+ printf("unravel univ %p: typeinfo %p, value %p\n",
+ (void *) univ, (void *) typeinfo, (void *) value);
+ fflush(stdout);
+ }
+}
+
+void
+MR_new_univ_on_hp_msg(MR_Word univ, MR_TypeInfo type_info, MR_Word value)
+{
+ if (MR_lld_print_enabled && MR_heapdebug) {
+ printf("new univ on hp: typeinfo %p, value %p => %p\n",
+ (void *) typeinfo, (void *) value, (void *) univ);
+ fflush(stdout);
+ }
+}
+
+void
+MR_tag_offset_incr_hp_n_msg(MR_Word *malloc_addr, MR_Word ptr, int tag,
+ int offset, int count)
+{
+ if (MR_lld_print_enabled && MR_heapdebug) {
+ printf("tag_offset_incr_hp_n: "
+ "tag %d, offset %d, count %d\n",
+ tag, offset, count);
+ printf("malloc: %p, addr %p\n",
+ (void *) malloc_addr, (void *) ptr);
+ fflush(stdout);
+ }
+}
+
+void
+MR_tag_offset_incr_hp_atomic_msg(MR_Word *malloc_addr, MR_Word ptr, int tag,
+ int offset, int count)
+{
+ if (MR_lld_print_enabled && MR_heapdebug) {
+ printf("tag_offset_incr_hp_atomic: "
+ "tag %d, offset %d, count %d\n",
+ tag, offset, count);
+ printf("malloc: %p, addr %p\n",
+ (void *) malloc_addr, (void *) ptr);
+ fflush(stdout);
+ }
+}
+
+#endif /* MR_DEBUG_HEAP_ALLOC */
+
#ifdef MR_LOWLEVEL_DEBUG
void
@@ -265,25 +317,62 @@
}
void
-MR_cr1_msg(MR_Word val0, const MR_Word *addr)
+MR_cr1_msg(const MR_Word *addr)
{
if (!MR_lld_print_enabled) {
return;
}
- printf("put value %9lx at ", (long) (MR_Integer) val0);
+#ifdef MR_RECORD_TERM_SIZES
+ printf("create1: put size %ld, value %9lx at ",
+ (long) (MR_Integer) addr[-2],
+ (long) (MR_Integer) addr[-1]);
+#else
+ printf("create1: put value %9lx at ",
+ (long) (MR_Integer) addr[-1]);
+#endif
MR_printheap(addr);
}
void
-MR_cr2_msg(MR_Word val0, MR_Word val1, const MR_Word *addr)
+MR_cr2_msg(const MR_Word *addr)
{
if (!MR_lld_print_enabled) {
return;
}
- printf("put values %9lx,%9lx at ",
- (long) (MR_Integer) val0, (long) (MR_Integer) val1);
+#ifdef MR_RECORD_TERM_SIZES
+ printf("create2: put size %ld, values %9lx,%9lx at ",
+ (long) (MR_Integer) addr[-3],
+ (long) (MR_Integer) addr[-2],
+ (long) (MR_Integer) addr[-1]);
+#else
+ printf("create2: put values %9lx,%9lx at ",
+ (long) (MR_Integer) addr[-2],
+ (long) (MR_Integer) addr[-1]);
+#endif
+ MR_printheap(addr);
+}
+
+void
+MR_cr3_msg(const MR_Word *addr)
+{
+ if (!MR_lld_print_enabled) {
+ return;
+ }
+
+#ifdef MR_RECORD_TERM_SIZES
+ printf("create3: put size %ld, values %9lx,%9lx,%9lx at ",
+ (long) (MR_Integer) addr[-4],
+ (long) (MR_Integer) addr[-3],
+ (long) (MR_Integer) addr[-2],
+ (long) (MR_Integer) addr[-1]);
+#else
+ printf("create3: put values %9lx,%9lx,%9lx at ",
+ (long) (MR_Integer) addr[-3],
+ (long) (MR_Integer) addr[-2],
+ (long) (MR_Integer) addr[-1]);
+#endif
MR_printheap(addr);
}
@@ -422,7 +511,8 @@
/* the bitwise ORs implement logical OR */
MR_lld_print_enabled = MR_lld_print_region_enabled
- | MR_lld_print_name_enabled | MR_lld_print_csd_enabled;
+ | MR_lld_print_name_enabled | MR_lld_print_csd_enabled
+ | MR_lld_debug_enabled;
}
void
@@ -488,8 +578,9 @@
MR_Word *fr;
printf("\nnondstack dump\n");
- for (fr = MR_maxfr; fr > MR_CONTEXT(MR_ctxt_nondetstack_zone)->min;
- fr = MR_prevfr_slot(fr)) {
+ for (fr = MR_maxfr; fr > MR_nondet_stack_trace_bottom;
+ fr = MR_prevfr_slot(fr))
+ {
MR_dumpframe(fr);
}
}
Index: runtime/mercury_debug.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_debug.h,v
retrieving revision 1.16
diff -u -b -r1.16 mercury_debug.h
--- runtime/mercury_debug.h 18 Mar 2003 16:38:09 -0000 1.16
+++ runtime/mercury_debug.h 26 May 2003 11:58:19 -0000
@@ -10,6 +10,7 @@
#define MERCURY_DEBUG_H
#include "mercury_types.h" /* for MR_Word and MR_Code */
+#include "mercury_type_info.h" /* for MR_TypeInfo */
#include <stdio.h> /* for FILE */
/*---------------------------------------------------------------------------*/
@@ -38,10 +39,38 @@
#endif
+#ifndef MR_DEBUG_HEAP_ALLOC
+
+#define MR_debugunraveluniv(univ, typeinfo, value) ((void)0)
+#define MR_debugnewunivonhp(univ, typeinfo, value) ((void)0)
+#define MR_debugtagoffsetincrhpn(malloc_addr, ptr, tag, offset, count) \
+ ((void)0)
+#define MR_debugtagoffsetincrhpatomic(malloc_addr, ptr, tag, offset, count) \
+ ((void)0)
+
+#else
+
+#define MR_debugunraveluniv(univ, typeinfo, value) \
+ MR_unravel_univ_msg((univ), (typeinfo), (value))
+
+#define MR_debugnewunivonhp(univ, typeinfo, value) \
+ MR_new_univ_on_hp_msg((univ), (typeinfo), (value))
+
+#define MR_debugtagoffsetincrhpn(malloc_addr, ptr, tag, offset, count) \
+ MR_debugtagoffsetincrhpn((malloc_addr), (ptr), (tag), \
+ (offset), (count))
+
+#define MR_debugtagoffsetincrhpatomic(malloc_addr, ptr, tag, offset, count) \
+ MR_debugtagoffsetincrhpatomic((malloc_addr), (ptr), (tag), \
+ (offset), (count))
+
+#endif
+
#ifndef MR_LOWLEVEL_DEBUG
-#define MR_debugcr1(val0, hp) ((void)0)
-#define MR_debugcr2(val0, val1, hp) ((void)0)
+#define MR_debugcr1(hp) ((void)0)
+#define MR_debugcr2(hp) ((void)0)
+#define MR_debugcr3(hp) ((void)0)
#define MR_debugincrhp(val, hp) ((void)0)
#define MR_debugincrsp(val, sp) ((void)0)
#define MR_debugdecrsp(val, sp) ((void)0)
@@ -64,17 +93,22 @@
#else
-#define MR_debugcr1(val0, hp) \
+#define MR_debugcr1(hp) \
+ MR_IF (MR_heapdebug, \
+ (MR_save_transient_registers(), MR_cr1_msg(hp)))
+
+#define MR_debugcr2(hp) \
MR_IF (MR_heapdebug, \
- (MR_save_transient_registers(), MR_cr1_msg(val0, hp)))
+ (MR_save_transient_registers(), MR_cr2_msg(hp)))
-#define MR_debugcr2(val0, val1, hp) \
+#define MR_debugcr3(hp) \
MR_IF (MR_heapdebug, \
- (MR_save_transient_registers(), MR_cr2_msg(val0, val1, hp)))
+ (MR_save_transient_registers(), MR_cr3_msg(hp)))
#define MR_debugincrhp(val, hp) \
MR_IF (MR_heapdebug, \
- (MR_save_transient_registers(), MR_incr_hp_debug_msg((val), (hp))))
+ (MR_save_transient_registers(), \
+ MR_incr_hp_debug_msg((val), (hp))))
#define MR_debugincrsp(val, sp) \
MR_IF (MR_detstackdebug, \
@@ -85,7 +119,8 @@
(MR_save_transient_registers(), MR_decr_sp_msg((val), (sp))))
#define MR_debugregs(msg) \
- MR_IF (MR_progdebug, (MR_save_transient_registers(), MR_printregs(msg)))
+ MR_IF (MR_progdebug, \
+ (MR_save_transient_registers(), MR_printregs(msg)))
#define MR_debugframe(msg) \
MR_IF (MR_progdebug, \
@@ -155,6 +190,17 @@
/*---------------------------------------------------------------------------*/
+#ifdef MR_DEBUG_HEAP_ALLOC
+extern void MR_unravel_univ_msg(MR_Word univ, MR_TypeInfo type_info,
+ MR_Word value);
+extern void MR_new_univ_on_hp_msg(MR_Word univ, MR_TypeInfo type_info,
+ MR_Word value);
+extern void MR_tag_offset_incr_hp_n_msg(MR_Word *malloc_addr,
+ MR_Word ptr, int tag, int offset, int count);
+extern void MR_tag_offset_incr_hp_atomic_msg(MR_Word *malloc_addr,
+ MR_Word ptr, int tag, int offset, int count);
+#endif
+
#ifdef MR_LOWLEVEL_DEBUG
extern void MR_mkframe_msg(const char *);
extern void MR_mktempframe_msg(void);
@@ -167,8 +213,9 @@
/* const */ MR_Code *succcont);
extern void MR_tailcall_msg(/* const */ MR_Code *proc);
extern void MR_proceed_msg(void);
-extern void MR_cr1_msg(MR_Word val0, const MR_Word *addr);
-extern void MR_cr2_msg(MR_Word val0, MR_Word val1, const MR_Word *addr);
+extern void MR_cr1_msg(const MR_Word *addr);
+extern void MR_cr2_msg(const MR_Word *addr);
+extern void MR_cr3_msg(const MR_Word *addr);
extern void MR_incr_hp_debug_msg(MR_Word val, const MR_Word *addr);
extern void MR_incr_sp_msg(MR_Word val, const MR_Word *addr);
extern void MR_decr_sp_msg(MR_Word val, const MR_Word *addr);
@@ -201,6 +248,16 @@
extern void MR_printlabel(FILE *fp, /* const */ MR_Code *w);
extern void MR_print_deep_prof_var(FILE *fp, const char *name,
MR_CallSiteDynamic *csd);
+
+#ifdef MR_DEBUG_HEAP_ALLOC
+#ifdef MR_CONSERVATIVE_GC
+extern MR_Word MR_tag_offset_incr_hp_n_func(int, int, int);
+extern MR_Word MR_tag_offset_incr_hp_atomic_func(int, int, int);
+#endif /* MR_CONSERVATIVE_GC */
+extern void MR_unravel_univ_func(MR_Word, MR_TypeInfo *, MR_Word *);
+extern void MR_define_univ_fields_func(MR_Word, MR_TypeInfo, MR_Word);
+extern MR_Word MR_new_univ_on_hp_func(MR_TypeInfo, MR_Word);
+#endif /* MR_DEBUG_HEAP_ALLOC */
/*---------------------------------------------------------------------------*/
Index: runtime/mercury_deconstruct_macros.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_deconstruct_macros.h,v
retrieving revision 1.1
diff -u -b -r1.1 mercury_deconstruct_macros.h
--- runtime/mercury_deconstruct_macros.h 9 Jan 2002 07:49:51 -0000 1.1
+++ runtime/mercury_deconstruct_macros.h 3 Apr 2003 11:53:57 -0000
@@ -62,7 +62,7 @@
(ei).args_field.num_extra_args]); \
\
/* Join the argument to the front of the list */ \
- var = MR_list_cons_msg(arg, var, MR_PROC_LABEL); \
+ var = MR_univ_list_cons_msg(arg, var, MR_PROC_LABEL); \
} \
} while (0)
Index: runtime/mercury_deep_copy_body.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_deep_copy_body.h,v
retrieving revision 1.61
diff -u -b -r1.61 mercury_deep_copy_body.h
--- runtime/mercury_deep_copy_body.h 13 May 2003 08:52:06 -0000 1.61
+++ runtime/mercury_deep_copy_body.h 22 May 2003 04:14:09 -0000
@@ -79,8 +79,6 @@
return (rettype) (pointer)[offset]); \
} while (0)
-
-
MR_Word
copy(MR_Word data, MR_TypeInfo type_info,
const MR_Word *lower_limit, const MR_Word *upper_limit)
@@ -226,13 +224,14 @@
} else { \
cell_size = 1 + arity; \
} \
+ cell_size += MR_SIZE_SLOT_SIZE; \
\
if (exist_info == NULL) { \
+ MR_offset_incr_saved_hp(new_data, MR_SIZE_SLOT_SIZE, \
+ cell_size); \
\
- MR_incr_saved_hp(new_data, cell_size); \
- \
+ MR_copy_size_slot(0, new_data, ptag, data); \
MR_get_first_slot(have_sectag); \
- \
} else { \
int num_ti_plain; \
int num_tci; \
@@ -241,8 +240,10 @@
num_tci = exist_info->MR_exist_tcis; \
cell_size += num_ti_plain + num_tci; \
\
- MR_incr_saved_hp(new_data, cell_size); \
+ MR_offset_incr_saved_hp(new_data, MR_SIZE_SLOT_SIZE, \
+ cell_size); \
\
+ MR_copy_size_slot(0, new_data, ptag, data); \
MR_get_first_slot(have_sectag); \
\
for (i = 0; i < num_ti_plain; i++) { \
@@ -383,10 +384,9 @@
RETURN_IF_OUT_OF_RANGE(data, (MR_Word *) data, 0, MR_Word);
{
- MR_incr_saved_hp_atomic(new_data,
- (strlen((MR_String) data) + sizeof(MR_Word)) /
- sizeof(MR_Word));
- strcpy((MR_String) new_data, (MR_String) data);
+ MR_make_aligned_string_copy_saved_hp(
+ (MR_LVALUE_CAST(MR_String, new_data)),
+ (MR_String) data);
leave_forwarding_pointer(data, 0, new_data);
}
}
@@ -422,8 +422,8 @@
args = old_closure->MR_closure_num_hidden_args;
/* create new closure */
- MR_incr_saved_hp(MR_LVALUE_CAST(MR_Word, new_closure),
- args + 3);
+ MR_offset_incr_saved_hp(MR_LVALUE_CAST(MR_Word, new_closure),
+ 0, args + 3);
/* copy the fixed fields */
new_closure->MR_closure_layout = closure_layout;
@@ -481,7 +481,9 @@
new_data = (MR_Word) NULL;
} else {
/* allocate space for the new tuple */
- MR_incr_saved_hp(new_data, arity);
+ MR_offset_incr_saved_hp(new_data, MR_SIZE_SLOT_SIZE,
+ MR_SIZE_SLOT_SIZE + arity);
+ MR_copy_size_slot(0, new_data, 0, data);
new_data_ptr = (MR_Word *) new_data;
arg_typeinfo_vector =
@@ -521,7 +523,7 @@
old_array = (MR_ArrayType *) data_value;
array_size = old_array->size;
- MR_incr_saved_hp(new_data, array_size + 1);
+ MR_offset_incr_saved_hp(new_data, 0, array_size + 1);
new_array = (MR_ArrayType *) new_data;
new_array->size = array_size;
for (i = 0; i < array_size; i++) {
@@ -618,7 +620,7 @@
RETURN_IF_OUT_OF_RANGE(data, ref, 0, MR_Word);
- MR_incr_saved_hp(new_data, 1);
+ MR_offset_incr_saved_hp(new_data, 0, 1);
new_ref = (MR_Word *) new_data;
*new_ref = copy_arg(NULL, *ref, NULL,
MR_TYPEINFO_GET_FIXED_ARITY_ARG_VECTOR(type_info),
@@ -706,14 +708,16 @@
arity = MR_TYPEINFO_GET_VAR_ARITY_ARITY(type_info);
type_info_args =
MR_TYPEINFO_GET_VAR_ARITY_ARG_VECTOR(type_info);
- MR_incr_saved_hp(MR_LVALUE_CAST(MR_Word, new_type_info_arena),
+ MR_offset_incr_saved_hp(
+ MR_LVALUE_CAST(MR_Word, new_type_info_arena), 0,
MR_var_arity_type_info_size(arity));
MR_fill_in_var_arity_type_info(new_type_info_arena,
type_ctor_info, arity, new_type_info_args);
} else {
arity = type_ctor_info->MR_type_ctor_arity;
type_info_args = MR_TYPEINFO_GET_FIXED_ARITY_ARG_VECTOR(type_info);
- MR_incr_saved_hp(MR_LVALUE_CAST(MR_Word, new_type_info_arena),
+ MR_offset_incr_saved_hp(
+ MR_LVALUE_CAST(MR_Word, new_type_info_arena), 0,
MR_fixed_arity_type_info_size(arity));
MR_fill_in_fixed_arity_type_info(new_type_info_arena,
type_ctor_info, new_type_info_args);
@@ -762,7 +766,7 @@
- num_instance_constraints;
num_super = MR_typeclass_info_num_superclasses(typeclass_info);
num_arg_typeinfos = MR_typeclass_info_num_type_infos(typeclass_info);
- MR_incr_saved_hp(MR_LVALUE_CAST(MR_Word, new_typeclass_info),
+ MR_offset_incr_saved_hp(MR_LVALUE_CAST(MR_Word, new_typeclass_info), 0,
num_instance_constraints + num_super + num_arg_typeinfos + 1);
new_typeclass_info[0] = (MR_Word) base_typeclass_info;
Index: runtime/mercury_deep_profiling.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_deep_profiling.h,v
retrieving revision 1.10
diff -u -b -r1.10 mercury_deep_profiling.h
--- runtime/mercury_deep_profiling.h 8 Nov 2002 00:45:41 -0000 1.10
+++ runtime/mercury_deep_profiling.h 7 Apr 2003 07:07:29 -0000
@@ -11,7 +11,8 @@
#ifndef MERCURY_DEEP_PROFILING_H
#define MERCURY_DEEP_PROFILING_H
-#include "mercury_stack_layout.h"
+#include "mercury_types.h" /* for MR_ConstString etc */
+#include "mercury_proc_id.h" /* for MR_Proc_Id */
#include "mercury_ho_call.h"
#include <stdio.h>
Index: runtime/mercury_engine.c
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_engine.c,v
retrieving revision 1.43
diff -u -b -r1.43 mercury_engine.c
--- runtime/mercury_engine.c 3 May 2003 04:49:38 -0000 1.43
+++ runtime/mercury_engine.c 9 May 2003 02:10:34 -0000
@@ -56,6 +56,7 @@
{ "ordreg", MR_ORDINARY_REG_FLAG },
{ "anyreg", MR_ANY_REG_FLAG },
{ "printlocn", MR_PRINT_LOCN_FLAG },
+ { "enabled", MR_LLD_DEBUG_ENABLED_FLAG },
{ "notnearest", MR_NOT_NEAREST_FLAG },
{ "detail", MR_DETAILFLAG }
};
Index: runtime/mercury_engine.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_engine.h,v
retrieving revision 1.31
diff -u -b -r1.31 mercury_engine.h
--- runtime/mercury_engine.h 3 May 2003 04:49:38 -0000 1.31
+++ runtime/mercury_engine.h 9 May 2003 02:11:22 -0000
@@ -61,9 +61,10 @@
#define MR_ORDINARY_REG_FLAG 15
#define MR_ANY_REG_FLAG 16
#define MR_PRINT_LOCN_FLAG 17
-#define MR_NOT_NEAREST_FLAG 18
-#define MR_DETAILFLAG 19
-#define MR_MAXFLAG 20
+#define MR_LLD_DEBUG_ENABLED_FLAG 18
+#define MR_NOT_NEAREST_FLAG 19
+#define MR_DETAILFLAG 20
+#define MR_MAXFLAG 21
/* MR_DETAILFLAG should be the last real flag */
/*
@@ -118,6 +119,9 @@
** MR_printlocndebug controls whether we want to get diagnostics showing how
** the runtime system looks up locations recorded in RTTI data structures.
**
+** MR_lld_debug_enabled turns on the generation of diagnostic output even when
+** they would otherwise be disabled.
+**
** MR_not_nearest_flag, if set, tells minimal model tabling to save stack
** segments only to the nearest generator, not to the nearest common ancestor
** of the consumer being suspended and its generator.
@@ -141,6 +145,7 @@
#define MR_ordregdebug MR_debugflag[MR_ORDINARY_REG_FLAG]
#define MR_anyregdebug MR_debugflag[MR_ANY_REG_FLAG]
#define MR_printlocndebug MR_debugflag[MR_PRINT_LOCN_FLAG]
+#define MR_lld_debug_enabled MR_debugflag[MR_LLD_DEBUG_ENABLED_FLAG]
#define MR_not_nearest_flag MR_debugflag[MR_NOT_NEAREST_FLAG]
#define MR_detaildebug MR_debugflag[MR_DETAILFLAG]
Index: runtime/mercury_grade.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_grade.h,v
retrieving revision 1.47
diff -u -b -r1.47 mercury_grade.h
--- runtime/mercury_grade.h 21 Mar 2003 08:00:29 -0000 1.47
+++ runtime/mercury_grade.h 25 Mar 2003 02:30:09 -0000
@@ -332,8 +332,21 @@
#endif
#endif
-#define MR_GRADE MR_GRADE_PART_13
-#define MR_GRADE_OPT MR_GRADE_OPT_PART_13
+#ifdef MR_RECORD_TERM_SIZES
+ #ifdef MR_RECORD_TERM_SIZES_AS_CELLS
+ #define MR_GRADE_PART_14 MR_PASTE2(MR_GRADE_PART_13, _tsc)
+ #define MR_GRADE_OPT_PART_14 MR_GRADE_OPT_PART_13 ".tsc"
+ #else
+ #define MR_GRADE_PART_14 MR_PASTE2(MR_GRADE_PART_13, _tsw)
+ #define MR_GRADE_OPT_PART_14 MR_GRADE_OPT_PART_13 ".tsw"
+ #endif
+#else
+ #define MR_GRADE_PART_14 MR_GRADE_PART_13
+ #define MR_GRADE_OPT_PART_14 MR_GRADE_OPT_PART_13
+#endif
+
+#define MR_GRADE MR_GRADE_PART_14
+#define MR_GRADE_OPT MR_GRADE_OPT_PART_14
#define MR_GRADE_VAR MR_PASTE2(MR_grade_,MR_GRADE)
#define MR_GRADE_STRING MR_STRINGIFY(MR_GRADE)
Index: runtime/mercury_heap.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_heap.h,v
retrieving revision 1.27
diff -u -b -r1.27 mercury_heap.h
--- runtime/mercury_heap.h 22 Nov 2002 08:50:41 -0000 1.27
+++ runtime/mercury_heap.h 26 May 2003 12:55:35 -0000
@@ -10,12 +10,14 @@
#define MERCURY_HEAP_H
#include "mercury_conf.h" /* for MR_CONSERVATIVE_GC */
+#include "mercury_conf_param.h" /* for MR_RECORD_TERM_SIZES */
#include "mercury_types.h" /* for `MR_Word' */
#include "mercury_context.h" /* for min_heap_reclamation_point() */
#include "mercury_heap_profile.h" /* for MR_record_allocation() */
#include "mercury_deep_profiling.h" /* for MR_current_call_site_dynamic */
#include "mercury_std.h" /* for MR_EXTERN_INLINE */
#include "mercury_reg_workarounds.h" /* for MR_memcpy */
+#include "mercury_debug.h" /* for MR_debugtagoffsetincrhp* */
#ifdef MR_HIGHLEVEL_CODE
#include "mercury.h" /* for MR_new_object() */
#endif
@@ -29,12 +31,42 @@
#include "gc.h"
#endif
- #define MR_tag_incr_hp_n(dest, tag, count) \
- ((dest) = (MR_Word) MR_mkword((tag), \
- (MR_Word) GC_MALLOC((count) * sizeof(MR_Word))))
- #define MR_tag_incr_hp_atomic(dest, tag, count) \
- ((dest) = (MR_Word) MR_mkword((tag), \
- (MR_Word) GC_MALLOC_ATOMIC((count) * sizeof(MR_Word))))
+ /*
+ ** Unfortunately, the following macros cannot expand to statements;
+ ** they must be usable inside expressions. The ultimate reason for this is
+ ** MR_float_to_word, which is used not just as an operand in expressions,
+ ** but also as an initializer in static cells generated by the compiler.
+ */
+
+ #ifdef MR_DEBUG_HEAP_ALLOC
+
+ #define MR_tag_offset_sanity_check(offset, count) \
+ ( ((offset) >= (count)) \
+ ? MR_fatal_error("MR_tag_offset_sanity_check failed") \
+ : ((void) 0) \
+ )
+
+ #else /* ! MR_DEBUG_HEAP_ALLOC */
+
+ #define MR_tag_offset_sanity_check(offset, count) ((void) 0)
+
+ #endif /* MR_DEBUG_HEAP_ALLOC */
+
+ #define MR_tag_offset_incr_hp_base(dest, tag, offset, count, alloc) \
+ ( \
+ MR_tag_offset_sanity_check((offset), (count)), \
+ (dest) = (MR_Word) MR_mkword((tag), (MR_Word) \
+ ((MR_Word *) alloc((count) * sizeof(MR_Word))) \
+ + (offset)), \
+ MR_debugtagoffsetincrhpn(MR_tag_offset_incr_malloc, \
+ (dest), (tag), (offset), (count)), \
+ /* return */ (dest) \
+ )
+
+ #define MR_tag_offset_incr_hp_n(dest, tag, offset, count) \
+ MR_tag_offset_incr_hp_base(dest, tag, offset, count, GC_MALLOC)
+ #define MR_tag_offset_incr_hp_atomic(dest, tag, offset, count) \
+ MR_tag_offset_incr_hp_base(dest, tag, offset, count, GC_MALLOC_ATOMIC)
#ifdef MR_INLINE_ALLOC
@@ -67,22 +99,23 @@
#endif
#include "gc_inl.h"
- #define MR_tag_incr_hp(dest, tag, count) \
+ #define MR_tag_offset_incr_hp(dest, tag, offset, count) \
( __builtin_constant_p(count) && (count) < 16 \
? ({ void * temp; \
/* if size > 1, round up to an even number of words */ \
MR_Word num_words = ((count) == 1 ? 1 : \
2 * (((count) + 1) / 2)); \
GC_MALLOC_WORDS(temp, num_words); \
+ temp = (void *) (((MR_Word *) temp) + (offset)); \
(dest) = (MR_Word) MR_mkword((tag), temp); \
}) \
- : MR_tag_incr_hp_n((dest), (tag), (count)) \
+ : MR_tag_offset_incr_hp_n((dest), (tag), (offset), (count)) \
)
#else /* not MR_INLINE_ALLOC */
- #define MR_tag_incr_hp(dest, tag, count) \
- MR_tag_incr_hp_n((dest), (tag), (count))
+ #define MR_tag_offset_incr_hp(dest, tag, offset, count) \
+ MR_tag_offset_incr_hp_n((dest), (tag), (offset), (count))
#endif /* not MR_INLINE_ALLOC */
@@ -105,16 +138,17 @@
#else /* not MR_CONSERVATIVE_GC */
- #define MR_tag_incr_hp(dest, tag, count) \
+ #define MR_tag_offset_incr_hp(dest, tag, offset, count) \
( \
- (dest) = (MR_Word) MR_mkword(tag, (MR_Word) MR_hp),\
+ (dest) = (MR_Word) MR_mkword(tag, (MR_Word) \
+ (((MR_Word *) MR_hp) + (offset))), \
MR_debugincrhp(count, MR_hp), \
MR_hp += (count), \
MR_heap_overflow_check(), \
(void) 0 \
)
- #define MR_tag_incr_hp_atomic(dest, tag, count) \
- MR_tag_incr_hp((dest), (tag), (count))
+ #define MR_tag_offset_incr_hp_atomic(dest, tag, offset, count) \
+ MR_tag_offset_incr_hp((dest), (tag), (offset), (count))
#define MR_mark_hp(dest) ((dest) = (MR_Word) MR_hp)
@@ -166,33 +200,55 @@
((void) 0)
#endif
-#define MR_tag_incr_hp_msg(dest, tag, count, proclabel, type) \
+#define MR_tag_offset_incr_hp_msg(dest, tag, offset, count, proclabel, type) \
( \
MR_maybe_record_allocation((count), proclabel, (type)), \
- MR_tag_incr_hp((dest), (tag), (count)) \
+ MR_tag_offset_incr_hp((dest), (tag), (offset), (count)) \
)
-#define MR_tag_incr_hp_atomic_msg(dest, tag, count, proclabel, type) \
+#define MR_tag_offset_incr_hp_atomic_msg(dest, tag, offset, count, proclabel, type) \
( \
MR_maybe_record_allocation((count), proclabel, (type)), \
- MR_tag_incr_hp_atomic((dest), (tag), (count)) \
+ MR_tag_offset_incr_hp_atomic((dest), (tag), (offset), (count)) \
)
+#define MR_tag_incr_hp(dest, tag, count) \
+ MR_tag_offset_incr_hp((dest), (tag), 0, (count))
+#define MR_tag_incr_hp_atomic(dest, tag, count) \
+ MR_tag_offset_incr_hp_atomic((dest), (tag), 0, (count))
+#define MR_tag_incr_hp_msg(dest, tag, count, proclabel, type) \
+ MR_tag_offset_incr_hp_msg((dest), (tag), 0, (count), \
+ proclabel, (type))
+#define MR_tag_incr_hp_atomic_msg(dest, tag, count, proclabel, type) \
+ MR_tag_offset_incr_hp_atomic_msg((dest), (tag), 0, (count), \
+ proclabel, (type))
+
/*
** The MR_incr_hp*() macros are defined in terms of the MR_tag_incr_hp*()
** macros. Note: the `proclabel' argument is not parenthesized, since it must
** be a label name; we may need to prefix `_entry_' in front of it,
** which wouldn't work if it was parenthesized.
*/
+
+#define MR_offset_incr_hp(dest, offset, count) \
+ MR_tag_offset_incr_hp((dest), MR_mktag(0), (offset), (count))
+#define MR_offset_incr_hp_msg(dest, offset, count, proclabel, type) \
+ MR_tag_offset_incr_hp_msg((dest), MR_mktag(0), \
+ (offset), (count), proclabel, (type))
+#define MR_offset_incr_hp_atomic(dest, offset, count) \
+ MR_tag_offset_incr_hp_atomic((dest), MR_mktag(0), (offset), (count))
+#define MR_offset_incr_hp_atomic_msg(dest, offset, count, proclabel, type) \
+ MR_tag_offset_incr_hp_atomic_msg((dest), MR_mktag(0), \
+ (offset), (count), proclabel, (type))
+
#define MR_incr_hp(dest, count) \
- MR_tag_incr_hp((dest), MR_mktag(0), (count))
+ MR_offset_incr_hp((dest), 0, (count))
#define MR_incr_hp_msg(dest, count, proclabel, type) \
- MR_tag_incr_hp_msg((dest), MR_mktag(0), (count), \
- proclabel, (type))
+ MR_offset_incr_hp_msg((dest), 0, (count), proclabel, (type))
#define MR_incr_hp_atomic(dest, count) \
- MR_tag_incr_hp_atomic((dest), MR_mktag(0), (count))
+ MR_offset_incr_hp_atomic((dest), 0, (count))
#define MR_incr_hp_atomic_msg(dest, count, proclabel, type) \
- MR_tag_incr_hp_atomic_msg((dest), MR_mktag(0), (count), \
- proclabel, (type))
+ MR_offset_incr_hp_atomic_msg((dest), 0, (count), proclabel, (type))
+
#define MR_incr_hp_type(dest, typename) \
do { \
MR_Word tmp; \
@@ -215,12 +271,12 @@
** Note that this code is also duplicated in mercury.c.
*/
-MR_EXTERN_INLINE MR_Word MR_create1(MR_Word w1);
-MR_EXTERN_INLINE MR_Word MR_create2(MR_Word w1, MR_Word w2);
-MR_EXTERN_INLINE MR_Word MR_create3(MR_Word w1, MR_Word w2, MR_Word w3) ;
+MR_EXTERN_INLINE MR_Word MR_create1_func(MR_Word w1);
+MR_EXTERN_INLINE MR_Word MR_create2_func(MR_Word w1, MR_Word w2);
+MR_EXTERN_INLINE MR_Word MR_create3_func(MR_Word w1, MR_Word w2, MR_Word w3);
MR_EXTERN_INLINE MR_Word
-MR_create1(MR_Word w1)
+MR_create1_func(MR_Word w1)
{
MR_Word *p = (MR_Word *) MR_new_object(MR_Word, 1 * sizeof(MR_Word),
"create1");
@@ -229,7 +285,7 @@
}
MR_EXTERN_INLINE MR_Word
-MR_create2(MR_Word w1, MR_Word w2)
+MR_create2_func(MR_Word w1, MR_Word w2)
{
MR_Word *p = (MR_Word *) MR_new_object(MR_Word, 2 * sizeof(MR_Word),
"create2");
@@ -239,7 +295,7 @@
}
MR_EXTERN_INLINE MR_Word
-MR_create3(MR_Word w1, MR_Word w2, MR_Word w3)
+MR_create3_func(MR_Word w1, MR_Word w2, MR_Word w3)
{
MR_Word *p = (MR_Word *) MR_new_object(MR_Word, 3 * sizeof(MR_Word),
"create3");
@@ -249,12 +305,25 @@
return (MR_Word) p;
}
-#define MR_create1_msg(w1, proclabel, type) \
- MR_create1((w1))
-#define MR_create2_msg(w1, w2, proclabel, type) \
- MR_create2((w1), (w2))
-#define MR_create3_msg(w1, w2, w3, proclabel, type) \
- MR_create3((w1), (w2), (w3))
+#define MR_create1(ti1, w1) \
+ MR_create1_func((w1))
+#define MR_create2(ti1, w1, ti2, w2) \
+ MR_create2_func((w1), (w2))
+#define MR_create3(ti1, w1, ti2, w2, ti3, w3) \
+ MR_create3_func((w1), (w2), (w3))
+
+#define MR_create1_msg(ti1, w1, proclabel, type) \
+ MR_create1((ti1), (w1))
+#define MR_create2_msg(ti1, w1, ti2, w2, proclabel, type) \
+ MR_create2((ti1), (w1), (ti2), (w2))
+#define MR_create3_msg(ti1, w1, ti2, w2, ti3, w3, proclabel, type) \
+ MR_create3((ti1), (w1), (ti2), (w2), (ti3), (w3))
+
+/* term size profiling is not supported with MR_HIGHLEVEL_CODE */
+#define MR_SIZE_SLOT_SIZE 0
+#define MR_cell_size(arity) 0
+#define MR_define_size_slot(ptag, new, size) 0
+#define MR_copy_size_slot(nptag, new, optag, old) 0
#else /* ! MR_HIGHLEVEL_CODE */
@@ -264,64 +333,115 @@
** gcc's expression statements in the code below.
*/
+#ifdef MR_RECORD_TERM_SIZES
+ #define MR_SIZE_SLOT_SIZE 1
+ #ifdef MR_RECORD_TERM_SIZES_AS_CELLS
+ #define MR_cell_size(arity) 1
+ #else
+ #define MR_cell_size(arity) arity
+ #endif
+
+ #define MR_define_size_slot(ptag, new, size) \
+ do { \
+ MR_field(ptag, new, -1) = size; \
+ } while(0)
+ #define MR_copy_size_slot(nptag, new, optag, old) \
+ do { \
+ MR_field(nptag, new, -1) = MR_field(optag, old, -1); \
+ } while(0)
+ #define MR_fill_create1_size(hp, ti1, w1) \
+ ( \
+ hp[-2] = MR_term_size(ti1, w1) + MR_cell_size(1) \
+ )
+ #define MR_fill_create2_size(hp, ti1, w1, ti2, w2) \
+ ( \
+ hp[-3] = MR_term_size(ti1, w1) + MR_term_size(ti2, w2) \
+ + MR_cell_size(2) \
+ )
+ #define MR_fill_create3_size(hp, ti1, w1, ti2, w2, ti3, w3) \
+ ( \
+ hp[-4] = MR_term_size(ti1, w1) + MR_term_size(ti2, w2) \
+ + MR_term_size(ti3, w3) + MR_cell_size(3) \
+ )
+#else
+ #define MR_SIZE_SLOT_SIZE 0
+ #define MR_cell_size(arity) 0
+ #define MR_define_size_slot(ptag, new, size) 0
+ #define MR_copy_size_slot(nptag, new, optag, old) 0
+ #define MR_fill_create1_size(hp, ti1, w1) 0
+ #define MR_fill_create2_size(hp, ti1, w1, ti2, w2) 0
+ #define MR_fill_create3_size(hp, ti1, w1, ti2, w2, ti3, w3) 0
+#endif
+
/* used only by hand-written code not by the automatically generated code */
-#define MR_create1(w1) \
+#define MR_create1(ti1, w1) \
( \
- MR_hp_alloc(1), \
+ MR_hp_alloc(MR_SIZE_SLOT_SIZE + 1), \
MR_hp[-1] = (MR_Word) (w1), \
- MR_debugcr1(MR_hp[-1], MR_hp), \
+ MR_fill_create1_size(MR_hp, ti1, w1), \
+ MR_debugcr1(MR_hp), \
/* return */ (MR_Word) (MR_hp - 1) \
)
/* used only by hand-written code not by the automatically generated code */
-#define MR_create2(w1, w2) \
+#define MR_create2(ti1, w1, ti2, w2) \
( \
- MR_hp_alloc(2), \
+ MR_hp_alloc(MR_SIZE_SLOT_SIZE + 2), \
MR_hp[-2] = (MR_Word) (w1), \
MR_hp[-1] = (MR_Word) (w2), \
- MR_debugcr2(MR_hp[-2], MR_hp[-1], MR_hp), \
+ MR_fill_create2_size(MR_hp, ti1, w1, ti2, w2), \
+ MR_debugcr2(MR_hp), \
/* return */ (MR_Word) (MR_hp - 2) \
)
/* used only by hand-written code not by the automatically generated code */
-#define MR_create3(w1, w2, w3) \
+#define MR_create3(ti1, w1, ti2, w2, ti3, w3) \
( \
- MR_hp_alloc(3), \
+ MR_hp_alloc(MR_SIZE_SLOT_SIZE + 3), \
MR_hp[-3] = (MR_Word) (w1), \
MR_hp[-2] = (MR_Word) (w2), \
MR_hp[-1] = (MR_Word) (w3), \
+ MR_fill_create3_size(MR_hp, ti1, w1, ti2, w2, ti3, w3), \
+ MR_debugcr3(MR_hp), \
/* return */ (MR_Word) (MR_hp - 3) \
)
/* used only by hand-written code not by the automatically generated code */
-#define MR_create1_msg(w1,proclabel,type) \
+#define MR_create1_msg(ti1, w1, proclabel, type) \
( \
- MR_maybe_record_allocation(1, proclabel, (type)), \
- MR_hp_alloc(1), \
+ MR_maybe_record_allocation(MR_SIZE_SLOT_SIZE + 1, \
+ proclabel, (type)), \
+ MR_hp_alloc(MR_SIZE_SLOT_SIZE + 1), \
MR_hp[-1] = (MR_Word) (w1), \
- MR_debugcr1(MR_hp[-1], MR_hp), \
+ MR_fill_create1_size(MR_hp, ti1, w1), \
+ MR_debugcr1(MR_hp), \
/* return */ (MR_Word) (MR_hp - 1) \
)
/* used only by hand-written code not by the automatically generated code */
-#define MR_create2_msg(w1, w2, proclabel, type) \
+#define MR_create2_msg(ti1, w1, ti2, w2, proclabel, type) \
( \
- MR_maybe_record_allocation(2, proclabel, (type)), \
- MR_hp_alloc(2), \
+ MR_maybe_record_allocation(MR_SIZE_SLOT_SIZE + 2, \
+ proclabel, (type)), \
+ MR_hp_alloc(MR_SIZE_SLOT_SIZE + 2), \
MR_hp[-2] = (MR_Word) (w1), \
MR_hp[-1] = (MR_Word) (w2), \
- MR_debugcr2(MR_hp[-2], MR_hp[-1], MR_hp), \
+ MR_fill_create2_size(MR_hp, ti1, w1, ti2, w2), \
+ MR_debugcr2(MR_hp), \
/* return */ (MR_Word) (MR_hp - 2) \
)
/* used only by hand-written code not by the automatically generated code */
-#define MR_create3_msg(w1, w2, w3, proclabel, type) \
+#define MR_create3_msg(ti1, w1, ti2, w2, ti3, w3, proclabel, type) \
( \
- MR_maybe_record_allocation(3, proclabel, (type)), \
- MR_hp_alloc(3), \
+ MR_maybe_record_allocation(MR_SIZE_SLOT_SIZE + 3, \
+ proclabel, (type)), \
+ MR_hp_alloc(MR_SIZE_SLOT_SIZE + 3), \
MR_hp[-3] = (MR_Word) (w1), \
MR_hp[-2] = (MR_Word) (w2), \
MR_hp[-1] = (MR_Word) (w3), \
+ MR_fill_create3_size(MR_hp, ti1, w1, ti2, w2, ti3, w3), \
+ MR_debugcr3(MR_hp), \
/* return */ (MR_Word) (MR_hp - 3) \
)
@@ -333,19 +453,23 @@
** to sliding register windows).
** Remember to MR_save_transient_hp() before calls to such code, and
** MR_restore_transient_hp() after.
+**
+** There are intentionally no versions that do not specify an offset;
+** this is to force anyone who wants to allocate cells on the saved heap
+** to think about the impliciations of their code for term size profiling.
*/
-#define MR_incr_saved_hp(A, B) \
+#define MR_offset_incr_saved_hp(dest, offset, count) \
do { \
MR_restore_transient_hp(); \
- MR_incr_hp((A), (B)); \
+ MR_offset_incr_hp((dest), (offset), (count)); \
MR_save_transient_hp(); \
} while (0)
-#define MR_incr_saved_hp_atomic(A, B) \
+#define MR_offset_incr_saved_hp_atomic(dest, offset, count) \
do { \
MR_restore_transient_hp(); \
- MR_incr_hp_atomic((A), (B)); \
+ MR_offset_incr_hp_atomic((dest), (offset), (count)); \
MR_save_transient_hp(); \
} while (0)
@@ -369,6 +493,10 @@
/* XXX this assumes that nothing requires */ \
/* stricter alignment than MR_Float */ \
MR_make_hp_float_aligned(); \
+ /* \
+ ** This assumes that we don't keep term sizes \
+ ** in grades that use boxes. \
+ */ \
MR_incr_hp(MR_LVALUE_CAST(MR_Word, (box)), \
size_in_words); \
MR_assign_structure(*(T *)(box), (value)); \
Index: runtime/mercury_imp.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_imp.h,v
retrieving revision 1.20
diff -u -b -r1.20 mercury_imp.h
--- runtime/mercury_imp.h 18 Mar 2003 16:38:10 -0000 1.20
+++ runtime/mercury_imp.h 7 Apr 2003 07:27:14 -0000
@@ -84,6 +84,9 @@
#include "mercury_minimal_model.h"
#endif
+#include "mercury_univ.h"
+#include "mercury_term_size.h"
+
#include "mercury_grade.h"
#endif /* not MERCURY_IMP_H */
Index: runtime/mercury_init.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_init.h,v
retrieving revision 1.39
diff -u -b -r1.39 mercury_init.h
--- runtime/mercury_init.h 21 Aug 2002 11:27:42 -0000 1.39
+++ runtime/mercury_init.h 9 Apr 2003 02:55:54 -0000
@@ -1,5 +1,5 @@
/*
-** Copyright (C) 1993-2002 The University of Melbourne.
+** Copyright (C) 1993-2003 The University of Melbourne.
** This file may only be copied under the terms of the GNU Library General
** Public License - see the file COPYING.LIB in the Mercury distribution.
*/
@@ -78,14 +78,14 @@
#include "mercury_regs.h" /* must come before system headers */
#include "mercury_goto.h" /* for MR_declare_entry */
-#include "mercury_types.h" /* for MR_Word */
+#include "mercury_types.h" /* for MR_Word etc */
#include "mercury_wrapper.h" /* for MR_do_init_modules,
mercury_runtime_init(),
mercury_runtime_main(),
mercury_runtime_terminate(),
etc. */
#include "mercury_trace_base.h" /* for MR_trace_port */
-#include "mercury_type_info.h" /* for MR_TypeCtorInfo_Struct */
+#include "mercury_type_info.h" /* for MR_TypeCtorInfo_Struct etc */
#ifdef MR_CONSERVATIVE_GC
#ifdef MR_MPS_GC
@@ -124,6 +124,15 @@
extern void ML_io_print_to_stream(MR_Word, MR_Word, MR_Word);
extern void ML_io_print_to_cur_stream(MR_Word, MR_Word);
+
+/* in library/private_builtin.m */
+extern const MR_TypeCtorInfo MR_lib_type_ctor_info_for_univ;
+extern const MR_FA_TypeInfo_Struct1 MR_lib_type_info_for_type_info;
+extern const MR_FA_TypeInfo_Struct1 MR_lib_type_info_for_list_of_univ;
+extern const MR_FA_TypeInfo_Struct1 MR_lib_type_info_for_list_of_int;
+extern const MR_FA_TypeInfo_Struct1 MR_lib_type_info_for_list_of_char;
+extern const MR_FA_TypeInfo_Struct1 MR_lib_type_info_for_list_of_string;
+extern const MR_FA_TypeInfo_Struct1 MR_lib_type_info_for_list_of_type_info;
/* in trace/mercury_trace_internal.h */
extern char *MR_trace_getline(const char *, FILE *mdb_in, FILE *mdb_out);
Index: runtime/mercury_ml_expand_body.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_ml_expand_body.h,v
retrieving revision 1.28
diff -u -b -r1.28 mercury_ml_expand_body.h
--- runtime/mercury_ml_expand_body.h 13 May 2003 08:52:07 -0000 1.28
+++ runtime/mercury_ml_expand_body.h 15 May 2003 02:31:50 -0000
@@ -648,9 +648,7 @@
data_word = *data_word_ptr;
sprintf(buf, "%ld", (long) data_word);
- MR_incr_saved_hp_atomic(MR_LVALUE_CAST(MR_Word, str),
- (strlen(buf) + sizeof(MR_Word)) / sizeof(MR_Word));
- strcpy(str, buf);
+ MR_make_aligned_string_copy_saved_hp(str, buf);
expand_info->EXPAND_FUNCTOR_FIELD = str;
}
#endif /* EXPAND_FUNCTOR_FIELD */
@@ -662,13 +660,13 @@
#ifdef EXPAND_FUNCTOR_FIELD
{
/* XXX should escape characters correctly */
+ char buf[8];
MR_Word data_word;
char *str;
data_word = *data_word_ptr;
- MR_incr_saved_hp_atomic(MR_LVALUE_CAST(MR_Word, str),
- (3 + sizeof(MR_Word)) / sizeof(MR_Word));
- sprintf(str, "\'%c\'", (char) data_word);
+ sprintf(buf, "\'%c\'", (char) data_word);
+ MR_make_aligned_string_copy_saved_hp(str, buf);
expand_info->EXPAND_FUNCTOR_FIELD = str;
}
#endif /* EXPAND_FUNCTOR_FIELD */
@@ -687,9 +685,7 @@
data_word = *data_word_ptr;
f = MR_word_to_float(data_word);
MR_sprintf_float(buf, f);
- MR_incr_saved_hp_atomic(MR_LVALUE_CAST(MR_Word, str),
- (strlen(buf) + sizeof(MR_Word)) / sizeof(MR_Word));
- strcpy(str, buf);
+ MR_make_aligned_string_copy_saved_hp(str, buf);
expand_info->EXPAND_FUNCTOR_FIELD = str;
}
#endif /* EXPAND_FUNCTOR_FIELD */
@@ -705,10 +701,8 @@
char *str;
data_word = *data_word_ptr;
- MR_incr_saved_hp_atomic(MR_LVALUE_CAST(MR_Word, str),
- (strlen((MR_String) data_word) + 2 + sizeof(MR_Word))
- / sizeof(MR_Word));
- sprintf(str, "%c%s%c", '"', (MR_String) data_word, '"');
+ MR_make_aligned_string_copy_saved_hp_quote(str,
+ (MR_String) data_word);
expand_info->EXPAND_FUNCTOR_FIELD = str;
}
#endif /* EXPAND_FUNCTOR_FIELD */
Index: runtime/mercury_proc_id.h
===================================================================
RCS file: runtime/mercury_proc_id.h
diff -N runtime/mercury_proc_id.h
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ runtime/mercury_proc_id.h 7 Apr 2003 07:09:54 -0000
@@ -0,0 +1,67 @@
+/*
+** Copyright (C) 2003 The University of Melbourne.
+** This file may only be copied under the terms of the GNU Library General
+** Public License - see the file COPYING.LIB in the Mercury distribution.
+*/
+
+/* mercury_proc_id.h - definitions for recording procedure ids */
+
+#ifndef MERCURY_PROC_ID_H
+#define MERCURY_PROC_ID_H
+
+#include "mercury_types.h" /* for MR_ConstString etc */
+
+/*
+** This type indicates whether a procedure came from a predicate or a function.
+** This enum should EXACTLY match the definition of the `pred_or_func' type
+** in browser/util.m.
+*/
+
+typedef enum { MR_PREDICATE, MR_FUNCTION } MR_PredFunc;
+
+/*
+** MR_Proc_Id is a union. The usual alternative identifies ordinary
+** procedures, while the other alternative identifies automatically generated
+** unification, comparison and index procedures. The meanings of the fields
+** in both forms are the same as in procedure labels. The runtime system
+** can figure out which form is present by using the macro
+** MR_PROC_LAYOUT_COMPILER_GENERATED, which will return true only if
+** the procedure is of the second type.
+**
+** The compiler generates MR_User_Proc_Id and MR_Compiler_Proc_Id structures
+** in order to avoid having to initialize the MR_Proc_Id union through the
+** inapplicable alternative, since the C standard in widespread use now
+** doesn't support that.
+**
+** The places that know about the structure of procedure ids include
+** browser/dl.m and besides all the places that refer to the C types below.
+*/
+
+struct MR_User_Proc_Id_Struct {
+ MR_PredFunc MR_user_pred_or_func;
+ MR_ConstString MR_user_decl_module;
+ MR_ConstString MR_user_def_module;
+ MR_ConstString MR_user_name;
+ MR_int_least16_t MR_user_arity;
+ MR_int_least16_t MR_user_mode;
+};
+
+struct MR_Compiler_Proc_Id_Struct {
+ MR_ConstString MR_comp_type_name;
+ MR_ConstString MR_comp_type_module;
+ MR_ConstString MR_comp_def_module;
+ MR_ConstString MR_comp_pred_name;
+ MR_int_least16_t MR_comp_type_arity;
+ MR_int_least16_t MR_comp_mode;
+};
+
+union MR_Proc_Id_Union {
+ MR_User_Proc_Id MR_proc_user;
+ MR_Compiler_Proc_Id MR_proc_comp;
+};
+
+#define MR_PROC_ID_COMPILER_GENERATED(proc_id) \
+ ((MR_Unsigned) (proc_id).MR_proc_user.MR_user_pred_or_func \
+ > MR_FUNCTION)
+
+#endif /* not MERCURY_PROC_ID_H */
Index: runtime/mercury_stack_layout.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_stack_layout.h,v
retrieving revision 1.71
diff -u -b -r1.71 mercury_stack_layout.h
--- runtime/mercury_stack_layout.h 7 May 2003 03:21:46 -0000 1.71
+++ runtime/mercury_stack_layout.h 7 May 2003 05:22:37 -0000
@@ -33,16 +33,7 @@
#include "mercury_std.h" /* for MR_VARIABLE_SIZED */
#include "mercury_tags.h"
#include "mercury_type_info.h" /* for MR_PseudoTypeInfo */
-#include "mercury_tabling.h" /* for MR_TableNodeUnion,
- needed for MR_TrieNode */
-
-/*-------------------------------------------------------------------------*/
-/*
-** Definitions for MR_PredFunc. This enum should EXACTLY match the definition
-** of the `pred_or_func' type in browser/util.m.
-*/
-
-typedef enum { MR_PREDICATE, MR_FUNCTION } MR_PredFunc;
+#include "mercury_proc_id.h" /* for MR_Proc_Id */
/*-------------------------------------------------------------------------*/
/*
@@ -328,10 +319,10 @@
** are ground.
*/
-typedef struct MR_Type_Param_Locns_Struct {
+struct MR_Type_Param_Locns_Struct {
MR_uint_least32_t MR_tp_param_count;
MR_Long_Lval MR_tp_param_locns[MR_VARIABLE_SIZED];
-} MR_Type_Param_Locns;
+};
struct MR_Label_Layout_Struct {
const MR_Proc_Layout *MR_sll_entry;
@@ -533,54 +524,9 @@
MR_Determinism MR_trav_detism;
} MR_Stack_Traversal;
-/*
-** MR_Proc_Id is a union. The usual alternative identifies ordinary
-** procedures, while the other alternative identifies automatically generated
-** unification, comparison and index procedures. The meanings of the fields
-** in both forms are the same as in procedure labels. The runtime system
-** can figure out which form is present by using the macro
-** MR_PROC_LAYOUT_COMPILER_GENERATED, which will return true only if
-** the procedure is of the second type.
-**
-** The compiler generates MR_User_Proc_Id and MR_Compiler_Proc_Id structures
-** in order to avoid having to initialize the MR_Proc_Id union through the
-** inapplicable alternative, since the C standard in widespread use now
-** doesn't support that.
-**
-** The places that know about the structure of procedure ids include
-** browser/dl.m and besides all the places that refer to the C types below.
-*/
-
-typedef struct MR_User_Proc_Id_Struct {
- MR_PredFunc MR_user_pred_or_func;
- MR_ConstString MR_user_decl_module;
- MR_ConstString MR_user_def_module;
- MR_ConstString MR_user_name;
- MR_int_least16_t MR_user_arity;
- MR_int_least16_t MR_user_mode;
-} MR_User_Proc_Id;
-
-typedef struct MR_Compiler_Proc_Id_Struct {
- MR_ConstString MR_comp_type_name;
- MR_ConstString MR_comp_type_module;
- MR_ConstString MR_comp_def_module;
- MR_ConstString MR_comp_pred_name;
- MR_int_least16_t MR_comp_type_arity;
- MR_int_least16_t MR_comp_mode;
-} MR_Compiler_Proc_Id;
-
-typedef union MR_Proc_Id_Union {
- MR_User_Proc_Id MR_proc_user;
- MR_Compiler_Proc_Id MR_proc_comp;
-} MR_Proc_Id;
-
#define MR_PROC_LAYOUT_COMPILER_GENERATED(entry) \
MR_PROC_ID_COMPILER_GENERATED(entry->MR_sle_proc_id)
-#define MR_PROC_ID_COMPILER_GENERATED(proc_id) \
- ((MR_Unsigned) (proc_id).MR_proc_user.MR_user_pred_or_func \
- > MR_FUNCTION)
-
/*
** The MR_Exec_Trace structure contains the following fields.
**
@@ -688,6 +634,16 @@
MR_int_least8_t MR_exec_maybe_call_table;
} MR_Exec_Trace;
+#define MR_compute_max_mr_num(max_mr_num, layout) \
+ if (layout->MR_sll_entry->MR_sle_max_r_num + MR_NUM_SPECIAL_REG \
+ > MR_MAX_SPECIAL_REG_MR) \
+ { \
+ max_mr_num = layout->MR_sll_entry->MR_sle_max_r_num \
+ + MR_NUM_SPECIAL_REG; \
+ } else { \
+ max_mr_num = MR_MAX_SPECIAL_REG_MR; \
+ }
+
/*-------------------------------------------------------------------------*/
/*
** Definitions for MR_Proc_Layout
@@ -811,7 +767,8 @@
/* Adjust the arity of functions for printing. */
#define MR_sle_user_adjusted_arity(entry) \
((entry)->MR_sle_user.MR_user_arity - \
- (((entry)->MR_sle_user.MR_user_pred_or_func == MR_FUNCTION) ? 1 : 0))
+ (((entry)->MR_sle_user.MR_user_pred_or_func == MR_FUNCTION) \
+ ? 1 : 0))
/*
** Define a layout structure for a procedure, containing information
@@ -997,28 +954,28 @@
** MR_Proc_Id union through an inappropriate member.
*/
-typedef struct MR_Closure_Id_Struct {
+struct MR_Closure_Id_Struct {
MR_Proc_Id MR_closure_proc_id;
MR_ConstString MR_closure_module_name;
MR_ConstString MR_closure_file_name;
MR_Integer MR_closure_line_number;
MR_ConstString MR_closure_goal_path;
-} MR_Closure_Id;
+};
-typedef struct MR_User_Closure_Id_Struct {
+struct MR_User_Closure_Id_Struct {
MR_User_Proc_Id MR_user_closure_proc_id;
MR_ConstString MR_user_closure_module_name;
MR_ConstString MR_user_closure_file_name;
MR_Integer MR_user_closure_line_number;
MR_ConstString MR_user_closure_goal_path;
-} MR_User_Closure_Id;
+};
-typedef struct MR_Compiler_Closure_Id_Struct {
+struct MR_Compiler_Closure_Id_Struct {
MR_Compiler_Proc_Id MR_comp_closure_proc_id;
MR_ConstString MR_comp_closure_module_name;
MR_ConstString MR_comp_closure_file_name;
MR_Integer MR_comp_closure_line_number;
MR_ConstString MR_comp_closure_goal_path;
-} MR_Compiler_Closure_Id;
+};
#endif /* not MERCURY_STACK_LAYOUT_H */
Index: runtime/mercury_string.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_string.h,v
retrieving revision 1.29
diff -u -b -r1.29 mercury_string.h
--- runtime/mercury_string.h 22 Nov 2002 15:01:10 -0000 1.29
+++ runtime/mercury_string.h 9 Apr 2003 06:50:15 -0000
@@ -74,8 +74,9 @@
} \
} while(0)
-/* void MR_make_aligned_string_copy(MR_ConstString &ptr, const char * string);
-** Same as make_aligned_string(ptr, string), except that the string
+/*
+** void MR_make_aligned_string_copy(MR_ConstString &ptr, const char * string);
+** Same as MR_make_aligned_string(ptr, string), except that the string
** is guaranteed to be copied. This is useful for copying C strings
** onto the Mercury heap.
**
@@ -97,8 +98,46 @@
(ptr) = make_aligned_string_ptr; \
} while(0)
+/*
+** void MR_make_aligned_string_copy_saved_hp(MR_ConstString &ptr,
+** const char * string);
+** Same as MR_make_aligned_string_copy(ptr, string), except that
+** it uses MR_incr_saved_hp_atomic instead of MR_incr_hp_atomic.
+*/
+#define MR_make_aligned_string_copy_saved_hp(ptr, string) \
+ do { \
+ MR_Word make_aligned_string_tmp; \
+ char * make_aligned_string_ptr; \
+ \
+ MR_offset_incr_saved_hp_atomic(make_aligned_string_tmp, 0, \
+ (strlen(string) + sizeof(MR_Word)) / sizeof(MR_Word)); \
+ make_aligned_string_ptr = \
+ (char *) make_aligned_string_tmp; \
+ strcpy(make_aligned_string_ptr, (string)); \
+ (ptr) = make_aligned_string_ptr; \
+ } while(0)
+
+/*
+** void MR_make_aligned_string_copy_saved_hp_quote(MR_ConstString &ptr,
+** const char * string);
+** Same as MR_make_aligned_string_copy_saved_hp(ptr, string), except that
+** it puts double quote marks at the start and end of the string.
+*/
+#define MR_make_aligned_string_copy_saved_hp_quote(ptr, string) \
+ do { \
+ MR_Word make_aligned_string_tmp; \
+ char * make_aligned_string_ptr; \
+ \
+ MR_offset_incr_saved_hp_atomic(make_aligned_string_tmp, 0, \
+ (strlen(string) + 2 + sizeof(MR_Word)) / sizeof(MR_Word)); \
+ make_aligned_string_ptr = \
+ (char *) make_aligned_string_tmp; \
+ sprintf(make_aligned_string_ptr, "%c%s%c", '"', string, '"'); \
+ (ptr) = make_aligned_string_ptr; \
+ } while(0)
-/* void MR_allocate_aligned_string_msg(MR_ConstString &ptr, size_t len,
+/*
+** void MR_allocate_aligned_string_msg(MR_ConstString &ptr, size_t len,
** MR_Code *proclabel, const char *type);
** Allocate enough word aligned memory to hold len characters. Also
** record for memory profiling purposes the location, proclabel, of the
Index: runtime/mercury_tabling.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_tabling.h,v
retrieving revision 1.31
diff -u -b -r1.31 mercury_tabling.h
--- runtime/mercury_tabling.h 2 May 2003 21:44:16 -0000 1.31
+++ runtime/mercury_tabling.h 3 May 2003 07:50:07 -0000
@@ -284,9 +284,6 @@
#define MR_table_free(pointer) \
MR_GC_free((pointer))
- #define MR_table_list_cons(h, t) \
- MR_list_cons((h), (t))
-
#else /* MR_NATIVE_GC */
#define MR_TABLE_NATIVE_GC_MSG \
@@ -326,9 +323,6 @@
(void *) NULL)
#define MR_table_free(pointer) \
MR_fatal_error(MR_TABLE_NATIVE_GC_MSG)
- #define MR_table_list_cons(h, t) \
- (MR_fatal_error(MR_TABLE_NATIVE_GC_MSG), \
- (MR_Word) 0)
#endif /* MR_NATIVE_GC */
Index: runtime/mercury_tags.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_tags.h,v
retrieving revision 1.16
diff -u -b -r1.16 mercury_tags.h
--- runtime/mercury_tags.h 18 Feb 2002 07:01:21 -0000 1.16
+++ runtime/mercury_tags.h 9 Apr 2003 07:06:19 -0000
@@ -141,27 +141,27 @@
*/
extern const struct mercury__list__list_1_s
mercury__list__list_1__f_111_98_106_95_91_93_95_48;
- #define MR_list_empty()
+ #define MR_list_empty() \
((MR_Word) (& mercury__list__list_1__f_111_98_106_95_91_93_95_48))
#define MR_list_is_empty(list) ((list) == MR_list_empty())
#else
/*
** We use the primary tag to distinguish between empty and non-empty lists.
*/
+ #define MR_list_empty() ((MR_Word) MR_mkword(MR_TAG_NIL,\
+ MR_mkbody(0)))
#define MR_list_is_empty(list) (MR_tag(list) == MR_TAG_NIL)
- #define MR_list_empty() ((MR_Word) MR_mkword(MR_TAG_NIL, MR_mkbody(0)))
#endif
#define MR_list_head(list) MR_field(MR_TAG_CONS, (list), 0)
#define MR_list_tail(list) MR_field(MR_TAG_CONS, (list), 1)
- #define MR_list_cons(head,tail) ((MR_Word) MR_mkword(MR_TAG_CONS, \
- MR_create2((head),(tail))))
- #define MR_list_empty_msg(proclabel) \
- MR_list_empty()
- #define MR_list_cons_msg(head,tail,proclabel) \
+ #define MR_typed_list_cons(ti_head, head, ti_tail, tail) \
((MR_Word) MR_mkword(MR_TAG_CONS, \
- MR_create2_msg((head),(tail), \
- proclabel, "list:list/1")))
-
+ MR_create2((ti_head), (head), (ti_tail), (tail))))
+ #define MR_list_empty_msg(proclabel) MR_list_empty()
+ #define MR_typed_list_cons_msg(ti_head, head, ti_tail, tail, proclabel) \
+ ((MR_Word) MR_mkword(MR_TAG_CONS, \
+ MR_create2_msg((ti_head), (head), (ti_tail), (tail), \
+ proclabel, "list.list/1")))
#else
/*
** MR_TAGBITS == 0 &&
@@ -177,23 +177,101 @@
== MR_RAW_TAG_NIL)
#define MR_list_head(list) MR_field(MR_mktag(0), (list), 1)
#define MR_list_tail(list) MR_field(MR_mktag(0), (list), 2)
- #define MR_list_empty() ((MR_Word) MR_mkword(MR_mktag(0), \
- MR_create1(MR_RAW_TAG_NIL)))
- #define MR_list_cons(head,tail) ((MR_Word) MR_mkword(MR_mktag(0), \
- MR_create3(MR_RAW_TAG_CONS, \
- (head), (tail))))
+ #define MR_list_empty() \
+ ((MR_Word) MR_mkword(MR_mktag(0), \
+ MR_create1((MR_TypeInfo) \
+ &MR_TYPE_CTOR_INFO_NAME(builtin, void, 0), \
+ MR_RAW_TAG_NIL)))
+
+ #define MR_typed_list_cons(ti_head, head, ti_tail, tail) \
+ ((MR_Word) MR_mkword(MR_mktag(0), \
+ MR_create3((MR_TypeInfo) \
+ &MR_TYPE_CTOR_INFO_NAME(builtin, void, 0), \
+ MR_RAW_TAG_CONS, (ti_head), (head), (ti_tail), (tail))))
+
#define MR_list_empty_msg(proclabel) \
((MR_Word) MR_mkword(MR_mktag(0), \
- MR_create1_msg(MR_RAW_TAG_NIL, \
- proclabel, "list:list/1")))
- #define MR_list_cons_msg(head,tail,proclabel) \
+ MR_create1_msg((MR_TypeInfo) \
+ &MR_TYPE_CTOR_INFO_NAME(builtin, void, 0),\
+ MR_RAW_TAG_NIL, proclabel, "list:list/1")))
+ #define MR_typed_list_cons_msg(ti_head, head, ti_tail, tail, proclabel) \
((MR_Word) MR_mkword(MR_mktag(0), \
- MR_create3_msg(MR_RAW_TAG_CONS, \
- (head), (tail), \
+ MR_create3((MR_TypeInfo) \
+ &MR_TYPE_CTOR_INFO_NAME(builtin, void, 0), \
+ MR_RAW_TAG_CONS, (ti_head), (head), (ti_tail), (tail), \
proclabel, "list:list/1")))
+#endif
+/*
+** Since these macros are not defined in term size profiling grades,
+** their use in those grades will cause errors from the C compiler.
+** This is what we want: no visible change for existing users, and
+** no incorrect sizes in term profiling grades caused by the lack of
+** type information in these macros.
+*/
+
+#ifndef MR_RECORD_TERM_SIZES
+ #define MR_list_cons(head, tail) \
+ MR_typed_list_cons( \
+ (MR_TypeInfo) &MR_TYPE_CTOR_INFO_NAME(builtin, void, 0), \
+ (head), \
+ (MR_TypeInfo) &MR_TYPE_CTOR_INFO_NAME(builtin, void, 0), \
+ (tail))
+ #define MR_list_cons_msg(head, tail, proclabel) \
+ MR_typed_list_cons_msg( \
+ (MR_TypeInfo) &MR_TYPE_CTOR_INFO_NAME(builtin, void, 0), \
+ (head), \
+ (MR_TypeInfo) &MR_TYPE_CTOR_INFO_NAME(builtin, void, 0), \
+ (tail), proclabel)
#endif
+#define MR_univ_list_cons(head, tail) \
+ MR_typed_list_cons((MR_TypeInfo) MR_type_ctor_info_for_univ, (head), \
+ MR_type_info_for_list_of_univ, (tail))
+
+#define MR_univ_list_cons_msg(head, tail, proclabel) \
+ MR_typed_list_cons_msg( \
+ (MR_TypeInfo) MR_type_ctor_info_for_univ, (head), \
+ MR_type_info_for_list_of_univ, (tail), proclabel)
+
+#define MR_int_list_cons(head, tail) \
+ MR_typed_list_cons( \
+ (MR_TypeInfo) &MR_TYPE_CTOR_INFO_NAME(builtin, int, 0), \
+ (head), MR_type_info_for_list_of_int, (tail))
+
+#define MR_int_list_cons_msg(head, tail, proclabel) \
+ MR_typed_list_cons_msg( \
+ (MR_TypeInfo) &MR_TYPE_CTOR_INFO_NAME(builtin, int, 0), \
+ (head), MR_type_info_for_list_of_int, (tail), proclabel)
+
+#define MR_char_list_cons(head, tail) \
+ MR_typed_list_cons( \
+ (MR_TypeInfo) &MR_TYPE_CTOR_INFO_NAME(builtin, character, 0), \
+ (head), MR_type_info_for_list_of_char, (tail))
+
+#define MR_char_list_cons_msg(head, tail, proclabel) \
+ MR_typed_list_cons_msg( \
+ (MR_TypeInfo) &MR_TYPE_CTOR_INFO_NAME(builtin, character, 0), \
+ (head), MR_type_info_for_list_of_char, (tail), proclabel)
+
+#define MR_string_list_cons(head, tail) \
+ MR_typed_list_cons( \
+ (MR_TypeInfo) &MR_TYPE_CTOR_INFO_NAME(builtin, string, 0), \
+ (head), MR_type_info_for_list_of_string, (tail))
+
+#define MR_string_list_cons_msg(head, tail, proclabel) \
+ MR_typed_list_cons_msg( \
+ (MR_TypeInfo) &MR_TYPE_CTOR_INFO_NAME(builtin, string, 0), \
+ (head), MR_type_info_for_list_of_string, (tail), proclabel)
+
+#define MR_type_info_list_cons(head, tail) \
+ MR_typed_list_cons(MR_type_info_for_type_info, (head), \
+ MR_type_info_for_list_of_type_info, (tail))
+
+#define MR_type_info_list_cons_msg(head, tail, proclabel) \
+ MR_typed_list_cons_msg(MR_type_info_for_type_info, (head), \
+ MR_type_info_for_list_of_type_info, (tail), proclabel)
+
/*
** Convert an enumeration declaration into one which assigns the same
** values to the enumeration constants as Mercury's tag allocation scheme
@@ -228,6 +306,5 @@
#define MR_DEFINE_MERCURY_ENUM_CONST(x) x
#endif
-
#endif /* not MERCURY_TAGS_H */
Index: runtime/mercury_term_size.c
===================================================================
RCS file: runtime/mercury_term_size.c
diff -N runtime/mercury_term_size.c
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ runtime/mercury_term_size.c 19 May 2003 12:46:58 -0000
@@ -0,0 +1,304 @@
+/*
+** vim:ts=4 sw=4 expandtab
+*/
+/*
+** Copyright (C) 2003 The University of Melbourne.
+** This file may only be copied under the terms of the GNU Library General
+** Public License - see the file COPYING.LIB in the Mercury distribution.
+*/
+
+/*
+** mercury_term_size.c
+**
+** This module defines a function for measuring the sizes of terms.
+*/
+
+#include "mercury_imp.h"
+
+#ifdef MR_RECORD_TERM_SIZES
+
+MR_Unsigned
+MR_term_size(MR_TypeInfo type_info, MR_Word term)
+{
+ MR_TypeCtorInfo type_ctor_info;
+ MR_DuTypeLayout du_type_layout;
+ const MR_DuPtagLayout *ptag_layout;
+ int ptag;
+ int sectag;
+
+try_again:
+ type_ctor_info = MR_TYPEINFO_GET_TYPE_CTOR_INFO(type_info);
+
+ if (! MR_type_ctor_has_valid_rep(type_ctor_info)) {
+ MR_fatal_error("MR_term_size: term of unknown representation");
+ }
+
+ switch (MR_type_ctor_rep(type_ctor_info)) {
+ case MR_TYPECTOR_REP_RESERVED_ADDR:
+ case MR_TYPECTOR_REP_RESERVED_ADDR_USEREQ:
+ /* XXX the code to handle these cases hasn't been written yet */
+ MR_fatal_error("MR_term_size: RESERVED_ADDR");
+
+ case MR_TYPECTOR_REP_DU:
+ case MR_TYPECTOR_REP_DU_USEREQ:
+ du_type_layout = MR_type_ctor_layout(type_ctor_info).MR_layout_du;
+ ptag = MR_tag(term);
+ ptag_layout = &du_type_layout[ptag];
+
+ switch (ptag_layout->MR_sectag_locn) {
+ case MR_SECTAG_NONE:
+#ifdef MR_DEBUG_TERM_SIZES
+ if (ptag_layout->MR_sectag_alternatives[0]->
+ MR_du_functor_orig_arity <= 0)
+ {
+ MR_fatal_error("MR_term_size: zero arity ptag none");
+ }
+
+ if (MR_heapdebug && MR_lld_print_enabled) {
+ printf("MR_term_size: du sectag none %p -> %d\n",
+ (void *) term,
+ (int) MR_field(MR_mktag(ptag), term, -1));
+ printf("type %s.%s/%d, functor %s\n",
+ type_ctor_info->MR_type_ctor_module_name,
+ type_ctor_info->MR_type_ctor_name,
+ type_ctor_info->MR_type_ctor_arity,
+ ptag_layout->MR_sectag_alternatives[0]->
+ MR_du_functor_name);
+ }
+#endif
+ return MR_field(MR_mktag(ptag), term, -1);
+
+ case MR_SECTAG_LOCAL:
+#ifdef MR_DEBUG_TERM_SIZES
+ if (MR_heapdebug && MR_lld_print_enabled) {
+ printf("MR_term_size: du sectag local %p\n",
+ (void *) term);
+ }
+#endif
+ return 0;
+
+ case MR_SECTAG_REMOTE:
+#ifdef MR_DEBUG_TERM_SIZES
+ sectag = MR_field(MR_mktag(ptag), term, 0);
+
+ if (ptag_layout->MR_sectag_alternatives[sectag]->
+ MR_du_functor_orig_arity <= 0)
+ {
+ MR_fatal_error("MR_term_size: zero arity ptag remote");
+ }
+
+ if (MR_heapdebug && MR_lld_print_enabled) {
+ printf("MR_term_size: du sectag remote %p -> %d\n",
+ (void *) term,
+ (int) MR_field(MR_mktag(ptag), term, -1));
+ printf("type %s.%s/%d, functor %s\n",
+ type_ctor_info->MR_type_ctor_module_name,
+ type_ctor_info->MR_type_ctor_name,
+ type_ctor_info->MR_type_ctor_arity,
+ ptag_layout->MR_sectag_alternatives[sectag]->
+ MR_du_functor_name);
+ }
+#endif
+ return MR_field(MR_mktag(ptag), term, -1);
+
+ case MR_SECTAG_VARIABLE:
+ MR_fatal_error("MR_term_size: VARIABLE");
+
+ default:
+ fprintf(stderr, "sectag_locn: %d\n",
+ (int) ptag_layout->MR_sectag_locn);
+ MR_fatal_error("MR_term_size: sectag_locn");
+ }
+
+ case MR_TYPECTOR_REP_EQUIV:
+#ifdef MR_DEBUG_TERM_SIZES
+ if (MR_heapdebug && MR_lld_print_enabled) {
+ printf("MR_term_size: equiv %p\n", (void *) term);
+ }
+#endif
+ type_info = MR_create_type_info(
+ MR_TYPEINFO_GET_FIXED_ARITY_ARG_VECTOR(type_info),
+ MR_type_ctor_layout(type_ctor_info).MR_layout_equiv);
+ goto try_again;
+
+ case MR_TYPECTOR_REP_EQUIV_GROUND:
+#ifdef MR_DEBUG_TERM_SIZES
+ if (MR_heapdebug && MR_lld_print_enabled) {
+ printf("MR_term_size: equiv ground %p\n", (void *) term);
+ }
+#endif
+ type_info = MR_pseudo_type_info_is_ground(
+ MR_type_ctor_layout(type_ctor_info).MR_layout_equiv);
+ goto try_again;
+
+ case MR_TYPECTOR_REP_NOTAG:
+ case MR_TYPECTOR_REP_NOTAG_USEREQ:
+#ifdef MR_DEBUG_TERM_SIZES
+ if (MR_heapdebug && MR_lld_print_enabled) {
+ printf("MR_term_size: notag (usereq) %p\n", (void *) term);
+ }
+#endif
+ MR_save_transient_hp();
+ type_info = MR_create_type_info(
+ MR_TYPEINFO_GET_FIXED_ARITY_ARG_VECTOR(type_info),
+ MR_type_ctor_layout(type_ctor_info).MR_layout_notag->
+ MR_notag_functor_arg_type);
+ MR_restore_transient_hp();
+ goto try_again;
+
+ case MR_TYPECTOR_REP_NOTAG_GROUND:
+ case MR_TYPECTOR_REP_NOTAG_GROUND_USEREQ:
+#ifdef MR_DEBUG_TERM_SIZES
+ if (MR_heapdebug && MR_lld_print_enabled) {
+ printf("MR_term_size: notag ground (usereq) %p\n",
+ (void *) term);
+ }
+#endif
+ type_info = MR_pseudo_type_info_is_ground(
+ MR_type_ctor_layout(type_ctor_info).MR_layout_notag
+ ->MR_notag_functor_arg_type);
+ goto try_again;
+
+ case MR_TYPECTOR_REP_TUPLE:
+#ifdef MR_DEBUG_TERM_SIZES
+ if (MR_heapdebug && MR_lld_print_enabled) {
+ printf("MR_term_size: tuple %p -> %d\n",
+ (void *) term,
+ (int) MR_field(MR_mktag(0), term, -1));
+ }
+#endif
+ return MR_field(MR_mktag(0), term, -1);
+
+ case MR_TYPECTOR_REP_PRED:
+ case MR_TYPECTOR_REP_FUNC:
+#ifdef MR_DEBUG_TERM_SIZES
+ if (MR_heapdebug && MR_lld_print_enabled) {
+ printf("MR_term_size: pred/func %p\n", (void *) term);
+ }
+#endif
+ /* currently we don't collect stats on closure sizes */
+ return 0;
+
+ case MR_TYPECTOR_REP_ARRAY:
+ /* currently we don't collect stats on array sizes */
+#ifdef MR_DEBUG_TERM_SIZES
+ if (MR_heapdebug && MR_lld_print_enabled) {
+ printf("MR_term_size: array %p\n", (void *) term);
+ }
+#endif
+ return 0;
+
+ case MR_TYPECTOR_REP_ENUM:
+ case MR_TYPECTOR_REP_ENUM_USEREQ:
+#ifdef MR_DEBUG_TERM_SIZES
+ if (MR_heapdebug && MR_lld_print_enabled) {
+ printf("MR_term_size: enum (usereq) %p\n", (void *) term);
+ }
+#endif
+ return 0;
+
+ case MR_TYPECTOR_REP_INT:
+#ifdef MR_DEBUG_TERM_SIZES
+ if (MR_heapdebug && MR_lld_print_enabled) {
+ printf("MR_term_size: int %p %ld\n",
+ (void *) term, (long) term);
+ }
+#endif
+ return 0;
+
+ case MR_TYPECTOR_REP_CHAR:
+#ifdef MR_DEBUG_TERM_SIZES
+ if (MR_heapdebug && MR_lld_print_enabled) {
+ printf("MR_term_size: char %p %c\n",
+ (void *) term, (char) term);
+ }
+#endif
+ return 0;
+
+ case MR_TYPECTOR_REP_FLOAT:
+#ifdef MR_DEBUG_TERM_SIZES
+ if (MR_heapdebug && MR_lld_print_enabled) {
+ printf("MR_term_size: float %p\n", (void *) term);
+ }
+#endif
+ return 0;
+
+ case MR_TYPECTOR_REP_STRING:
+#ifdef MR_DEBUG_TERM_SIZES
+ if (MR_heapdebug && MR_lld_print_enabled) {
+ printf("MR_term_size: string %p '%s'\n",
+ (void *) term, (char *) term);
+ }
+#endif
+ return 0;
+
+ case MR_TYPECTOR_REP_SUCCIP:
+ case MR_TYPECTOR_REP_HP:
+ case MR_TYPECTOR_REP_CURFR:
+ case MR_TYPECTOR_REP_MAXFR:
+ case MR_TYPECTOR_REP_REDOFR:
+ case MR_TYPECTOR_REP_REDOIP:
+ case MR_TYPECTOR_REP_TRAIL_PTR:
+ case MR_TYPECTOR_REP_TICKET:
+#ifdef MR_DEBUG_TERM_SIZES
+ if (MR_heapdebug && MR_lld_print_enabled) {
+ printf("MR_term_size: impl artifact type %p\n", (void *) term);
+ }
+#endif
+ return 0;
+
+ case MR_TYPECTOR_REP_TYPEINFO:
+ case MR_TYPECTOR_REP_TYPECLASSINFO:
+ case MR_TYPECTOR_REP_TYPECTORINFO:
+ case MR_TYPECTOR_REP_BASETYPECLASSINFO:
+ case MR_TYPECTOR_REP_TYPEDESC:
+ case MR_TYPECTOR_REP_TYPECTORDESC:
+#ifdef MR_DEBUG_TERM_SIZES
+ if (MR_heapdebug && MR_lld_print_enabled) {
+ printf("MR_term_size: type_info etc %p\n", (void *) term);
+ }
+#endif
+ return 0;
+
+ case MR_TYPECTOR_REP_SUBGOAL:
+#ifdef MR_DEBUG_TERM_SIZES
+ if (MR_heapdebug && MR_lld_print_enabled) {
+ printf("MR_term_size: subgoal %p\n", (void *) term);
+ }
+#endif
+ return 0;
+
+ case MR_TYPECTOR_REP_C_POINTER:
+ case MR_TYPECTOR_REP_STABLE_C_POINTER:
+ case MR_TYPECTOR_REP_FOREIGN:
+#ifdef MR_DEBUG_TERM_SIZES
+ if (MR_heapdebug && MR_lld_print_enabled) {
+ printf("MR_term_size: c_pointer/foreign %p\n", (void *) term);
+ }
+#endif
+ return 0;
+
+ case MR_TYPECTOR_REP_REFERENCE:
+#ifdef MR_DEBUG_TERM_SIZES
+ if (MR_heapdebug && MR_lld_print_enabled) {
+ printf("MR_term_size: reference %p\n", (void *) term);
+ }
+#endif
+ return 1;
+
+ case MR_TYPECTOR_REP_VOID:
+ MR_fatal_error("MR_term_size: VOID");
+
+ case MR_TYPECTOR_REP_UNKNOWN:
+ MR_fatal_error("MR_term_size: UNKNOWN");
+
+ default:
+ fprintf(stderr, "default rep: %d\n",
+ (int) MR_type_ctor_rep(type_ctor_info));
+ MR_fatal_error("MR_term_size: default");
+ }
+
+ MR_fatal_error("MR_term_size: unexpected fallthrough");
+}
+
+#endif /* MR_RECORD_TERM_SIZES */
Index: runtime/mercury_term_size.h
===================================================================
RCS file: runtime/mercury_term_size.h
diff -N runtime/mercury_term_size.h
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ runtime/mercury_term_size.h 9 Apr 2003 07:39:07 -0000
@@ -0,0 +1,38 @@
+/*
+** vim:ts=4 sw=4 expandtab
+*/
+/*
+** Copyright (C) 2003 The University of Melbourne.
+** This file may only be copied under the terms of the GNU Library General
+** Public License - see the file COPYING.LIB in the Mercury distribution.
+*/
+
+/*
+** mercury_term_size.h
+**
+** This module declares functions for returning the sizes of terms.
+*/
+
+#ifndef MR_MERCURY_TERM_SIZE_H
+#define MR_MERCURY_TERM_SIZE_H
+
+#include "mercury_types.h"
+
+#ifdef MR_RECORD_TERM_SIZES
+
+extern MR_Unsigned MR_term_size(MR_TypeInfo type_info, MR_Word term);
+
+#else /* MR_RECORD_TERM_SIZES */
+
+/*
+** Term sizes are not meaningful if MR_RECORD_TERM_SIZES is not defined.
+** This macro, and others in mercury_heap.h, allows us to write code to
+** compute term sizes without worrying about whether MR_RECORD_TERM_SIZES
+** is defined or not.
+*/
+
+#define MR_term_size(type_info, term) 0
+
+#endif /* MR_RECORD_TERM_SIZES */
+
+#endif /* MR_MERCURY_TERM_SIZE_H */
Index: runtime/mercury_trace_base.c
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_trace_base.c,v
retrieving revision 1.50
diff -u -b -r1.50 mercury_trace_base.c
--- runtime/mercury_trace_base.c 8 Nov 2002 08:48:21 -0000 1.50
+++ runtime/mercury_trace_base.c 14 Apr 2003 05:03:25 -0000
@@ -26,6 +26,7 @@
#include "mercury_layout_util.h" /* for MR_generate_proc_name_from_layout */
#include "mercury_runtime_util.h" /* for strerror() on some systems */
#include "mercury_signal.h" /* for MR_setup_signal() */
+#include "mercury_builtin_types.h" /* for type_ctor_infos */
#include <signal.h> /* for SIGINT */
#include <stdio.h>
#include <errno.h>
@@ -318,6 +319,8 @@
&MR_init_call_num_hash, &MR_next_std_call_num);
}
+char *MR_trace_report_msg = NULL;
+
void
MR_trace_report(FILE *fp)
{
@@ -327,6 +330,10 @@
** which implies that the user wants trace info on abort.
*/
+ if (MR_trace_report_msg != NULL) {
+ fprintf(fp, "%s\n", MR_trace_report_msg);
+ }
+
if (MR_standardize_event_details) {
fprintf(fp, "Last trace event was event #E%ld.\n",
(long) MR_standardize_event_num(
@@ -376,6 +383,11 @@
** which implies that the user wants trace info on abort.
*/
+ if (MR_trace_report_msg != NULL) {
+ write(fd, MR_trace_report_msg,
+ strlen(MR_trace_report_msg));
+ }
+
if (MR_standardize_event_details) {
sprintf(buf, "Last trace event was event #E%ld.\n",
(long) MR_standardize_event_num(
@@ -440,7 +452,7 @@
table_io_decl->MR_table_io_decl_ptis[hv - 1]);
MR_restore_transient_hp();
MR_new_univ_on_hp(arg, type_info, answer_block[hv]);
- arg_list = MR_list_cons(arg, arg_list);
+ arg_list = MR_univ_list_cons(arg, arg_list);
MR_save_transient_hp();
}
Index: runtime/mercury_trace_base.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_trace_base.h,v
retrieving revision 1.32
diff -u -b -r1.32 mercury_trace_base.h
--- runtime/mercury_trace_base.h 18 Mar 2003 16:38:13 -0000 1.32
+++ runtime/mercury_trace_base.h 14 Apr 2003 05:01:19 -0000
@@ -287,6 +287,12 @@
extern void MR_trace_report_raw(int fd);
/*
+** If MR_trace_report_msg is not NULL, it will be included in messages
+** from MR_trace_report.
+*/
+extern char *MR_trace_report_msg;
+
+/*
** This function prints an error message and aborts. It should be
** called in situations where tracing is required, but `--trace' was
** not passed to c2init.
Index: runtime/mercury_type_info.c
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_type_info.c,v
retrieving revision 1.56
diff -u -b -r1.56 mercury_type_info.c
--- runtime/mercury_type_info.c 21 Mar 2003 08:00:30 -0000 1.56
+++ runtime/mercury_type_info.c 9 Apr 2003 06:55:59 -0000
@@ -16,7 +16,7 @@
#endif
#include "mercury_type_info.h"
#include "mercury_misc.h" /* for MR_fatal_error() */
-#include "mercury_heap.h" /* for incr_saved_hp() */
+#include "mercury_heap.h" /* for MR_incr_saved_hp() */
#include "mercury_builtin_types.h" /* for void/0's type_ctor_info */
/*---------------------------------------------------------------------------*/
@@ -62,13 +62,16 @@
do { \
/* reserve one extra word for GC forwarding pointer */ \
/* (see comments in compiler/mlds_to_c.m for details) */ \
- MR_incr_saved_hp(MR_LVALUE_CAST(MR_Word, (target)), 1); \
- MR_incr_saved_hp(MR_LVALUE_CAST(MR_Word, (target)), (size)); \
+ MR_offset_incr_saved_hp(MR_LVALUE_CAST(MR_Word, (target)), \
+ 0, 1); \
+ MR_offset_incr_saved_hp(MR_LVALUE_CAST(MR_Word, (target)), \
+ 0, (size)); \
} while (0)
#else /* !MR_NATIVE_GC */
#define ALLOCATE_WORDS(target, size) \
do { \
- MR_incr_saved_hp(MR_LVALUE_CAST(MR_Word, (target)), (size)); \
+ MR_offset_incr_saved_hp(MR_LVALUE_CAST(MR_Word, (target)), \
+ 0, (size)); \
} while (0)
#endif /* !MR_NATIVE_GC */
@@ -415,8 +418,8 @@
MR_restore_transient_registers();
type_info_list = MR_list_empty();
while (arity > 0) {
- type_info_list = MR_list_cons((MR_Word) type_params[arity],
- type_info_list);
+ type_info_list = MR_type_info_list_cons(
+ (MR_Word) type_params[arity], type_info_list);
--arity;
}
@@ -427,7 +430,6 @@
MR_Word
MR_arg_name_vector_to_list(int arity, const MR_ConstString *arg_names)
{
- MR_TypeInfo arg_type;
MR_Word arg_names_list;
MR_restore_transient_registers();
@@ -437,15 +439,14 @@
/* No arguments have names. */
while (arity > 0) {
--arity;
- arg_names_list =
- MR_list_cons((MR_Word) NULL, arg_names_list);
+ arg_names_list = MR_string_list_cons(
+ (MR_Word) NULL, arg_names_list);
}
} else {
while (arity > 0) {
--arity;
- arg_names_list =
- MR_list_cons((MR_Word) arg_names[arity],
- arg_names_list);
+ arg_names_list = MR_string_list_cons(
+ (MR_Word) arg_names[arity], arg_names_list);
}
}
@@ -476,8 +477,8 @@
arg_type_info = MR_collapse_equivalences(arg_type_info);
MR_restore_transient_registers();
- type_info_list = MR_list_cons((MR_Word) arg_type_info,
- type_info_list);
+ type_info_list = MR_type_info_list_cons(
+ (MR_Word) arg_type_info, type_info_list);
}
MR_save_transient_registers();
Index: runtime/mercury_type_info.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_type_info.h,v
retrieving revision 1.104
diff -u -b -r1.104 mercury_type_info.h
--- runtime/mercury_type_info.h 13 May 2003 08:52:08 -0000 1.104
+++ runtime/mercury_type_info.h 22 May 2003 04:26:02 -0000
@@ -11,7 +11,6 @@
** mercury_type_info.h -
** Definitions for accessing the type_infos, type_layouts, and
** type_functors tables generated by the Mercury compiler.
-** Also contains definitions for accessing the Mercury `univ' type.
**
** Changes to the structures of type_infos and pseudo_type_infos
** may also require changes in:
@@ -60,7 +59,7 @@
#include "mercury_std.h" /* for `MR_STRINGIFY', `MR_PASTEn' and MR_CALL */
#include "mercury_types.h" /* for `MR_Word' */
#include "mercury_tags.h" /* for `MR_CONVERT_C_ENUM_CONSTANT' */
-#include "mercury_hlc_types.h" /* for `MR_UnifyFunc*' */
+#include "mercury_hlc_types.h" /* for `MR_Mercury_Type_Info' */
/*---------------------------------------------------------------------------*/
@@ -98,23 +97,6 @@
/*---------------------------------------------------------------------------*/
-/* Forward declarations */
-
-typedef struct MR_TypeCtorInfo_Struct MR_TypeCtorInfo_Struct;
-typedef const struct MR_TypeCtorInfo_Struct *MR_TypeCtorInfo;
-typedef struct MR_TypeInfo_Almost_Struct *MR_TypeInfo;
-typedef const struct MR_PseudoTypeInfo_Almost_Struct *MR_PseudoTypeInfo;
-typedef const void *MR_ReservedAddr;
-typedef MR_TrieNode *MR_TrieNodePtr;
-
-#ifdef MR_HIGHLEVEL_CODE
- typedef MR_Box MR_BaseTypeclassInfo;
-#else
- typedef MR_Code *MR_BaseTypeclassInfo;
-#endif
-
-/*---------------------------------------------------------------------------*/
-
/*
** The C structures of typeinfos and pseudotypeinfos are sort of lies,
** for two reasons. First, we want one C type that can describe both first
@@ -184,9 +166,8 @@
}
/*
-** Now define specific versions of these struct types,
-** which are used by the MR_TypeInfo and MR_PseudoTypeInfo
-** typedefs above.
+** Now define specific versions of these struct types, which are used by
+** the MR_TypeInfo and MR_PseudoTypeInfo typedefs in mercury_types.h.
*/
MR_VAR_ARITY_TYPEINFO_STRUCT(MR_TypeInfo_Almost_Struct,
@@ -424,43 +405,6 @@
#define MR_UNBOUND 0
#endif
-
-/*---------------------------------------------------------------------------*/
-
-/*
-** Offsets for dealing with `univ' types.
-**
-** `univ' is represented as a two word structure.
-** The first word contains the address of a type_info for the type.
-** The second word contains the data.
-*/
-
-#define MR_UNIV_OFFSET_FOR_TYPEINFO 0
-#define MR_UNIV_OFFSET_FOR_DATA 1
-
-#define MR_unravel_univ(univ, typeinfo, value) \
- do { \
- typeinfo = (MR_TypeInfo) MR_field(MR_UNIV_TAG, (univ), \
- MR_UNIV_OFFSET_FOR_TYPEINFO); \
- value = MR_field(MR_UNIV_TAG, (univ), \
- MR_UNIV_OFFSET_FOR_DATA); \
- } while (0)
-
-#define MR_define_univ_fields(univ, typeinfo, value) \
- do { \
- MR_field(MR_UNIV_TAG, (univ), MR_UNIV_OFFSET_FOR_TYPEINFO) \
- = (MR_Word) (typeinfo); \
- MR_field(MR_UNIV_TAG, (univ), MR_UNIV_OFFSET_FOR_DATA) \
- = (MR_Word) (value); \
- } while (0)
-
-/* Allocate a univ on the heap */
-/* XXX we should use MR_tag_incr_hp_msg() here */
-#define MR_new_univ_on_hp(univ, typeinfo, value) \
- do { \
- MR_tag_incr_hp((univ), MR_UNIV_TAG, 2); \
- MR_define_univ_fields((univ), (typeinfo), (value)); \
- } while (0)
/*---------------------------------------------------------------------------*/
Index: runtime/mercury_types.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_types.h,v
retrieving revision 1.31
diff -u -b -r1.31 mercury_types.h
--- runtime/mercury_types.h 18 Mar 2003 16:38:13 -0000 1.31
+++ runtime/mercury_types.h 7 Apr 2003 07:31:24 -0000
@@ -111,13 +111,49 @@
#endif
/*
+** The MR_Box type is used for representing polymorphic types.
+** Currently this is only used in the MLDS C backend.
+**
+** Since it is used in some C code fragments, we define it as MR_Word
+** in the low-level backend.
+*/
+
+#ifdef MR_HIGHLEVEL_CODE
+ typedef void *MR_Box;
+#else
+ typedef MR_Word MR_Box;
+#endif
+
+/*
** These typedefs are forward declarations, used to avoid circular dependencies
** between header files.
*/
+typedef struct MR_TypeCtorInfo_Struct MR_TypeCtorInfo_Struct;
+typedef const struct MR_TypeCtorInfo_Struct *MR_TypeCtorInfo;
+typedef struct MR_TypeInfo_Almost_Struct *MR_TypeInfo;
+typedef const struct MR_PseudoTypeInfo_Almost_Struct *MR_PseudoTypeInfo;
+typedef const void *MR_ReservedAddr;
+
+#ifdef MR_HIGHLEVEL_CODE
+ typedef MR_Box MR_BaseTypeclassInfo;
+#else
+ typedef MR_Code *MR_BaseTypeclassInfo;
+#endif
+
typedef struct MR_Closure_Struct MR_Closure;
typedef const MR_Closure *MR_ClosurePtr;
+typedef struct MR_Closure_Id_Struct MR_Closure_Id;
+typedef struct MR_User_Closure_Id_Struct MR_User_Closure_Id;
+typedef struct MR_Compiler_Closure_Id_Struct MR_Compiler_Closure_Id;
+
+typedef struct MR_Type_Param_Locns_Struct MR_Type_Param_Locns;
+
+typedef struct MR_User_Proc_Id_Struct MR_User_Proc_Id;
+typedef struct MR_Compiler_Proc_Id_Struct MR_Compiler_Proc_Id;
+typedef union MR_Proc_Id_Union MR_Proc_Id;
+
typedef struct MR_CallSiteStatic_Struct MR_CallSiteStatic;
typedef struct MR_CallSiteDynamic_Struct MR_CallSiteDynamic;
typedef struct MR_User_ProcStatic_Struct MR_User_ProcStatic;
@@ -134,6 +170,7 @@
typedef union MR_TableNode_Union MR_TableNode;
typedef MR_TableNode *MR_TrieNode;
+typedef MR_TrieNode *MR_TrieNodePtr;
typedef struct MR_HashTable_Struct MR_HashTable;
typedef struct MR_Subgoal_Struct MR_Subgoal;
@@ -155,21 +192,5 @@
typedef struct MR_ConsumerDebug_Struct MR_ConsumerDebug;
typedef struct MR_SubgoalDebug_Struct MR_SubgoalDebug;
-
-/*---------------------------------------------------------------------------*/
-
-/*
-** The MR_Box type is used for representing polymorphic types.
-** Currently this is only used in the MLDS C backend.
-**
-** Since it is used in some C code fragments, we define it as MR_Word
-** in the low-level backend.
-*/
-
-#ifdef MR_HIGHLEVEL_CODE
- typedef void *MR_Box;
-#else
- typedef MR_Word MR_Box;
-#endif
#endif /* not MERCURY_TYPES_H */
Index: runtime/mercury_wrapper.c
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_wrapper.c,v
retrieving revision 1.119
diff -u -b -r1.119 mercury_wrapper.c
--- runtime/mercury_wrapper.c 10 Apr 2003 05:51:05 -0000 1.119
+++ runtime/mercury_wrapper.c 20 May 2003 09:40:26 -0000
@@ -129,13 +129,13 @@
** Getting low level debugging messages from *every* call, *every* heap
** allocation etc usually results in an avalanche of data that buries the
** information you are looking for, and often runs filesystems out of space.
-** Therefore we inhibit these messages unless any one of three conditions
+** Therefore we inhibit these messages unless any one of four conditions
** apply. We implement this by making MR_lld_print_enabled, which controls
** the printing of these messages, the logical OR of MR_lld_print_name_enabled,
-** MR_lld_print_csd_enabled and MR_lld_print_region_enabled, which are flags
-** implementing the three conditions. (We rely on these flags being 0 or 1
-** (i.e. MR_FALSE or MR_TRUE) so we can implement logical OR as bitwise OR,
-** which is faster.)
+** MR_lld_print_csd_enabled, MR_lld_print_region_enabled and
+** MR_lld_debug_enabled, which are flags implementing the four conditions.
+** (We rely on these flags being 0 or 1 (i.e. MR_FALSE or MR_TRUE) so we can
+** implement logical OR as bitwise OR, which is faster.)
**
** One condition is MR_lld_start_block calls starting with a call to a
** predicate whose entry label matches MR_lld_start_name. Another is
@@ -144,7 +144,8 @@
** MR_watch_csd_addr. The third is calls whose sequence number is in a range
** specified by MR_lld_print_more_min_max, which should point to a string
** containing a comma-separated list of integer intervals (the last interval
-** may be open ended).
+** may be open ended). The fourth is calls between debugger commands that
+** enable and disable low level messages.
**
** MR_lld_start_until and MR_lld_csd_until give the end call numbers of the
** blocks printed for the first two conditions. MR_lld_print_{min,max} give the
@@ -266,6 +267,14 @@
void (*MR_address_of_write_out_proc_statics)(FILE *fp);
#endif
+MR_TypeCtorInfo MR_type_ctor_info_for_univ;
+MR_TypeInfo MR_type_info_for_type_info;
+MR_TypeInfo MR_type_info_for_list_of_univ;
+MR_TypeInfo MR_type_info_for_list_of_int;
+MR_TypeInfo MR_type_info_for_list_of_char;
+MR_TypeInfo MR_type_info_for_list_of_string;
+MR_TypeInfo MR_type_info_for_list_of_type_info;
+
int (*MR_address_of_do_load_aditi_rl_code)(void);
char *(*MR_address_of_trace_getline)(const char *, FILE *, FILE *);
@@ -541,6 +550,11 @@
MR_bool GC_quiet = MR_TRUE;
#endif
+ #ifdef MR_HIGHTAGS
+ /* MR_HIGHTAGS disguises pointers and hides them from gc */
+ #error "MR_HIGHTAGS is incompatible with MR_CONSERVATIVE_GC"
+ #endif
+
void
MR_init_conservative_GC(void)
{
@@ -582,12 +596,26 @@
*/
GC_is_visible(&MR_runqueue_head);
- /* The following code is necessary to tell the conservative */
- /* garbage collector that we are using tagged pointers */
+ /*
+ ** The following code is necessary to tell the conservative
+ ** garbage collector that we are using tagged pointers.
+ **
+ ** With MR_RECORD_TERM_SIZES, we not only add tags in the bottom
+ ** MR_LOW_TAG_BITS bits of the word, we add the tag to a pointer
+ ** not just to the first MR_Word in the block, but also to a pointer
+ ** to the second MR_Word.
+ */
{
int i;
+ int limit;
+
+ limit = (1 << MR_LOW_TAG_BITS);
+
+ #ifdef MR_RECORD_TERM_SIZES
+ limit += sizeof(MR_Word);
+ #endif
- for (i = 1; i < (1 << MR_TAGBITS); i++) {
+ for (i = 1; i < limit; i++) {
GC_REGISTER_DISPLACEMENT(i);
}
}
Index: runtime/mercury_wrapper.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_wrapper.h,v
retrieving revision 1.57
diff -u -b -r1.57 mercury_wrapper.h
--- runtime/mercury_wrapper.h 18 Mar 2003 16:38:14 -0000 1.57
+++ runtime/mercury_wrapper.h 9 Apr 2003 02:57:11 -0000
@@ -93,6 +93,14 @@
extern void (*MR_address_of_write_out_proc_statics)(FILE *fp);
#endif
+extern MR_TypeCtorInfo MR_type_ctor_info_for_univ;
+extern MR_TypeInfo MR_type_info_for_type_info;
+extern MR_TypeInfo MR_type_info_for_list_of_univ;
+extern MR_TypeInfo MR_type_info_for_list_of_int;
+extern MR_TypeInfo MR_type_info_for_list_of_char;
+extern MR_TypeInfo MR_type_info_for_list_of_string;
+extern MR_TypeInfo MR_type_info_for_list_of_type_info;
+
#ifdef MR_CONSERVATIVE_GC
extern void (*MR_address_of_init_gc)(void);
#endif
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 samples/muz
cvs diff: Diffing samples/rot13
cvs diff: Diffing samples/solutions
cvs diff: Diffing samples/tests
cvs diff: Diffing samples/tests/c_interface
cvs diff: Diffing samples/tests/c_interface/c_calls_mercury
cvs diff: Diffing samples/tests/c_interface/cplusplus_calls_mercury
cvs diff: Diffing samples/tests/c_interface/mercury_calls_c
cvs diff: Diffing samples/tests/c_interface/mercury_calls_cplusplus
cvs diff: Diffing samples/tests/c_interface/mercury_calls_fortran
cvs diff: Diffing samples/tests/c_interface/simpler_c_calls_mercury
cvs diff: Diffing samples/tests/c_interface/simpler_cplusplus_calls_mercury
cvs diff: Diffing samples/tests/diff
cvs diff: Diffing samples/tests/muz
cvs diff: Diffing samples/tests/rot13
cvs diff: Diffing samples/tests/solutions
cvs diff: Diffing samples/tests/toplevel
cvs diff: Diffing scripts
Index: scripts/c2init.in
===================================================================
RCS file: /home/mercury1/repository/mercury/scripts/c2init.in,v
retrieving revision 1.39
diff -u -b -r1.39 c2init.in
--- scripts/c2init.in 13 Apr 2003 05:48:35 -0000 1.39
+++ scripts/c2init.in 16 Apr 2003 08:49:40 -0000
@@ -23,7 +23,8 @@
FULLARCH=@FULLARCH@
DEFAULT_GRADE=${MERCURY_DEFAULT_GRADE=@DEFAULT_GRADE@}
-# include the file `parse_ml_options.sh-subr'
+# include the file `parse_ml_options.sh-subr', which in turn includes
+# the sh-subr files dealing with grades
@PARSE_ML_OPTIONS@
# include the file `canonical_grade.sh-subr'
Index: scripts/canonical_grade.sh-subr
===================================================================
RCS file: /home/mercury1/repository/mercury/scripts/canonical_grade.sh-subr,v
retrieving revision 1.7
diff -u -b -r1.7 canonical_grade.sh-subr
--- scripts/canonical_grade.sh-subr 23 Dec 2002 11:21:56 -0000 1.7
+++ scripts/canonical_grade.sh-subr 27 Mar 2003 11:36:52 -0000
@@ -1,5 +1,5 @@
#---------------------------------------------------------------------------#
-# Copyright (C) 2000-2002 The University of Melbourne.
+# Copyright (C) 2000-2003 The University of Melbourne.
# This file may only be copied under the terms of the GNU General
# Public License - see the file COPYING in the Mercury distribution.
#---------------------------------------------------------------------------#
@@ -133,7 +133,18 @@
false,true,false) GRADE="$GRADE.trace" ;;
true,false,false) GRADE="$GRADE.strce" ;;
false,false,false) ;;
- *) echo "$progname: error: invalid combination of debugging options." 1>&2
+ *) progname=`basename $0`
+ echo "$progname: error: invalid combination of debugging options." 1>&2
+ exit 1
+ ;;
+esac
+
+case $record_term_sizes_as_words,$record_term_sizes_as_cells in
+ true,false) GRADE="$GRADE.tsw" ;;
+ false,true) GRADE="$GRADE.tsc" ;;
+ false,false) ;;
+ *) progname=`basename $0`
+ echo "$progname: error: invalid combination of term size profiling options." 1>&2
exit 1
;;
esac
Index: scripts/init_grade_options.sh-subr
===================================================================
RCS file: /home/mercury1/repository/mercury/scripts/init_grade_options.sh-subr,v
retrieving revision 1.20
diff -u -b -r1.20 init_grade_options.sh-subr
--- scripts/init_grade_options.sh-subr 1 Sep 2002 06:05:19 -0000 1.20
+++ scripts/init_grade_options.sh-subr 25 Mar 2003 02:32:28 -0000
@@ -36,6 +36,8 @@
--profile-time
--profile-memory
--profile-deep
+ --record-term-sizes-as-words
+ --record-term-sizes-as-cells
--use-trail
--reserve-tag
--use-minimal-model
@@ -64,6 +66,8 @@
profile_calls=false
profile_memory=false
profile_deep=false
+record_term_sizes_as_words=false
+record_term_sizes_as_cells=false
use_trail=false
reserve_tag=false
use_minimal_model=false
Index: scripts/mgnuc.in
===================================================================
RCS file: /home/mercury1/repository/mercury/scripts/mgnuc.in,v
retrieving revision 1.98
diff -u -b -r1.98 mgnuc.in
--- scripts/mgnuc.in 14 Apr 2003 06:50:13 -0000 1.98
+++ scripts/mgnuc.in 16 Apr 2003 08:49:40 -0000
@@ -368,6 +368,15 @@
false) PROF_DEEP_OPTS="" ;;
esac
+case $record_term_sizes_as_words,$record_term_sizes_as_cells in
+ true,true) progname=`basename $0`
+ echo "$progname: we can't record both cell and word sizes"
+ exit 1 ;;
+ true,false) RECORD_TERM_SIZE_OPTS="-DMR_RECORD_TERM_SIZES" ;;
+ false,true) RECORD_TERM_SIZE_OPTS="-DMR_RECORD_TERM_SIZES -DMR_RECORD_TERM_SIZES_AS_CELLS" ;;
+ false,false) RECORD_TERM_SIZE_OPTS="" ;;
+esac
+
case $use_trail in
true) TRAIL_OPTS="-DMR_USE_TRAIL" ;;
false) TRAIL_OPTS="" ;;
@@ -411,8 +420,9 @@
;;
*) case "$GCC_OPTS" in
*USE_GCC*)
- echo "$0: For compilers other than GNU C, the only" 1>&2
- echo "$0: base grade allowed is \`none'" 1>&2
+ progname=`basename $0`
+ echo "$progname: For compilers other than GNU C, the only" 1>&2
+ echo "$progname: base grade allowed is \`none'" 1>&2
;;
esac
;;
@@ -562,6 +572,7 @@
$LLDEBUG_OPTS $C_DEBUG_OPTS \
$PROF_TIME_OPTS $PROF_CALLS_OPTS $PROF_MEMORY_OPTS \
$PROF_DEEP_OPTS $INLINE_ALLOC_OPTS $TRAIL_OPTS \
+ $RECORD_TERM_SIZE_OPTS \
$RESERVE_TAG_OPTS $MINIMAL_MODEL_OPTS \
$SPLIT_OPTS $THREAD_OPTS $PICREG_OPTS $ARCH_OPTS $ARG_OPTS"
Index: scripts/parse_grade_options.sh-subr
===================================================================
RCS file: /home/mercury1/repository/mercury/scripts/parse_grade_options.sh-subr,v
retrieving revision 1.25
diff -u -b -r1.25 parse_grade_options.sh-subr
--- scripts/parse_grade_options.sh-subr 1 Sep 2002 06:05:20 -0000 1.25
+++ scripts/parse_grade_options.sh-subr 27 Mar 2003 11:37:26 -0000
@@ -126,6 +126,15 @@
--no-profile-deep)
profile_deep=false ;;
+ --record-term-sizes-as-words)
+ record_term_sizes_as_words=true ;;
+ --no-record-term-sizes-as-words)
+ record_term_sizes_as_words=false ;;
+ --record-term-sizes-as-cells)
+ record_term_sizes_as_cells=true ;;
+ --no-record-term-sizes-as-cells)
+ record_term_sizes_as_cells=false ;;
+
--use-trail)
use_trail=true ;;
--no-use-trail)
@@ -192,6 +201,8 @@
profile_calls=false
profile_memory=false
profile_deep=false
+ record_term_sizes_as_words=false
+ record_term_sizes_as_cells=false
use_trail=false
reserve_tag=false
use_minimal_model=false
@@ -370,6 +381,16 @@
profile_calls=false
profile_memory=false
profile_deep=true
+ ;;
+
+ tsw)
+ record_term_sizes_as_words=true
+ record_term_sizes_as_cells=false
+ ;;
+
+ tsc)
+ record_term_sizes_as_words=false
+ record_term_sizes_as_cells=true
;;
tr)
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.96
diff -u -b -r1.96 Mmakefile
--- tests/debugger/Mmakefile 17 Apr 2003 09:57:28 -0000 1.96
+++ tests/debugger/Mmakefile 22 May 2003 03:19:37 -0000
@@ -101,6 +101,12 @@
ifneq "$(findstring mm,$(GRADE))" ""
SENSITIVE_PROGS :=
endif
+ifneq "$(findstring tsw,$(GRADE))" ""
+ SENSITIVE_PROGS :=
+endif
+ifneq "$(findstring tsc,$(GRADE))" ""
+ SENSITIVE_PROGS :=
+endif
# The no_inline_builtins test only works if the library is
# built with execution tracing enabled. Adding a `.exp2' file
Index: tests/debugger/completion.exp
===================================================================
RCS file: /home/mercury1/repository/tests/debugger/completion.exp,v
retrieving revision 1.12
diff -u -b -r1.12 completion.exp
--- tests/debugger/completion.exp 18 Mar 2003 16:38:31 -0000 1.12
+++ tests/debugger/completion.exp 22 May 2003 09:26:17 -0000
@@ -15,13 +15,13 @@
clear_histogram flag print subgoal
consumer forward print_optionals table
context g printlevel table_io
-continue gen_stack proc_body unalias
-current goto proc_stats unhide_events
-cut_stack h procedures up
-d help query v
-dd histogram_all quit vars
-dd_dd histogram_exp r view
-delete ignore register
+continue gen_stack proc_body term_size
+current goto proc_stats unalias
+cut_stack h procedures unhide_events
+d help query up
+dd histogram_all quit v
+dd_dd histogram_exp r vars
+delete ignore register view
disable io_query retry
document label_stats return
h help histogram_all histogram_exp
cvs diff: Diffing tests/debugger/declarative
cvs diff: Diffing tests/dppd
cvs diff: Diffing tests/general
cvs diff: Diffing tests/general/accumulator
cvs diff: Diffing tests/general/string_format
cvs diff: Diffing tests/general/structure_reuse
cvs diff: Diffing tests/grade_subdirs
cvs diff: Diffing tests/hard_coded
cvs diff: Diffing tests/hard_coded/exceptions
cvs diff: Diffing tests/hard_coded/purity
cvs diff: Diffing tests/hard_coded/sub-modules
cvs diff: Diffing tests/hard_coded/typeclasses
cvs diff: Diffing tests/invalid
cvs diff: Diffing tests/invalid/purity
cvs diff: Diffing tests/misc_tests
cvs diff: Diffing tests/mmc_make
cvs diff: Diffing tests/mmc_make/lib
cvs diff: Diffing tests/recompilation
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.c
===================================================================
RCS file: /home/mercury1/repository/mercury/trace/mercury_trace.c,v
retrieving revision 1.61
diff -u -b -r1.61 mercury_trace.c
--- trace/mercury_trace.c 2 May 2003 21:44:17 -0000 1.61
+++ trace/mercury_trace.c 3 May 2003 07:50:12 -0000
@@ -61,6 +61,7 @@
0, /* stop event */
MR_PRINT_LEVEL_SOME,
MR_FALSE, /* not strict */
+ MR_FALSE, /* don't check integrity */
MR_TRUE, /* must check */
NULL /* pointer to filter/4 for collect queries */
};
@@ -177,18 +178,11 @@
#ifdef MR_USE_EXTERNAL_DEBUGGER
MR_Event_Info event_info;
MR_Word *saved_regs = event_info.MR_saved_regs;
- int max_r_num;
const char *path;
MR_bool stop_collecting = MR_FALSE;
int lineno = 0;
- max_r_num = layout->MR_sll_entry->MR_sle_max_r_num;
- if (max_r_num + MR_NUM_SPECIAL_REG > MR_MAX_SPECIAL_REG_MR) {
- event_info.MR_max_mr_num = max_r_num + MR_NUM_SPECIAL_REG;
- } else {
- event_info.MR_max_mr_num = MR_MAX_SPECIAL_REG_MR;
- }
-
+ MR_compute_max_mr_num(event_info.MR_max_mr_num, layout);
port = (MR_Trace_Port) layout->MR_sll_port;
path = MR_label_goal_path(layout);
MR_copy_regs_to_saved_regs(event_info.MR_max_mr_num, saved_regs);
@@ -318,16 +312,26 @@
/*
** The value of MR_trace_ctrl.MR_trace_must_check was
** precomputed when the command was set up; it was set to
- ** MR_TRUE iff either MR_trace_ctrl.MR_trace_strict is
- ** MR_FALSE (allowing us to stop at breakpoints whose action
- ** is MR_SPY_STOP) or MR_trace_ctrl.MR_trace_print_level is
- ** something other than MR_PRINT_LEVEL_NONE (allowing us to
- ** print at least some events). The precomputation avoids
- ** several jumps in the very frequent case that
- ** MR_trace_must_check is false.
+ ** MR_TRUE iff any one of the following conditions is true:
+ **
+ ** - MR_trace_ctrl.MR_trace_strict is MR_FALSE (allowing us to stop
+ ** at breakpoints whose action is MR_SPY_STOP);
+ ** - MR_trace_ctrl.MR_trace_print_level is something other than
+ ** MR_PRINT_LEVEL_NONE (allowing us to print at least some events);
+ ** - MR_trace_ctrl.MR_trace_check_vars_integrity is MR_TRUE, requiring
+ ** us to check the integrity of all the live variables (which at the
+ ** moment means that they can have their sizes computed without
+ ** internal errors).
+ **
+ ** The precomputation avoids several jumps in the very frequent case
+ ** that MR_trace_must_check is false.
*/
port = (MR_Trace_Port) layout->MR_sll_port;
+ if (MR_trace_ctrl.MR_trace_check_integrity) {
+ MR_trace_check_integrity(layout, port);
+ }
+
match = MR_event_matches_spy_point(layout, port, &action);
if (! match) {
if (MR_trace_ctrl.MR_trace_print_level == MR_PRINT_LEVEL_ALL) {
@@ -421,7 +425,6 @@
MR_Code *jumpaddr;
MR_Event_Info event_info;
MR_Word *saved_regs = event_info.MR_saved_regs;
- int max_r_num;
event_info.MR_event_number = MR_trace_event_number;
event_info.MR_call_seqno = seqno;
@@ -430,13 +433,7 @@
event_info.MR_event_sll = layout;
event_info.MR_event_path = MR_label_goal_path(layout);
- max_r_num = layout->MR_sll_entry->MR_sle_max_r_num;
- if (max_r_num + MR_NUM_SPECIAL_REG > MR_MAX_SPECIAL_REG_MR) {
- event_info.MR_max_mr_num = max_r_num + MR_NUM_SPECIAL_REG;
- } else {
- event_info.MR_max_mr_num = MR_MAX_SPECIAL_REG_MR;
- }
-
+ MR_compute_max_mr_num(event_info.MR_max_mr_num, layout);
/* This also saves the regs in MR_fake_regs. */
MR_copy_regs_to_saved_regs(event_info.MR_max_mr_num, saved_regs);
Index: trace/mercury_trace.h
===================================================================
RCS file: /home/mercury1/repository/mercury/trace/mercury_trace.h,v
retrieving revision 1.27
diff -u -b -r1.27 mercury_trace.h
--- trace/mercury_trace.h 6 Nov 2002 02:02:37 -0000 1.27
+++ trace/mercury_trace.h 13 Apr 2003 09:21:52 -0000
@@ -226,17 +226,19 @@
MR_Unsigned MR_trace_stop_event;
MR_Trace_Print_Level MR_trace_print_level;
MR_bool MR_trace_strict;
+ MR_bool MR_trace_check_integrity;
/*
** The next field is an optimization;
** it must be set to !MR_trace_strict ||
** MR_trace_print_level != MR_PRINT_LEVEL_NONE
+ ** || MR_trace_check_integrity
*/
MR_bool MR_trace_must_check;
/*
- ** The MR_filter_ptr field points to the filter/4
- ** procedure during a collect request
+ ** The MR_filter_ptr field points to the
+ ** filter/4 procedure during a collect request
*/
MR_FilterFuncPtr MR_filter_ptr;
} MR_Trace_Cmd_Info;
Index: trace/mercury_trace_browse.c
===================================================================
RCS file: /home/mercury1/repository/mercury/trace/mercury_trace_browse.c,v
retrieving revision 1.27
diff -u -b -r1.27 mercury_trace_browse.c
--- trace/mercury_trace_browse.c 15 Nov 2002 04:50:47 -0000 1.27
+++ trace/mercury_trace_browse.c 3 Apr 2003 14:18:04 -0000
@@ -315,7 +315,8 @@
{
MR_ConstString options_on_heap;
MR_Word imports_list;
- MercuryFile mdb_in, mdb_out;
+ MercuryFile mdb_in;
+ MercuryFile mdb_out;
int i;
MR_c_file_to_mercury_file(MR_mdb_in, &mdb_in);
@@ -330,8 +331,8 @@
for (i = num_imports; i > 0; i--) {
MR_ConstString this_import;
MR_make_aligned_string(this_import, imports[i - 1]);
- imports_list = MR_list_cons((MR_Word) this_import,
- imports_list);
+ imports_list = MR_string_list_cons(
+ (MR_Word) this_import, imports_list);
}
);
Index: trace/mercury_trace_external.c
===================================================================
RCS file: /home/mercury1/repository/mercury/trace/mercury_trace_external.c,v
retrieving revision 1.69
diff -u -b -r1.69 mercury_trace_external.c
--- trace/mercury_trace_external.c 16 Apr 2003 12:38:10 -0000 1.69
+++ trace/mercury_trace_external.c 22 May 2003 04:02:29 -0000
@@ -51,7 +51,6 @@
#include <dlfcn.h>
#endif
-
/*
** This type must match the definition of classify_request in
** browser/debugger_interface.m.
@@ -841,6 +840,8 @@
cmd->MR_trace_must_check =
MR_FALSE;
cmd->MR_trace_strict = MR_TRUE;
+ cmd->MR_trace_check_integrity =
+ MR_FALSE;
cmd->MR_trace_print_level =
MR_PRINT_LEVEL_NONE;
goto done;
@@ -896,7 +897,8 @@
** changed the command strictness or print-level
*/
cmd->MR_trace_must_check = (! cmd->MR_trace_strict) ||
- (cmd->MR_trace_print_level != MR_PRINT_LEVEL_NONE);
+ (cmd->MR_trace_print_level != MR_PRINT_LEVEL_NONE)
+ || cmd->MR_trace_check_integrity;
/*
** Restore the event numbers, in case the Mercury
@@ -1129,7 +1131,7 @@
);
MR_TRACE_USE_HP(
- var_list = MR_list_cons(univ, var_list);
+ var_list = MR_univ_list_cons(univ, var_list);
);
}
@@ -1167,7 +1169,7 @@
}
MR_TRACE_USE_HP(
- var_names_list = MR_list_cons((MR_Word) name,
+ var_names_list = MR_string_list_cons((MR_Word) name,
var_names_list);
);
}
@@ -1209,8 +1211,8 @@
type_info_string = ML_type_name((MR_Word) type_info);
);
MR_TRACE_USE_HP(
- type_list = MR_list_cons((MR_Word) type_info_string,
- type_list);
+ type_list = MR_string_list_cons(
+ (MR_Word) type_info_string, type_list);
);
}
@@ -1467,16 +1469,15 @@
{
const char *problem;
- problem = MR_trace_browse_one(NULL, var_spec, MR_trace_browse_external,
- MR_BROWSE_CALLER_BROWSE, MR_BROWSE_DEFAULT_FORMAT,
- MR_TRUE);
+ problem = MR_trace_browse_one(NULL, MR_FALSE, var_spec,
+ MR_trace_browse_external, MR_BROWSE_CALLER_BROWSE,
+ MR_BROWSE_DEFAULT_FORMAT, MR_TRUE);
if (problem != NULL) {
MR_send_message_to_socket_format("error(\"%s\").\n", problem);
}
}
-
/*
** This function calls the collect filtering predicate defined by the user
** and dynamically link with the execution.
@@ -1539,7 +1540,6 @@
int lineno = 0;
MR_Word *base_sp, *base_curfr;
-
if MR_port_is_interface(port)
/*
** At external events, we want the line number
Index: trace/mercury_trace_help.c
===================================================================
RCS file: /home/mercury1/repository/mercury/trace/mercury_trace_help.c,v
retrieving revision 1.19
diff -u -b -r1.19 mercury_trace_help.c
--- trace/mercury_trace_help.c 5 Aug 2002 21:46:19 -0000 1.19
+++ trace/mercury_trace_help.c 3 Apr 2003 14:16:20 -0000
@@ -81,7 +81,7 @@
MR_TRACE_USE_HP(
MR_make_aligned_string_copy(category_on_heap, category);
path = MR_list_empty();
- path = MR_list_cons((MR_Word) category_on_heap, path);
+ path = MR_string_list_cons((MR_Word) category_on_heap, path);
);
return MR_trace_help_add_node(path, item, slot, text);
@@ -164,8 +164,8 @@
MR_make_aligned_string_copy(category_on_heap, category);
MR_make_aligned_string_copy(item_on_heap, item);
path = MR_list_empty();
- path = MR_list_cons((MR_Word) item_on_heap, path);
- path = MR_list_cons((MR_Word) category_on_heap, path);
+ path = MR_string_list_cons((MR_Word) item_on_heap, path);
+ path = MR_string_list_cons((MR_Word) category_on_heap, path);
);
MR_c_file_to_mercury_file(MR_mdb_out, &mdb_out);
Index: trace/mercury_trace_internal.c
===================================================================
RCS file: /home/mercury1/repository/mercury/trace/mercury_trace_internal.c,v
retrieving revision 1.156
diff -u -b -r1.156 mercury_trace_internal.c
--- trace/mercury_trace_internal.c 16 Apr 2003 12:38:10 -0000 1.156
+++ trace/mercury_trace_internal.c 22 May 2003 03:45:38 -0000
@@ -440,6 +440,7 @@
static MR_TraceCmdFunc MR_trace_cmd_histogram_all;
static MR_TraceCmdFunc MR_trace_cmd_histogram_exp;
static MR_TraceCmdFunc MR_trace_cmd_clear_histogram;
+static MR_TraceCmdFunc MR_trace_cmd_term_size;
static MR_TraceCmdFunc MR_trace_cmd_flag;
static MR_TraceCmdFunc MR_trace_cmd_subgoal;
static MR_TraceCmdFunc MR_trace_cmd_consumer;
@@ -478,7 +479,7 @@
static void MR_trace_cmd_nondet_stack_2(MR_Event_Info *event_info,
int limit, MR_bool detailed);
-static MR_bool MR_trace_options_strict_print(MR_Trace_Cmd_Info *cmd,
+static MR_bool MR_trace_options_movement_cmd(MR_Trace_Cmd_Info *cmd,
char ***words, int *word_count,
const char *cat, const char *item);
static MR_bool MR_trace_options_retry(MR_Retry_Across_Io *across_io,
@@ -678,7 +679,8 @@
} while (res == KEEP_INTERACTING);
cmd->MR_trace_must_check = (! cmd->MR_trace_strict) ||
- (cmd->MR_trace_print_level != MR_PRINT_LEVEL_NONE);
+ (cmd->MR_trace_print_level != MR_PRINT_LEVEL_NONE)
+ || cmd->MR_trace_check_integrity;
MR_trace_call_seqno = event_details.MR_call_seqno;
MR_trace_call_depth = event_details.MR_call_depth;
@@ -1323,7 +1325,8 @@
cmd->MR_trace_strict = MR_FALSE;
cmd->MR_trace_print_level = MR_default_print_level;
- if (! MR_trace_options_strict_print(cmd, &words, &word_count,
+ cmd->MR_trace_check_integrity = MR_FALSE;
+ if (! MR_trace_options_movement_cmd(cmd, &words, &word_count,
"forward", "step"))
{
; /* the usage message has already been printed */
@@ -1353,7 +1356,8 @@
cmd->MR_trace_strict = MR_TRUE;
cmd->MR_trace_print_level = MR_default_print_level;
- if (! MR_trace_options_strict_print(cmd, &words, &word_count,
+ cmd->MR_trace_check_integrity = MR_FALSE;
+ if (! MR_trace_options_movement_cmd(cmd, &words, &word_count,
"forward", "goto"))
{
; /* the usage message has already been printed */
@@ -1387,7 +1391,8 @@
cmd->MR_trace_strict = MR_TRUE;
cmd->MR_trace_print_level = MR_default_print_level;
- if (! MR_trace_options_strict_print(cmd, &words, &word_count,
+ cmd->MR_trace_check_integrity = MR_FALSE;
+ if (! MR_trace_options_movement_cmd(cmd, &words, &word_count,
"forward", "next"))
{
; /* the usage message has already been printed */
@@ -1426,7 +1431,8 @@
cmd->MR_trace_strict = MR_TRUE;
cmd->MR_trace_print_level = MR_default_print_level;
- if (! MR_trace_options_strict_print(cmd, &words, &word_count,
+ cmd->MR_trace_check_integrity = MR_FALSE;
+ if (! MR_trace_options_movement_cmd(cmd, &words, &word_count,
"forward", "finish"))
{
; /* the usage message has already been printed */
@@ -1467,7 +1473,8 @@
cmd->MR_trace_strict = MR_TRUE;
cmd->MR_trace_print_level = MR_default_print_level;
- if (! MR_trace_options_strict_print(cmd, &words, &word_count,
+ cmd->MR_trace_check_integrity = MR_FALSE;
+ if (! MR_trace_options_movement_cmd(cmd, &words, &word_count,
"forward", "fail"))
{
; /* the usage message has already been printed */
@@ -1518,7 +1525,8 @@
{
cmd->MR_trace_strict = MR_TRUE;
cmd->MR_trace_print_level = MR_default_print_level;
- if (! MR_trace_options_strict_print(cmd, &words, &word_count,
+ cmd->MR_trace_check_integrity = MR_FALSE;
+ if (! MR_trace_options_movement_cmd(cmd, &words, &word_count,
"forward", "exception"))
{
; /* the usage message has already been printed */
@@ -1543,7 +1551,8 @@
{
cmd->MR_trace_strict = MR_TRUE;
cmd->MR_trace_print_level = MR_default_print_level;
- if (! MR_trace_options_strict_print(cmd, &words, &word_count,
+ cmd->MR_trace_check_integrity = MR_FALSE;
+ if (! MR_trace_options_movement_cmd(cmd, &words, &word_count,
"forward", "return"))
{
; /* the usage message has already been printed */
@@ -1568,7 +1577,8 @@
{
cmd->MR_trace_strict = MR_TRUE;
cmd->MR_trace_print_level = MR_default_print_level;
- if (! MR_trace_options_strict_print(cmd, &words, &word_count,
+ cmd->MR_trace_check_integrity = MR_FALSE;
+ if (! MR_trace_options_movement_cmd(cmd, &words, &word_count,
"forward", "forward"))
{
; /* the usage message has already been printed */
@@ -1599,7 +1609,8 @@
cmd->MR_trace_strict = MR_TRUE;
cmd->MR_trace_print_level = MR_default_print_level;
- if (! MR_trace_options_strict_print(cmd, &words, &word_count,
+ cmd->MR_trace_check_integrity = MR_FALSE;
+ if (! MR_trace_options_movement_cmd(cmd, &words, &word_count,
"forward", "mindepth"))
{
; /* the usage message has already been printed */
@@ -1625,7 +1636,8 @@
cmd->MR_trace_strict = MR_TRUE;
cmd->MR_trace_print_level = MR_default_print_level;
- if (! MR_trace_options_strict_print(cmd, &words, &word_count,
+ cmd->MR_trace_check_integrity = MR_FALSE;
+ if (! MR_trace_options_movement_cmd(cmd, &words, &word_count,
"forward", "maxdepth"))
{
; /* the usage message has already been printed */
@@ -1649,14 +1661,14 @@
{
cmd->MR_trace_strict = MR_FALSE;
cmd->MR_trace_print_level = (MR_Trace_Cmd_Type) -1;
- if (! MR_trace_options_strict_print(cmd, &words, &word_count,
+ cmd->MR_trace_check_integrity = MR_FALSE;
+ if (! MR_trace_options_movement_cmd(cmd, &words, &word_count,
"forward", "continue"))
{
; /* the usage message has already been printed */
} else if (word_count == 1) {
cmd->MR_trace_cmd = MR_CMD_TO_END;
- if (cmd->MR_trace_print_level ==
- (MR_Trace_Cmd_Type) -1) {
+ if (cmd->MR_trace_print_level == (MR_Trace_Cmd_Type) -1) {
/*
** The user did not specify the print level;
** select the intelligent default.
@@ -1901,7 +1913,7 @@
MR_BROWSE_CALLER_PRINT, format);
} else {
problem = MR_trace_parse_browse_one(MR_mdb_out,
- words[1], MR_trace_browse_internal,
+ MR_TRUE, words[1], MR_trace_browse_internal,
MR_BROWSE_CALLER_PRINT, format,
MR_FALSE);
}
@@ -1965,8 +1977,8 @@
MR_trace_browse_internal,
MR_BROWSE_CALLER_BROWSE, format);
} else {
- problem = MR_trace_parse_browse_one(NULL,
- words[1], MR_trace_browse_internal,
+ problem = MR_trace_parse_browse_one(MR_mdb_out,
+ MR_FALSE, words[1], MR_trace_browse_internal,
MR_BROWSE_CALLER_BROWSE, format,
MR_TRUE);
}
@@ -2072,18 +2084,16 @@
MR_Word pretty_format;
if (! MR_trace_options_param_set(&print_set, &browse_set,
- &print_all_set, &flat_format,
- &raw_pretty_format, &verbose_format,
- &pretty_format, &words, &word_count, "browsing",
- "set"))
+ &print_all_set, &flat_format, &raw_pretty_format,
+ &verbose_format, &pretty_format, &words, &word_count,
+ "browsing", "set"))
{
; /* the usage message has already been printed */
}
else if (word_count != 3 ||
- ! MR_trace_set_browser_param(print_set,
- browse_set, print_all_set, flat_format,
- raw_pretty_format, verbose_format,
- pretty_format, words[1], words[2]))
+ ! MR_trace_set_browser_param(print_set, browse_set,
+ print_all_set, flat_format, raw_pretty_format,
+ verbose_format, pretty_format, words[1], words[2]))
{
MR_trace_usage("browsing", "set");
}
@@ -2106,10 +2116,9 @@
MR_bool close_window = MR_FALSE;
const char *msg;
- if (! MR_trace_options_view(&window_cmd, &server_cmd,
- &server_name, &timeout, &force, &verbose,
- &split, &close_window, &words, &word_count,
- "browsing", "view"))
+ if (! MR_trace_options_view(&window_cmd, &server_cmd, &server_name,
+ &timeout, &force, &verbose, &split, &close_window,
+ &words, &word_count, "browsing", "view"))
{
; /* the usage message has already been printed */
} else if (word_count != 1) {
@@ -2211,8 +2220,7 @@
layout->MR_sll_entry, layout,
&problem);
MR_maybe_print_spy_point(slot, problem);
- } else if (word_count == 2 && MR_parse_proc_spec(words[1], &spec))
- {
+ } else if (word_count == 2 && MR_parse_proc_spec(words[1], &spec)) {
MR_Matches_Info matches;
int slot;
@@ -2410,6 +2418,7 @@
MR_Code **jumpaddr)
{
int n;
+
if (word_count == 2 && MR_trace_is_natural_number(words[1], &n)) {
if (0 <= n && n < MR_spy_point_next
&& MR_spy_points[n]->spy_exists)
@@ -3170,6 +3179,34 @@
}
static MR_Next
+MR_trace_cmd_term_size(char **words, int word_count, MR_Trace_Cmd_Info *cmd,
+ MR_Event_Info *event_info, MR_Event_Details *event_details,
+ MR_Code **jumpaddr)
+{
+ int n;
+
+ if (word_count == 2) {
+ const char *problem;
+
+ if (MR_streq(words[1], "*")) {
+ problem = MR_trace_print_size_all(MR_mdb_out);
+ } else {
+ problem = MR_trace_print_size_one(MR_mdb_out,
+ words[1]);
+ }
+
+ if (problem != NULL) {
+ fflush(MR_mdb_out);
+ fprintf(MR_mdb_err, "mdb: %s.\n", problem);
+ }
+ } else {
+ MR_trace_usage("developer", "term_size");
+ }
+
+ return KEEP_INTERACTING;
+}
+
+static MR_Next
MR_trace_cmd_flag(char **words, int word_count, MR_Trace_Cmd_Info *cmd,
MR_Event_Info *event_info, MR_Event_Details *event_details,
MR_Code **jumpaddr)
@@ -4841,25 +4878,26 @@
}
}
-static struct MR_option MR_trace_strict_print_opts[] =
+static struct MR_option MR_trace_movement_cmd_opts[] =
{
{ "all", MR_no_argument, NULL, 'a' },
{ "none", MR_no_argument, NULL, 'n' },
{ "some", MR_no_argument, NULL, 's' },
{ "nostrict", MR_no_argument, NULL, 'N' },
{ "strict", MR_no_argument, NULL, 'S' },
+ { "integrity", MR_no_argument, NULL, 'i' },
{ NULL, MR_no_argument, NULL, 0 }
};
static MR_bool
-MR_trace_options_strict_print(MR_Trace_Cmd_Info *cmd,
+MR_trace_options_movement_cmd(MR_Trace_Cmd_Info *cmd,
char ***words, int *word_count, const char *cat, const char *item)
{
int c;
MR_optind = 0;
- while ((c = MR_getopt_long(*word_count, *words, "NSans",
- MR_trace_strict_print_opts, NULL)) != EOF)
+ while ((c = MR_getopt_long(*word_count, *words, "NSains",
+ MR_trace_movement_cmd_opts, NULL)) != EOF)
{
switch (c) {
@@ -4883,6 +4921,10 @@
cmd->MR_trace_print_level = MR_PRINT_LEVEL_SOME;
break;
+ case 'i':
+ cmd->MR_trace_check_integrity = MR_TRUE;
+ break;
+
default:
MR_trace_usage(cat, item);
return MR_FALSE;
@@ -6147,60 +6189,61 @@
}
static const char *const MR_trace_movement_cmd_args[] =
- {"-N", "-S", "-a", "-n", "-s",
- "--none", "--some", "--all", "--strict", "--no-strict", NULL};
+ { "-N", "-S", "-a", "-i", "-n", "-s",
+ "--none", "--some", "--all", "--integrity",
+ "--strict", "--no-strict", NULL };
/*
** "retry --assume-all-io-is-tabled" is deliberately not documented as
** it is for developers only.
*/
static const char *const MR_trace_retry_cmd_args[] =
- {"--force", "--interactive", "--only-if-safe", NULL};
+ { "--force", "--interactive", "--only-if-safe", NULL };
static const char *const MR_trace_print_cmd_args[] =
- {"-f", "-p", "-v", "--flat", "--pretty", "--verbose",
- "exception", "goal", "*", NULL};
+ { "-f", "-p", "-v", "--flat", "--pretty", "--verbose",
+ "exception", "goal", "*", NULL };
- /*
- ** It's better to have a single completion where possible,
- ** so don't include `-d' here.
- */
+/*
+** It's better to have a single completion where possible,
+** so don't include `-d' here.
+*/
static const char *const MR_trace_stack_cmd_args[] =
- {"--detailed", NULL};
+ { "--detailed", NULL };
static const char *const MR_trace_set_cmd_args[] =
- {"-A", "-B", "-P", "-f", "-p", "-v",
+ { "-A", "-B", "-P", "-f", "-p", "-v",
"--print-all", "--print", "--browse",
"--flat", "--pretty", "--verbose",
"format", "depth", "size", "width", "lines",
- "flat", "pretty", "verbose", NULL};
+ "flat", "pretty", "verbose", NULL };
static const char *const MR_trace_view_cmd_args[] =
- {"-c", "-f", "-n", "-s", "-t", "-v", "-w", "-2",
+ { "-c", "-f", "-n", "-s", "-t", "-v", "-w", "-2",
"--close", "--verbose", "--force", "--split-screen",
"--window-command", "--server-command", "--server-name",
- "--timeout", NULL};
+ "--timeout", NULL };
static const char *const MR_trace_break_cmd_args[] =
- {"-A", "-E", "-I", "-O", "-P", "-S", "-a", "-e", "-i",
+ { "-A", "-E", "-I", "-O", "-P", "-S", "-a", "-e", "-i",
"--all", "--entry", "--ignore-entry", "--ignore-interface",
"--interface", "--print", "--select-all", "--select-one",
- "--stop", "here", "info", NULL};
+ "--stop", "here", "info", NULL };
static const char *const MR_trace_ignore_cmd_args[] =
- {"-E", "-I", "--ignore-entry", "--ignore-interface", NULL};
+ { "-E", "-I", "--ignore-entry", "--ignore-interface", NULL };
static const char *const MR_trace_printlevel_cmd_args[] =
- {"none", "some", "all", NULL};
+ { "none", "some", "all", NULL };
static const char *const MR_trace_on_off_args[] =
- {"on", "off", NULL};
+ { "on", "off", NULL };
static const char *const MR_trace_context_cmd_args[] =
- {"none", "before", "after", "prevline", "nextline", NULL};
+ { "none", "before", "after", "prevline", "nextline", NULL };
static const char *const MR_trace_scope_cmd_args[] =
- {"all", "interface", "entry", NULL};
+ { "all", "interface", "entry", NULL };
/*
** "table_io allow" is deliberately not documented as it is developer only
@@ -6208,17 +6251,17 @@
** effort to encourage consistent use of start/stop.
*/
static const char *const MR_trace_table_io_cmd_args[] =
- {"stats", "start", "stop", NULL};
+ { "stats", "start", "stop", NULL };
- /*
- ** It's better to have a single completion where possible,
- ** so don't include `-i' here.
- */
+/*
+** It's better to have a single completion where possible,
+** so don't include `-i' here.
+*/
static const char *const MR_trace_source_cmd_args[] =
- {"--ignore-errors", NULL};
+ { "--ignore-errors", NULL };
static const char *const MR_trace_quit_cmd_args[] =
- {"-y", NULL};
+ { "-y", NULL };
static const MR_Trace_Command_Info MR_trace_command_infos[] =
{
@@ -6332,9 +6375,9 @@
{ "misc", "save", MR_trace_cmd_save,
NULL, MR_trace_filename_completer },
{ "misc", "dd", MR_trace_cmd_dd,
- NULL, MR_trace_null_completer},
+ NULL, MR_trace_null_completer },
{ "misc", "quit", MR_trace_cmd_quit,
- MR_trace_quit_cmd_args, NULL},
+ MR_trace_quit_cmd_args, NULL },
{ "exp", "histogram_all", MR_trace_cmd_histogram_all,
NULL, MR_trace_filename_completer },
@@ -6343,6 +6386,8 @@
{ "exp", "clear_histogram", MR_trace_cmd_clear_histogram,
NULL, MR_trace_null_completer },
+ { "developer", "term_size", MR_trace_cmd_term_size,
+ NULL, MR_trace_null_completer },
{ "developer", "flag", MR_trace_cmd_flag,
NULL, MR_trace_null_completer },
{ "developer", "subgoal", MR_trace_cmd_subgoal,
@@ -6372,7 +6417,7 @@
{ "developer", "unhide_events", MR_trace_cmd_unhide_events,
MR_trace_on_off_args, MR_trace_null_completer },
{ "developer", "dd_dd", MR_trace_cmd_dd_dd,
- NULL, MR_trace_filename_completer},
+ NULL, MR_trace_filename_completer },
{ "developer", "table", MR_trace_cmd_table,
NULL, MR_trace_null_completer },
Index: trace/mercury_trace_vars.c
===================================================================
RCS file: /home/mercury1/repository/mercury/trace/mercury_trace_vars.c,v
retrieving revision 1.52
diff -u -b -r1.52 mercury_trace_vars.c
--- trace/mercury_trace_vars.c 2 Apr 2003 23:01:45 -0000 1.52
+++ trace/mercury_trace_vars.c 22 May 2003 03:58:37 -0000
@@ -20,6 +20,7 @@
#include "mercury_memory.h"
#include "mercury_layout_util.h"
#include "mercury_deconstruct.h"
+#include "mercury_term_size.h"
#include "mercury_stack_layout.h"
#include "mercury_trace_util.h"
#include "mercury_trace_vars.h"
@@ -119,14 +120,19 @@
MR_bool print_optionals);
static int MR_trace_compare_var_details(const void *arg1,
const void *arg2);
+static int MR_compare_slots_on_headvar_num(const void *p1,
+ const void *p2);
static const char * MR_trace_browse_one_path(FILE *out,
- MR_Var_Spec var_spec, char *path,
- MR_Browser browser, MR_Browse_Caller_Type caller,
- MR_Browse_Format format, MR_bool must_be_unique);
-static char * MR_trace_browse_var(FILE *out, MR_Var_Details *var,
+ MR_bool print_var_name, MR_Var_Spec var_spec,
char *path, MR_Browser browser,
MR_Browse_Caller_Type caller,
+ MR_Browse_Format format, MR_bool must_be_unique);
+static char * MR_trace_browse_var(FILE *out, MR_bool print_var_name,
+ MR_Var_Details *var, char *path,
+ MR_Browser browser, MR_Browse_Caller_Type caller,
MR_Browse_Format format);
+static const char * MR_lookup_var_spec(MR_Var_Spec var_spec,
+ int *var_index_ptr, MR_bool *is_ambiguous_ptr);
static char * MR_trace_var_completer_next(const char *word,
size_t word_len, MR_Completer_Data *data);
static const char * MR_trace_bad_path(const char *path);
@@ -747,6 +753,49 @@
static
MR_static_type_info_arity_0(MR_unbound_typeinfo_struct, &unbound_ctor_name);
+void
+MR_convert_arg_to_var_spec(const char *word_spec, MR_Var_Spec *var_spec)
+{
+ int n;
+
+ if (MR_trace_is_natural_number(word_spec, &n)) {
+ var_spec->MR_var_spec_kind = MR_VAR_SPEC_NUMBER;
+ var_spec->MR_var_spec_number = n;
+ var_spec->MR_var_spec_name = NULL; /* unused */
+ } else {
+ var_spec->MR_var_spec_kind = MR_VAR_SPEC_NAME;
+ var_spec->MR_var_spec_name = word_spec;
+ var_spec->MR_var_spec_number = -1; /* unused */
+ }
+}
+
+static int
+MR_compare_slots_on_headvar_num(const void *p1, const void *p2)
+{
+ MR_Var_Details *vars;
+ int s1;
+ int s2;
+
+ vars = MR_point.MR_point_vars;
+ s1 = * (int *) p1;
+ s2 = * (int *) p2;
+
+ if (! vars[s1].MR_var_is_headvar) {
+ MR_fatal_error("MR_compare_slots_on_headvar_num: s1");
+ }
+ if (! vars[s2].MR_var_is_headvar) {
+ MR_fatal_error("MR_compare_slots_on_headvar_num: s2");
+ }
+
+ if (vars[s1].MR_var_is_headvar < vars[s2].MR_var_is_headvar) {
+ return -1;
+ } else if (vars[s1].MR_var_is_headvar > vars[s2].MR_var_is_headvar) {
+ return 1;
+ } else {
+ return 0;
+ }
+}
+
const char *
MR_trace_browse_one_goal(FILE *out, MR_GoalBrowser browser,
MR_Browse_Caller_Type caller, MR_Browse_Format format)
@@ -755,75 +804,61 @@
MR_ConstString proc_name;
MR_Word is_func;
MR_Word arg_list;
- MR_Word prev;
- MR_Word cur;
MR_Word arg;
MR_TypeInfo arg_list_typeinfo;
MR_Var_Details *vars;
int headvar_num;
int arity;
int slot;
+ int var_count;
+ int next;
+ int i;
+ int *var_slot_array;
MR_bool saved_io_tabling_enabled;
proc_layout = MR_point.MR_point_level_entry;
MR_generate_proc_name_from_layout(proc_layout, &proc_name, &arity,
&is_func);
- MR_TRACE_USE_HP(
-
vars = MR_point.MR_point_vars;
- arg_list = MR_list_empty();
+ var_count = MR_point.MR_point_var_count;
+ var_slot_array = MR_malloc(sizeof(int) * var_count);
+
+ next = 0;
for (slot = MR_point.MR_point_var_count - 1; slot >= 0; slot--) {
headvar_num = vars[slot].MR_var_is_headvar;
if (headvar_num) {
- /*
- ** Insert the slot into the list sorted by argument number.
- */
- prev = MR_list_empty();
- cur = arg_list;
- while (! MR_list_is_empty(cur) &&
- headvar_num > vars[MR_list_head(cur)].MR_var_is_headvar)
- {
- prev = cur;
- cur = MR_list_tail(cur);
- }
- if (MR_list_is_empty(prev)) {
- arg_list = MR_list_cons(slot, cur);
- } else {
- MR_list_tail(prev) = MR_list_cons(slot, cur);
- }
+ var_slot_array[next] = slot;
+ next++;
}
}
+ qsort(var_slot_array, next, sizeof(int), MR_compare_slots_on_headvar_num);
+
+ MR_TRACE_USE_HP(
+
/*
** Replace the slot numbers in the argument list
** with the argument values, adding entries for
** any unbound arguments (they will be printed
** as `_').
*/
- prev = MR_list_empty();
- cur = arg_list;
- for (headvar_num = 1; headvar_num <= arity; headvar_num++) {
- if (!MR_list_is_empty(cur) &&
- vars[MR_list_head(cur)].MR_var_is_headvar == headvar_num)
+ arg_list = MR_list_empty();
+ i = next - 1;
+ for (headvar_num = arity; headvar_num > 0; headvar_num--) {
+ if (i >= 0 && vars[var_slot_array[i]].MR_var_is_headvar
+ == headvar_num)
{
- slot = MR_list_head(cur);
+ slot = var_slot_array[i];
+ i--;
MR_new_univ_on_hp(arg, vars[slot].MR_var_type,
vars[slot].MR_var_value);
- MR_list_head(cur) = arg;
- prev = cur;
- cur = MR_list_tail(cur);
- } else {
- MR_new_univ_on_hp(arg, &MR_unbound_typeinfo_struct,
- MR_UNBOUND);
- if (MR_list_is_empty(prev)) {
- arg_list = MR_list_cons(arg, cur);
- prev = arg_list;
} else {
- MR_list_tail(prev) = MR_list_cons(arg, cur);
- prev = MR_list_tail(prev);
- }
+ MR_new_univ_on_hp(arg,
+ (MR_TypeInfo) &MR_unbound_typeinfo_struct, MR_UNBOUND);
}
+
+ arg_list = MR_univ_list_cons(arg, arg_list);
}
);
@@ -858,8 +893,8 @@
}
const char *
-MR_trace_parse_browse_one(FILE *out, char *word_spec, MR_Browser browser,
- MR_Browse_Caller_Type caller, MR_Browse_Format format,
+MR_trace_parse_browse_one(FILE *out, MR_bool print_var_name, char *word_spec,
+ MR_Browser browser, MR_Browse_Caller_Type caller, MR_Browse_Format format,
MR_bool must_be_unique)
{
MR_Var_Spec var_spec;
@@ -900,76 +935,44 @@
path++;
}
- if (MR_trace_is_natural_number(word_spec, &n)) {
- var_spec.MR_var_spec_kind = MR_VAR_SPEC_NUMBER;
- var_spec.MR_var_spec_number = n;
- var_spec.MR_var_spec_name = NULL; /* unused */
- return MR_trace_browse_one_path(out, var_spec, path,
- browser, caller, format, must_be_unique);
- } else {
- var_spec.MR_var_spec_kind = MR_VAR_SPEC_NAME;
- var_spec.MR_var_spec_name = word_spec;
- var_spec.MR_var_spec_number = -1; /* unused */
- return MR_trace_browse_one_path(out, var_spec, path,
+ MR_convert_arg_to_var_spec(word_spec, &var_spec);
+
+ return MR_trace_browse_one_path(out, print_var_name, var_spec, path,
browser, caller, format, must_be_unique);
- }
}
const char *
-MR_trace_browse_one(FILE *out, MR_Var_Spec var_spec, MR_Browser browser,
- MR_Browse_Caller_Type caller, MR_Browse_Format format,
+MR_trace_browse_one(FILE *out, MR_bool print_var_name, MR_Var_Spec var_spec,
+ MR_Browser browser, MR_Browse_Caller_Type caller, MR_Browse_Format format,
MR_bool must_be_unique)
{
- return MR_trace_browse_one_path(out, var_spec, NULL, browser,
- caller, format, must_be_unique);
+ return MR_trace_browse_one_path(out, print_var_name, var_spec, NULL,
+ browser, caller, format, must_be_unique);
}
static const char *
-MR_trace_browse_one_path(FILE *out, MR_Var_Spec var_spec, char *path,
- MR_Browser browser, MR_Browse_Caller_Type caller,
- MR_Browse_Format format, MR_bool must_be_unique)
+MR_trace_browse_one_path(FILE *out, MR_bool print_var_name,
+ MR_Var_Spec var_spec, char *path, MR_Browser browser,
+ MR_Browse_Caller_Type caller, MR_Browse_Format format,
+ MR_bool must_be_unique)
{
int i;
- MR_bool found;
+ MR_bool is_ambiguous;
const char *problem;
char *bad_path;
- if (MR_point.MR_point_problem != NULL) {
- return MR_point.MR_point_problem;
- }
-
- if (var_spec.MR_var_spec_kind == MR_VAR_SPEC_NUMBER) {
- int varno;
-
- problem = MR_trace_valid_var_number(
- var_spec.MR_var_spec_number);
+ problem = MR_lookup_var_spec(var_spec, &i, &is_ambiguous);
if (problem != NULL) {
return problem;
}
- varno = var_spec.MR_var_spec_number - 1;
- bad_path = MR_trace_browse_var(out,
- &MR_point.MR_point_vars[varno],
- path, browser, caller, format);
+ if (! is_ambiguous) {
+ bad_path = MR_trace_browse_var(out, print_var_name,
+ &MR_point.MR_point_vars[i], path, browser, caller, format);
if (bad_path != NULL) {
return MR_trace_bad_path(bad_path);
}
- } else if (var_spec.MR_var_spec_kind == MR_VAR_SPEC_NAME) {
- found = MR_FALSE;
- for (i = 0; i < MR_point.MR_point_var_count; i++) {
- if (MR_streq(var_spec.MR_var_spec_name,
- MR_point.MR_point_vars[i].MR_var_fullname))
- {
- found = MR_TRUE;
- break;
- }
- }
-
- if (!found) {
- return "there is no such variable";
- }
-
- if (MR_point.MR_point_vars[i].MR_var_is_ambiguous) {
+ } else {
int success_count;
if (must_be_unique) {
@@ -978,8 +981,8 @@
success_count = 0;
do {
- bad_path = MR_trace_browse_var(out, &MR_point.MR_point_vars[i],
- path, browser, caller, format);
+ bad_path = MR_trace_browse_var(out, print_var_name,
+ &MR_point.MR_point_vars[i], path, browser, caller, format);
if (bad_path == NULL) {
success_count++;
@@ -993,18 +996,75 @@
if (success_count == 0) {
return "the selected path does not exist in any of the variables with that name";
}
- } else {
- bad_path = MR_trace_browse_var(out, &MR_point.MR_point_vars[i],
- path, browser, caller, format);
- if (bad_path != NULL) {
- return MR_trace_bad_path(bad_path);
}
+
+ return NULL;
+}
+
+const char *
+MR_trace_print_size_one(FILE *out, char *word_spec)
+{
+#ifndef MR_RECORD_TERM_SIZES
+
+ return "term sizes not available in this grade";
+
+#else
+
+ int i;
+ MR_bool is_ambiguous;
+ const char *problem;
+ MR_Var_Spec var_spec;
+
+ MR_convert_arg_to_var_spec(word_spec, &var_spec);
+ problem = MR_lookup_var_spec(var_spec, &i, &is_ambiguous);
+ if (problem != NULL) {
+ return problem;
}
+
+ if (is_ambiguous) {
+ do {
+ fprintf(out, "%20s: %6u\n",
+ MR_point.MR_point_vars[i].MR_var_fullname,
+ MR_term_size(MR_point.MR_point_vars[i].MR_var_type,
+ MR_point.MR_point_vars[i].MR_var_value));
+ i++;
+ } while (i < MR_point.MR_point_var_count &&
+ MR_streq(var_spec.MR_var_spec_name,
+ MR_point.MR_point_vars[i].MR_var_fullname));
} else {
- MR_fatal_error("internal error: bad var_spec kind");
+ fprintf(out, "%20s: %6u\n",
+ MR_point.MR_point_vars[i].MR_var_fullname,
+ MR_term_size(MR_point.MR_point_vars[i].MR_var_type,
+ MR_point.MR_point_vars[i].MR_var_value));
}
return NULL;
+
+#endif
+}
+
+const char *
+MR_trace_print_size_all(FILE *out)
+{
+#ifndef MR_RECORD_TERM_SIZES
+ return "term sizes not available in this grade";
+#else
+ int i;
+ const char *problem;
+
+ if (MR_point.MR_point_problem != NULL) {
+ return MR_point.MR_point_problem;
+ }
+
+ for (i = 0; i < MR_point.MR_point_var_count; i++) {
+ fprintf(out, "%20s: %6u\n",
+ MR_point.MR_point_vars[i].MR_var_fullname,
+ MR_term_size(MR_point.MR_point_vars[i].MR_var_type,
+ MR_point.MR_point_vars[i].MR_var_value));
+ }
+
+ return NULL;
+#endif
}
#define BAD_PATH_BUFFER_SIZE 128
@@ -1041,7 +1101,7 @@
}
for (i = 0; i < MR_point.MR_point_var_count; i++) {
- (void) MR_trace_browse_var(out, &MR_point.MR_point_vars[i],
+ (void) MR_trace_browse_var(out, MR_TRUE, &MR_point.MR_point_vars[i],
NULL, browser, MR_BROWSE_CALLER_PRINT_ALL, format);
}
@@ -1065,8 +1125,8 @@
}
static char *
-MR_trace_browse_var(FILE *out, MR_Var_Details *var, char *path,
- MR_Browser browser, MR_Browse_Caller_Type caller,
+MR_trace_browse_var(FILE *out, MR_bool print_var_name, MR_Var_Details *var,
+ char *path, MR_Browser browser, MR_Browse_Caller_Type caller,
MR_Browse_Format format)
{
MR_TypeInfo typeinfo;
@@ -1132,7 +1192,11 @@
}
}
- if (out != NULL) {
+ if (print_var_name) {
+ if (out == NULL) {
+ MR_fatal_error("MR_trace_browse_var: out == NULL");
+ }
+
/*
** The initial blanks are to visually separate
** the variable names from the prompt.
@@ -1160,6 +1224,71 @@
return NULL;
}
+/*
+** Look up the specified variable. If the specified variable exists among the
+** variables of the current program point, return NULL, and set *var_index_ptr
+** to point to the index of the variable in the MR_point_vars array. If the
+** specification matches exactly than one variable in the array, then
+** *is_ambiguous_ptr will be set to false. If it matches more than one, then
+** *is_ambiguous_ptr will be set to true, and *var_index_ptr will be set
+** to the index of the lowest matching variable. You can then increment index
+** until the name no longer matches to find all the matching variables.
+** (Ambiguity is not possible if the variable is specified by number.)
+**
+** If the specified variable does not exist, the return value will point to an
+** error message.
+*/
+
+static const char *
+MR_lookup_var_spec(MR_Var_Spec var_spec, int *var_index_ptr,
+ MR_bool *is_ambiguous_ptr)
+{
+ int i;
+ MR_bool found;
+ const char *problem;
+
+ if (MR_point.MR_point_problem != NULL) {
+ return MR_point.MR_point_problem;
+ }
+
+ if (var_spec.MR_var_spec_kind == MR_VAR_SPEC_NUMBER) {
+ problem = MR_trace_valid_var_number(var_spec.MR_var_spec_number);
+ if (problem != NULL) {
+ return problem;
+ }
+
+ *var_index_ptr = var_spec.MR_var_spec_number - 1;
+ *is_ambiguous_ptr = MR_FALSE;
+ return NULL;
+ } else if (var_spec.MR_var_spec_kind == MR_VAR_SPEC_NAME) {
+ found = MR_FALSE;
+ for (i = 0; i < MR_point.MR_point_var_count; i++) {
+ if (MR_streq(var_spec.MR_var_spec_name,
+ MR_point.MR_point_vars[i].MR_var_fullname))
+ {
+ found = MR_TRUE;
+ break;
+ }
+ }
+
+ if (! found) {
+ return "there is no such variable";
+ }
+
+ *var_index_ptr = i;
+ if (MR_point.MR_point_vars[i].MR_var_is_ambiguous) {
+ *is_ambiguous_ptr = MR_TRUE;
+ } else {
+ *is_ambiguous_ptr = MR_FALSE;
+ }
+
+ return NULL;
+ } else {
+ MR_fatal_error("internal error: bad var_spec kind");
+ return NULL;
+ }
+}
+
MR_ConstString
MR_hlds_var_name(const MR_Proc_Layout *entry, int hlds_var_num)
{
@@ -1254,4 +1383,68 @@
}
return NULL;
+}
+
+static void
+MR_trace_check_integrity_on_cur_level(void)
+{
+ int i;
+
+ for (i = 0; i < MR_point.MR_point_var_count; i++) {
+ (void) MR_trace_browse_var(stdout, MR_TRUE, &MR_point.MR_point_vars[i],
+ (MR_String) (MR_Integer) "", MR_trace_print,
+ MR_BROWSE_CALLER_PRINT, MR_BROWSE_DEFAULT_FORMAT);
+ (void) MR_term_size(MR_point.MR_point_vars[i].MR_var_type,
+ MR_point.MR_point_vars[i].MR_var_value);
+ }
+}
+
+#define MR_INTEGRITY_ERROR_BUF_SIZE 512
+
+static int MR_check_max_mr_num;
+static MR_Word MR_check_saved_regs[MR_MAX_FAKE_REG];
+
+static int MR_check_integrity_seq_num = 0;
+
+void
+MR_trace_check_integrity(const MR_Label_Layout *layout, MR_Trace_Port port)
+{
+ int level;
+ const char *problem;
+ char buf[MR_INTEGRITY_ERROR_BUF_SIZE];
+ MR_bool saved_trace_enabled;
+
+ saved_trace_enabled = MR_trace_enabled;
+ MR_trace_enabled = MR_FALSE;
+
+ MR_compute_max_mr_num(MR_check_max_mr_num, layout);
+ MR_restore_transient_registers();
+ /* This also saves the regs in MR_fake_regs. */
+ MR_copy_regs_to_saved_regs(MR_check_max_mr_num, MR_check_saved_regs);
+ MR_trace_init_point_vars(layout, MR_check_saved_regs, port, MR_TRUE);
+
+ if (MR_point.MR_point_problem != NULL) {
+ MR_fatal_error(problem);
+ }
+
+ level = 0;
+ do {
+ MR_check_integrity_seq_num++;
+#if 0
+ sprintf(buf, "integrity check at event %d, level %d, seq %d\n",
+ MR_trace_event_number, level, MR_check_integrity_seq_num);
+#endif
+ MR_trace_report_msg = buf;
+ fprintf(stdout, "%s", buf);
+ fflush(stdout);
+ MR_trace_check_integrity_on_cur_level();
+ level++;
+ problem = MR_trace_set_level(level, MR_TRUE);
+ } while (problem == NULL);
+
+ MR_restore_transient_registers();
+ MR_saved_global_hp(MR_check_saved_regs) = MR_global_hp;
+ MR_copy_saved_regs_to_regs(MR_check_max_mr_num, MR_check_saved_regs);
+ MR_trace_report_msg = NULL;
+ MR_trace_enabled = saved_trace_enabled;
}
Index: trace/mercury_trace_vars.h
===================================================================
RCS file: /home/mercury1/repository/mercury/trace/mercury_trace_vars.h,v
retrieving revision 1.21
diff -u -b -r1.21 mercury_trace_vars.h
--- trace/mercury_trace_vars.h 15 May 2002 11:24:21 -0000 1.21
+++ trace/mercury_trace_vars.h 22 May 2003 04:01:27 -0000
@@ -74,6 +74,14 @@
} MR_Var_Spec;
/*
+** This function converts a variable name or variable number to MR_Var_Spec
+** format.
+*/
+
+extern void MR_convert_arg_to_var_spec(const char *word_spec,
+ MR_Var_Spec *var_spec);
+
+/*
** These functions are documented near the top of this file.
*/
@@ -170,7 +178,8 @@
** number in the set of live variables at the current point; the desired part
** is specified by zero or more suffixes of the form ^argnum or /argnum.
**
-** The names are printed to the given file if the file pointer is non-NULL.
+** The names are printed to the file specified by the out parameter if
+** print_var_name is set, which requires out to be non-NULL.
** The values are printed by giving them to the specified browser.
** The last argument governs whether this function returns an error
** if the given variable specification is ambiguous.
@@ -178,15 +187,16 @@
** XXX Actually, the "out" parameter is currently ignored by the browser.
*/
-extern const char *MR_trace_parse_browse_one(FILE *out, char *word_spec,
+extern const char *MR_trace_parse_browse_one(FILE *out,
+ MR_bool print_var_name, char *word_spec,
MR_Browser browser,
MR_Browse_Caller_Type caller,
MR_Browse_Format format,
MR_bool must_be_unique);
/*
-** Print the (names and) values of the specified variables.
-** The names are printed to the given file if the file pointer is non-NULL.
+** Print the (name and) value of the specified variable.
+** The name is printed to the given file if print_var_name is set.
** The values are printed by giving them to the specified browser.
** The last argument governs whether this function returns an error
** if the given variable specification is ambiguous.
@@ -194,8 +204,8 @@
** XXX Actually, the "out" parameter is currently ignored by the browser.
*/
-extern const char *MR_trace_browse_one(FILE *out, MR_Var_Spec var_spec,
- MR_Browser browser,
+extern const char *MR_trace_browse_one(FILE *out, MR_bool print_var_name,
+ MR_Var_Spec var_spec, MR_Browser browser,
MR_Browse_Caller_Type caller,
MR_Browse_Format format,
MR_bool must_be_unique);
@@ -226,6 +236,21 @@
int ancestor_level, MR_bool print_optionals);
/*
+** Print the size of the specified variable(s) to the specified file.
+** Return a non-NULL error message if this is not possible.
+*/
+
+extern const char * MR_trace_print_size_one(FILE *out,
+ char *word_spec);
+
+/*
+** Print the size of all the variables at the current program point to the
+** specified file. Return a non-NULL error message if this is not possible.
+*/
+
+extern const char * MR_trace_print_size_all(FILE *out);
+
+/*
** Return the name (if any) of the variable with the given HLDS variable number
** in the procedure indicated by the first argument.
*/
@@ -239,5 +264,12 @@
extern MR_Completer_List *MR_trace_var_completer(const char *word,
size_t word_len);
+
+/*
+** Performs integrity checks on the whether
+*/
+
+extern void MR_trace_check_integrity(const MR_Label_Layout *layout,
+ MR_Trace_Port port);
#endif /* MERCURY_TRACE_VARS_H */
cvs diff: Diffing util
Index: util/mkinit.c
===================================================================
RCS file: /home/mercury1/repository/mercury/util/mkinit.c,v
retrieving revision 1.89
diff -u -b -r1.89 mkinit.c
--- util/mkinit.c 25 Sep 2002 07:53:53 -0000 1.89
+++ util/mkinit.c 3 Apr 2003 13:59:12 -0000
@@ -287,6 +287,19 @@
" MR_address_of_write_out_proc_statics =\n"
" write_out_proc_statics;\n"
"#endif\n"
+ " MR_type_ctor_info_for_univ = MR_lib_type_ctor_info_for_univ;\n"
+ " MR_type_info_for_type_info = (MR_TypeInfo)\n"
+ " &MR_lib_type_info_for_type_info;\n"
+ " MR_type_info_for_list_of_univ = (MR_TypeInfo)\n"
+ " &MR_lib_type_info_for_list_of_univ;\n"
+ " MR_type_info_for_list_of_int = (MR_TypeInfo)\n"
+ " &MR_lib_type_info_for_list_of_int;\n"
+ " MR_type_info_for_list_of_char = (MR_TypeInfo)\n"
+ " &MR_lib_type_info_for_list_of_char;\n"
+ " MR_type_info_for_list_of_string = (MR_TypeInfo)\n"
+ " &MR_lib_type_info_for_list_of_string;\n"
+ " MR_type_info_for_list_of_type_info = (MR_TypeInfo)\n"
+ " &MR_lib_type_info_for_list_of_type_info;\n"
" MR_address_of_do_load_aditi_rl_code = %s;\n"
"#ifdef MR_CONSERVATIVE_GC\n"
" MR_address_of_init_gc = init_gc;\n"
cvs diff: Diffing vim
cvs diff: Diffing vim/after
cvs diff: Diffing vim/ftplugin
cvs diff: Diffing vim/syntax
--------------------------------------------------------------------------
mercury-reviews mailing list
post: mercury-reviews at cs.mu.oz.au
administrative address: owner-mercury-reviews at cs.mu.oz.au
unsubscribe: Address: mercury-reviews-request at cs.mu.oz.au Message: unsubscribe
subscribe: Address: mercury-reviews-request at cs.mu.oz.au Message: subscribe
--------------------------------------------------------------------------
More information about the reviews
mailing list