[m-rev.] for review: term size profiling
Zoltan Somogyi
zs at cs.mu.OZ.AU
Wed Oct 1 18:21:38 AEST 2003
For review by Simon.
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.
The diff overhauls 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, converting type_ctor_infos into
type_infos only as necessary. It also includes separating type_ctor_infos,
type_infos, base_typeclass_infos and typeclass_infos (as well as voids,
for clarity) from plain user-defined type constructors in type categorizations.
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).
The diff adds a new mdb command, term_size. It also replaces the proc_body
mdb command with new ways of using the existing print and browse commands
("print proc_body" and "browse proc_body") in order to make looking at
procedure bodies more controllable. This was useful in debugging the effect
of term size profiling on some test case outputs. It is not strictly tied
to term size profiling, but turns out to be difficult to disentangle.
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, and the term_size mdb command. The documentation is
commented out for now.
Modify the wording of the 'u' HLDS dump flag to include other details
of unifications (e.g. term size info) rather than just unification
categories.
Document the new alternatives of the print and browse commands. Since
they are for developers only, the documentation is commented out.
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/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/code_info.m:
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/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/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 they used to be classified) is not always correct.
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 whose updated implementation is now in type_util.m.
compiler/mlds_to_c.m:
compiler/mlds_to_gcc.m:
compiler/mlds_to_il.m:
compiler/mlds_to_java.m:
Still treat type_infos, type_ctor_infos, typeclass_infos and
base_typeclass_infos as user-defined types, but prepare for when
they won't be.
compiler/hlds_pred.m:
Require interface typeinfo liveness when term size profiling is
enabled.
compiler/hlds_out.m:
Print the size annotations on unifications if HLDS dump flags call
for unification details. (The flag test is in the caller of the
modified predicate.)
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 or dynamic cell. Term size profiling uses this with N=1.
compiler/llds_out.m:
When allocating memory on the heap, use the macro variants that
specify an optional offset, and specify the offset when required.
compiler/bytecode_gen.m:
compiler/dense_switch.m:
compiler/dupelim.m:
compiler/exprn_aux.m:
compiler/goal_form.m:
compiler/goal_util.m:
compiler/higher_order.m:
compiler/inst_match.m:
compiler/intermod.m:
compiler/jumpopt.m:
compiler/lambda.m:
compiler/livemap.m:
compiler/ll_pseudo_type_info.m:
compiler/lookup_switch.m:
compiler/magic_util.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/post_typecheck.m:
compiler/reassign.m:
compiler/rl.m:
compiler/rl_key.m:
compiler/special_pred.m:
compiler/stack_layout.m:
compiler/static_term.m:
compiler/string_switch.m:
compiler/switch_gen.m:
compiler/switch_util.m:
compiler/table_gen.m:
compiler/term_util.m:
compiler/type_ctor_info.m:
compiler/unused_args.m:
compiler/use_local_vars.m:
Minor updates to conform to the changes above.
library/term_size_prof_builtin.m:
New module containing helper predicates for term size profiling.
size_prof.m generates call to these predicates.
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.
Fix formatting of foreign_procs.
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.
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.
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_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.
Call new diagnostic macros that can help debug heap allocations.
Document why the macros in this files must expand to expressions
instead of statements, evn though the latter would be preferable
(e.g. by allowing them to declare and use local variables without
depending on gcc extensions).
runtime/mercury_debug.[ch]:
Add diagnostic macros to debug heap allocations, and the functions
behind them if MR_DEBUG_HEAP_ALLOC is defined.
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.
runtime/mercury_string.h:
Provide some needed variants of the macro for copying strings.
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_ho_call.c:
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_stack_layout.h:
Delete the definition of MR_Proc_Id, which is now in mercury_proc_id.h.
runtime/mercury_type_info.h:
Delete the macros for manipulating univs, which are now in
mercury_univ.h.
runtime/Mmakefile:
Mention the new files.
runtime/mercury_imp.h:
runtime/mercury.h:
runtime/mercury_construct.c:
runtime/mercury_deep_profiling.h:
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.c:
runtime/mercury_type_info.c:
Use the new macros supplying type information when constructing lists.
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.
Replace the "proc_body" command with optional arguments to the "print"
and "browse" commands.
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.
Add documentation of the new arguments of the print and browse mdb
commands. Since they are for implementors only, the documentation
is commented out.
trace/mercury_trace_vars.[ch]:
Add the functions needed to implement the term_size command, and
factor out the code common to the "size" and "print"/"browse" 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.
trace/mercury_trace_browse.c:
trace/mercury_trace_external.c:
trace/mercury_trace_help.c:
Supply type information when constructing terms.
browser/program_representation.m:
Since the new library module term_size_prof_builtin never generates
any events, mark it as such, so that the declarative debugger doesn't
expect it to generate any.
Do the same for the deep profiling builtin module.
tests/debugger/term_size_words.{m,inp,exp}:
tests/debugger/term_size_cells.{m,inp,exp}:
Two new test cases, each testing one of the new grades.
tests/debugger/Mmakefile:
Enable the two new test cases in their grades.
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,
and delete "proc_body".
tests/debugger/declarative/dependency.{inp,exp}:
Use "print proc_body" instead of "proc_body".
tests/hard_coded/nondet_c.m:
tests/hard_coded/pragma_inline.m:
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.
tests/valid/Mmakefile:
Disable Aditi tests in term profiling grades, since Aditi will never
support term size profiling.
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/program_representation.m
===================================================================
RCS file: /home/mercury1/repository/mercury/browser/program_representation.m,v
retrieving revision 1.9
diff -u -b -r1.9 program_representation.m
--- browser/program_representation.m 30 May 2003 07:41:11 -0000 1.9
+++ browser/program_representation.m 27 Aug 2003 12:11:44 -0000
@@ -233,9 +233,15 @@
).
call_is_primitive(ModuleName, PredName) :-
+ (
ModuleName = "builtin",
( PredName = "unify"
; PredName = "compare"
+ )
+ ;
+ ModuleName = "profiling_builtin"
+ ;
+ ModuleName = "term_size_prof_builtin"
).
convert_dirs_to_term_path([], []).
cvs diff: Diffing bytecode
cvs diff: Diffing compiler
Index: compiler/builtin_ops.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/builtin_ops.m,v
retrieving revision 1.13
diff -u -b -r1.13 builtin_ops.m
--- compiler/builtin_ops.m 30 May 2003 07:01:03 -0000 1.13
+++ compiler/builtin_ops.m 30 May 2003 08:47:46 -0000
@@ -176,6 +176,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.75
diff -u -b -r1.75 bytecode_gen.m
--- compiler/bytecode_gen.m 24 Jun 2003 14:20:46 -0000 1.75
+++ compiler/bytecode_gen.m 22 Sep 2003 01:22:13 -0000
@@ -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/compile_target_code.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/compile_target_code.m,v
retrieving revision 1.48
diff -u -b -r1.48 compile_target_code.m
--- compiler/compile_target_code.m 24 Sep 2003 06:50:36 -0000 1.48
+++ compiler/compile_target_code.m 30 Sep 2003 03:15:30 -0000
@@ -496,7 +496,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,
@@ -624,8 +645,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/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/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 22 Sep 2003 01:23:44 -0000
@@ -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.86
diff -u -b -r1.86 goal_util.m
--- compiler/goal_util.m 29 May 2003 18:17:14 -0000 1.86
+++ compiler/goal_util.m 22 Sep 2003 01:24:08 -0000
@@ -474,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, Size),
Must, Subn,
- construct(Var, ConsId, Vars, Modes, How, Uniq, Aditi)) :-
+ construct(Var, ConsId, Vars, Modes, How, Uniq, Size)) :-
goal_util__rename_var(Var0, Must, Subn, Var),
goal_util__rename_var_list(Vars0, Must, Subn, Vars),
(
Index: compiler/handle_options.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/handle_options.m,v
retrieving revision 1.186
diff -u -b -r1.186 handle_options.m
--- compiler/handle_options.m 6 Aug 2003 12:38:09 -0000 1.186
+++ compiler/handle_options.m 24 Sep 2003 06:31:34 -0000
@@ -820,6 +820,27 @@
[]
),
+ 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")
+ ;
+ []
+ ),
+
(
{ given_trace_level_is_none(TraceLevel) = yes
; HighLevel = no, Target = c
@@ -1437,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
@@ -1697,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).
@@ -1802,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.110
diff -u -b -r1.110 higher_order.m
--- compiler/higher_order.m 24 Jun 2003 14:20:47 -0000 1.110
+++ compiler/higher_order.m 22 Sep 2003 01:25:00 -0000
@@ -1087,7 +1087,7 @@
(
{ Goal0 = unify(_, _, UniMode, Unify0, Context) },
{ Unify0 = construct(LVar, ConsId0, Args0, _,
- HowToConstruct, CellIsUnique, MaybeExprn) },
+ HowToConstruct, CellIsUnique, no) },
{ ConsId0 = pred_const(PredId, ProcId, EvalMethod) },
{ map__contains(NewPreds, proc(PredId, ProcId)) },
{ proc_info_vartypes(ProcInfo0, VarTypes0) },
@@ -1155,9 +1155,8 @@
{ NewConsId = pred_const(NewPredId, NewProcId,
EvalMethod) },
- { Unify = construct(LVar, NewConsId,
- NewArgs, UniModes, HowToConstruct,
- CellIsUnique, MaybeExprn) },
+ { Unify = construct(LVar, NewConsId, NewArgs, UniModes,
+ HowToConstruct, CellIsUnique, no) },
{ Goal2 = unify(LVar, functor(NewConsId, no, NewArgs),
UniMode, Unify, Context) },
@@ -1556,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]
@@ -2151,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,
@@ -2169,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")
@@ -2179,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)
@@ -3041,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.107
diff -u -b -r1.107 hlds_goal.m
--- compiler/hlds_goal.m 19 Sep 2003 11:10:02 -0000 1.107
+++ compiler/hlds_goal.m 30 Sep 2003 07:18:40 -0000
@@ -375,7 +375,22 @@
construct_is_unique :: cell_is_unique,
% Can the cell be allocated
% in shared data.
- maybe(unit) % Unused.
+ 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.
+ %
+ % The content of this slot is not
+ % meaningful before the size_prof pass
+ % has been run.
)
% A deconstruction unification is a unification with a functor
@@ -461,6 +476,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
@@ -1812,9 +1836,8 @@
RHS = functor(ConsId, no, []),
Inst = bound(unique, [functor(ConsId, [])]),
Mode = (free -> Inst) - (Inst -> Inst),
- RLExprnId = no,
Unification = construct(Var, ConsId, [], [],
- construct_dynamically, cell_is_unique, RLExprnId),
+ construct_dynamically, cell_is_unique, no),
Context = unify_context(explicit, []),
Goal = unify(Var, RHS, Mode, Unification, Context),
set__singleton_set(NonLocals, Var),
@@ -1829,9 +1852,8 @@
UnifyMode = (free_inst -> ground_inst) - (ground_inst -> ground_inst),
UniMode = ((free_inst - ground_inst) -> (ground_inst - ground_inst)),
list__duplicate(Arity, UniMode, UniModes),
- ExprnId = no,
Unification = construct(Tuple, ConsId, Args, UniModes,
- construct_dynamically, cell_is_unique, ExprnId),
+ construct_dynamically, cell_is_unique, no),
UnifyContext = unify_context(explicit, []),
Unify = unify(Tuple, Rhs, UnifyMode, Unification, UnifyContext),
set__list_to_set([Tuple | Args], NonLocals),
Index: compiler/hlds_out.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_out.m,v
retrieving revision 1.315
diff -u -b -r1.315 hlds_out.m
--- compiler/hlds_out.m 19 Sep 2003 11:10:02 -0000 1.315
+++ compiler/hlds_out.m 22 Sep 2003 01:25:50 -0000
@@ -2167,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, 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.129
diff -u -b -r1.129 hlds_pred.m
--- compiler/hlds_pred.m 19 Sep 2003 11:10:02 -0000 1.129
+++ compiler/hlds_pred.m 21 Sep 2003 23:32:25 -0000
@@ -2468,6 +2468,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/inst_match.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/inst_match.m,v
retrieving revision 1.55
diff -u -b -r1.55 inst_match.m
--- compiler/inst_match.m 28 Jul 2003 21:50:43 -0000 1.55
+++ compiler/inst_match.m 22 Aug 2003 04:54:14 -0000
@@ -2030,20 +2030,24 @@
:- mode type_may_contain_solver_type(in, in) is semidet.
type_may_contain_solver_type(Type, ModuleInfo) :-
- classify_type(Type, ModuleInfo, Category),
- type_may_contain_solver_type_2(Category) = yes.
+ type_may_contain_solver_type_2(classify_type(ModuleInfo, Type)) = yes.
-:- func type_may_contain_solver_type_2(builtin_type) = bool.
+:- func type_may_contain_solver_type_2(type_category) = bool.
type_may_contain_solver_type_2(int_type) = no.
type_may_contain_solver_type_2(char_type) = no.
type_may_contain_solver_type_2(str_type) = no.
type_may_contain_solver_type_2(float_type) = no.
-type_may_contain_solver_type_2(pred_type) = no.
+type_may_contain_solver_type_2(higher_order_type) = no.
type_may_contain_solver_type_2(tuple_type) = yes.
type_may_contain_solver_type_2(enum_type) = no.
-type_may_contain_solver_type_2(polymorphic_type) = yes.
-type_may_contain_solver_type_2(user_type) = yes.
+type_may_contain_solver_type_2(variable_type) = yes.
+type_may_contain_solver_type_2(type_info_type) = no.
+type_may_contain_solver_type_2(type_ctor_info_type) = no.
+type_may_contain_solver_type_2(typeclass_info_type) = no.
+type_may_contain_solver_type_2(base_typeclass_info_type) = no.
+type_may_contain_solver_type_2(void_type) = no.
+type_may_contain_solver_type_2(user_ctor_type) = yes.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
Index: compiler/intermod.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/intermod.m,v
retrieving revision 1.146
diff -u -b -r1.146 intermod.m
--- compiler/intermod.m 19 Sep 2003 11:10:02 -0000 1.146
+++ compiler/intermod.m 21 Sep 2003 23:32:26 -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.82
diff -u -b -r1.82 lambda.m
--- compiler/lambda.m 19 Sep 2003 11:10:03 -0000 1.82
+++ compiler/lambda.m 22 Sep 2003 01:26:19 -0000
@@ -581,9 +581,8 @@
ConsId = pred_const(PredId, ProcId, EvalMethod),
Functor = functor(ConsId, no, ArgVars),
- RLExprnId = no,
Unification = construct(Var, ConsId, ArgVars, UniModes,
- construct_dynamically, cell_is_unique, RLExprnId),
+ construct_dynamically, cell_is_unique, no),
LambdaInfo = lambda_info(VarSet, VarTypes, Constraints, TVarSet,
InstVarSet, TVarMap, TCVarMap, Markers, POF, OrigPredName,
Owner, ModuleInfo, MustRecomputeNonLocals).
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.216
diff -u -b -r1.216 llds_out.m
--- compiler/llds_out.m 6 Aug 2003 12:38:09 -0000 1.216
+++ compiler/llds_out.m 8 Aug 2003 02:27: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 - _ },
@@ -2103,7 +2112,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) } ->
@@ -3468,12 +3477,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/magic_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/magic_util.m,v
retrieving revision 1.30
diff -u -b -r1.30 magic_util.m
--- compiler/magic_util.m 25 Jul 2003 02:27:20 -0000 1.30
+++ compiler/magic_util.m 22 Sep 2003 01:31:36 -0000
@@ -502,9 +502,8 @@
{ Rhs = functor(cons(qualified(PredModule, PredName), Arity),
no, InputVars) },
- { RLExprnId = no },
{ Uni = construct(Var, ConsId, InputVars, Modes,
- construct_dynamically, cell_is_unique, RLExprnId) },
+ construct_dynamically, cell_is_unique, no) },
{ Goal1 = unify(Var, Rhs, UniMode, Uni, Context) - Info },
{ list__append(InputGoals, [Goal1], InputAndClosure) }
@@ -841,11 +840,10 @@
{ Rhs = functor(cons(qualified(SuppModule, SuppName),
SuppArity), no, LambdaInputs) },
- { RLExprnId = no },
{ Unify = construct(InputVar,
pred_const(SuppPredId, SuppProcId, (aditi_bottom_up)),
LambdaInputs, UniModes, construct_dynamically,
- cell_is_unique, RLExprnId) },
+ cell_is_unique, no) },
{ UnifyContext = unify_context(explicit, []) },
% Construct a goal_info.
@@ -1292,7 +1290,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.446
diff -u -b -r1.446 make_hlds.m
--- compiler/make_hlds.m 19 Sep 2003 11:10:03 -0000 1.446
+++ compiler/make_hlds.m 30 Sep 2003 07:36:41 -0000
@@ -4418,8 +4418,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
+ % to add term_size_prof_builtin.term_size_plus is bootstrapped
+ % prog_out__write_context(Context),
+ % report_warning("Warning: clause for builtin.\n"),
{ ModuleInfo = ModuleInfo1 },
{ Info = Info0 }
;
Index: compiler/mercury_compile.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mercury_compile.m,v
retrieving revision 1.289
diff -u -b -r1.289 mercury_compile.m
--- compiler/mercury_compile.m 6 Aug 2003 12:38:10 -0000 1.289
+++ compiler/mercury_compile.m 8 Aug 2003 02:27:19 -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
@@ -2179,8 +2180,14 @@
mercury_compile__maybe_dump_hlds(HLDS47, "47", "magic"),
mercury_compile__maybe_eliminate_dead_procs(HLDS47, Verbose, Stats,
- HLDS49),
- mercury_compile__maybe_dump_hlds(HLDS49, "49", "dead_procs"),
+ 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
@@ -3259,6 +3266,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.73
diff -u -b -r1.73 ml_code_util.m
--- compiler/ml_code_util.m 25 Sep 2003 07:56:28 -0000 1.73
+++ compiler/ml_code_util.m 30 Sep 2003 03:15:33 -0000
@@ -1769,10 +1769,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.
%-----------------------------------------------------------------------------%
%
@@ -2170,6 +2185,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.
@@ -2197,16 +2216,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
@@ -2321,7 +2345,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.67
diff -u -b -r1.67 ml_unify_gen.m
--- compiler/ml_unify_gen.m 25 Jul 2003 02:27:21 -0000 1.67
+++ compiler/ml_unify_gen.m 30 Sep 2003 07:31:33 -0000
@@ -147,15 +147,12 @@
ml_gen_set_success(Test, Context, MLDS_Statement).
ml_gen_unification(construct(Var, ConsId, Args, ArgModes,
- HowToConstruct, _CellIsUnique, MaybeAditiRLExprnID),
+ HowToConstruct, _CellIsUnique, MaybeSizeProfInfo),
CodeModel, Context, MLDS_Decls, MLDS_Statements) -->
{ require(unify(CodeModel, model_det),
"ml_code_gen: construct not det") },
- { MaybeAditiRLExprnID = yes(_) ->
- sorry(this_file, "Aditi closures")
- ;
- true
- },
+ { require(unify(MaybeSizeProfInfo, no),
+ "ml_code_gen: term size profiling not yet supported") },
ml_gen_construct(Var, ConsId, Args, ArgModes, HowToConstruct, Context,
MLDS_Decls, MLDS_Statements).
@@ -827,8 +824,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)
;
@@ -845,7 +846,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,
@@ -870,7 +871,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),
@@ -889,7 +891,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)
;
@@ -970,7 +972,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.104
diff -u -b -r1.104 mlds.m
--- compiler/mlds.m 25 Jul 2003 02:27:22 -0000 1.104
+++ compiler/mlds.m 29 Jul 2003 07:55:51 -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
@@ -1759,7 +1759,7 @@
),
MLDSType = mlds__foreign_type(ForeignType)
;
- 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.151
diff -u -b -r1.151 mlds_to_c.m
--- compiler/mlds_to_c.m 13 Jul 2003 08:25:36 -0000 1.151
+++ compiler/mlds_to_c.m 29 Jul 2003 07:55:51 -0000
@@ -1111,8 +1111,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)
@@ -1824,7 +1825,7 @@
( { HighLevelData = yes } ->
mlds_output_mercury_user_type_name(
qualified(unqualified("array"), "array") - 1,
- user_type)
+ user_ctor_type)
;
io__write_string("MR_ArrayPtr")
).
@@ -1906,7 +1907,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.
@@ -1924,13 +1925,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")
@@ -1941,11 +1965,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.
@@ -1964,7 +1988,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.
@@ -2946,8 +2970,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.
@@ -2971,7 +2995,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.
@@ -3228,7 +3251,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.131
diff -u -b -r1.131 mlds_to_il.m
--- compiler/mlds_to_il.m 17 Jul 2003 14:40:22 -0000 1.131
+++ compiler/mlds_to_il.m 30 Sep 2003 07:50:05 -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, TypeCategory, _)) =
+ mlds_mercury_type_to_ilds_type(ILDataRep, MercuryType, TypeCategory).
+
+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,
@@ -3384,8 +3389,6 @@
ModuleName = ModuleName0
).
-
-
:- pred mangle_dataname(mlds__data_name, string).
:- mode mangle_dataname(in, out) is det.
@@ -3432,7 +3435,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) :-
@@ -3493,7 +3495,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) :-
@@ -3506,14 +3507,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) :-
@@ -3627,7 +3625,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.
@@ -3638,7 +3635,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
@@ -4166,7 +4162,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).
@@ -4191,8 +4188,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,
@@ -4202,7 +4197,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").
@@ -4247,7 +4243,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 ->
@@ -4267,7 +4262,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.
@@ -4405,7 +4399,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.43
diff -u -b -r1.43 mlds_to_java.m
--- compiler/mlds_to_java.m 8 Jul 2003 10:29:57 -0000 1.43
+++ compiler/mlds_to_java.m 29 Jul 2003 07:55:37 -0000
@@ -154,11 +154,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.
%
@@ -1328,11 +1342,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".
@@ -1745,7 +1765,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 []'.
@@ -1812,7 +1832,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.
@@ -1830,23 +1850,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("/* Tuple */ java.lang.Object")
;
- { TypeCategory = pred_type },
+ { TypeCategory = higher_order_type },
io__write_string("/* closure */ 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.
@@ -2671,7 +2707,7 @@
),
(
{ Type = mlds__array_type(_Type)
- ; Type = mlds__mercury_type(_Type, pred_type, _)
+ ; Type = mlds__mercury_type(_Type, higher_order_type, _)
; Type = mlds__mercury_type(MercType, _, _),
hand_defined_type(MercType, _, yes)
}
Index: compiler/modecheck_unify.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/modecheck_unify.m,v
retrieving revision 1.61
diff -u -b -r1.61 modecheck_unify.m
--- compiler/modecheck_unify.m 3 Aug 2003 13:33:21 -0000 1.61
+++ compiler/modecheck_unify.m 22 Sep 2003 01:38:52 -0000
@@ -1034,16 +1034,20 @@
Unification, ModeInfo) :-
% if we are re-doing mode analysis, preserve the existing cons_id
list__length(ArgVars, Arity),
- ( Unification0 = construct(_, ConsId0, _, _, _, _, AditiInfo0) ->
- AditiInfo = AditiInfo0,
+ (
+ Unification0 = construct(_, ConsId0, _, _, _, _, MaybeSize0)
+ ->
+ MaybeSize = MaybeSize0,
ConsId = ConsId0
- ; Unification0 = deconstruct(_, ConsId1, _, _, _, _) ->
- AditiInfo = no,
+ ;
+ Unification0 = deconstruct(_, ConsId1, _, _, _, _)
+ ->
+ 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),
@@ -1090,7 +1094,7 @@
RHS = RHS0
),
Unification = construct(X, ConsId, ArgVars, ArgModes,
- construct_dynamically, cell_is_unique, AditiInfo),
+ construct_dynamically, cell_is_unique, MaybeSize),
ModeInfo = ModeInfo0
;
instmap__is_reachable(InstMap)
@@ -1132,11 +1136,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,
@@ -1145,9 +1152,8 @@
mode_is_output(ModuleInfo, ModeOfX)
->
% It's a construction.
- RLExprnId = no,
Unification = construct(X, ConsId, ArgVars, ArgModes,
- construct_dynamically, cell_is_unique, RLExprnId),
+ construct_dynamically, cell_is_unique, 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.278
diff -u -b -r1.278 modules.m
--- compiler/modules.m 6 Aug 2003 12:38:10 -0000 1.278
+++ compiler/modules.m 8 Aug 2003 02:27:20 -0000
@@ -824,6 +824,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").
@@ -1893,8 +1894,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
@@ -1977,8 +1978,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.
@@ -2089,22 +2090,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
@@ -2116,19 +2116,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.
@@ -5320,16 +5333,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.133
diff -u -b -r1.133 opt_debug.m
--- compiler/opt_debug.m 27 May 2003 05:57:15 -0000 1.133
+++ compiler/opt_debug.m 27 May 2003 05:57:50 -0000
@@ -319,10 +319,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).
@@ -677,7 +686,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,
@@ -686,9 +695,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.122
diff -u -b -r1.122 opt_util.m
--- compiler/opt_util.m 27 May 2003 05:57:16 -0000 1.122
+++ compiler/opt_util.m 27 May 2003 05:57:50 -0000
@@ -754,7 +754,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,
@@ -819,7 +819,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),
@@ -998,7 +998,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).
@@ -1066,7 +1066,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).
@@ -1112,7 +1112,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).
@@ -1175,7 +1175,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(_), [], []).
@@ -1223,7 +1223,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(_), []).
@@ -1288,7 +1288,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], []).
@@ -1417,7 +1417,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) :-
@@ -1546,7 +1546,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)
@@ -1691,7 +1691,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
@@ -1807,8 +1807,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),
@@ -2041,8 +2041,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.417
diff -u -b -r1.417 options.m
--- compiler/options.m 25 Sep 2003 07:56:28 -0000 1.417
+++ compiler/options.m 30 Sep 2003 03:15:34 -0000
@@ -227,9 +227,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
@@ -866,6 +868,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),
@@ -1503,6 +1507,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).
@@ -3051,6 +3057,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/polymorphism.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/polymorphism.m,v
retrieving revision 1.241
diff -u -b -r1.241 polymorphism.m
--- compiler/polymorphism.m 30 Sep 2003 07:15:23 -0000 1.241
+++ compiler/polymorphism.m 30 Sep 2003 07:37:53 -0000
@@ -167,7 +167,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.
@@ -259,10 +259,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)).
@@ -296,6 +296,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.
+
:- implementation.
:- import_module backend_libs__base_typeclass_info.
@@ -321,7 +372,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.
%-----------------------------------------------------------------------------%
@@ -1116,7 +1167,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
@@ -2438,9 +2488,8 @@
BaseTypeClassInfoTerm = functor(ConsId, no, []),
% 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, no),
BaseUnifyMode = (free -> ground(shared, none)) -
(ground(shared, none) -> ground(shared, none)),
BaseUnifyContext = unify_context(explicit, []),
@@ -2472,8 +2521,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, no),
UnifyMode = (free -> ground(shared, none)) -
(ground(shared, none) -> ground(shared, none)),
UnifyContext = unify_context(explicit, []),
@@ -2637,40 +2686,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
@@ -2721,8 +2754,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),
@@ -2736,7 +2769,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,
@@ -2746,75 +2779,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_cell,
- 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_cell,
- 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,
@@ -2830,7 +2902,7 @@
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),
@@ -2840,59 +2912,46 @@
PredName = qualified(mercury_private_builtin_module, Name)
).
-:- pred polymorphism__get_category_name(builtin_type, string).
-:- mode polymorphism__get_category_name(in, out) is det.
-
-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),
- polymorphism_cell, 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.
+:- func polymorphism__get_category_name(type_category) = maybe(string).
-polymorphism__init_type_info_var(Type, ArgVars, WhichCell, VarSet0, VarTypes0,
- TypeInfoVar, TypeInfoGoal, VarSet, VarTypes) :-
- ConsId = cell_cons_id(WhichCell),
+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, MaybePreferredVar, TypeInfoVar,
+ TypeInfoGoal, !VarSet, !VarTypes) :-
+ ConsId = cell_cons_id(type_info_cell),
TypeInfoTerm = functor(ConsId, no, ArgVars),
% introduce a new variable
- polymorphism__new_type_info_var_raw(Type, cell_type_name(WhichCell),
- typeinfo_prefix, VarSet0, VarTypes0, TypeInfoVar,
- VarSet, VarTypes),
+ (
+ MaybePreferredVar = yes(TypeInfoVar)
+ ;
+ MaybePreferredVar = no,
+ polymorphism__new_type_info_var_raw(Type, type_info,
+ TypeInfoVar, !VarSet, !VarTypes)
+ ),
% create the construction unification to initialize the variable
UniMode = (free - ground(shared, none) ->
ground(shared, none) - ground(shared, none)),
list__length(ArgVars, NumArgVars),
list__duplicate(NumArgVars, UniMode, UniModes),
- RLExprnId = no,
Unification = construct(TypeInfoVar, ConsId, ArgVars, UniModes,
- construct_dynamically, cell_is_unique, RLExprnId),
+ construct_dynamically, cell_is_unique, no),
UnifyMode = (free -> ground(shared, none)) -
(ground(shared, none) -> ground(shared, none)),
UnifyContext = unify_context(explicit, []),
@@ -2906,7 +2965,7 @@
% note that we could perhaps be more accurate than
% `ground(shared)', but it shouldn't make any
% difference.
- InstConsId = cell_inst_cons_id(WhichCell, NumArgVars),
+ InstConsId = cell_inst_cons_id(type_info_cell, NumArgVars),
instmap_delta_from_assoc_list(
[TypeInfoVar - bound(unique, [functor(InstConsId, ArgInsts)])],
InstMapDelta),
@@ -2914,26 +2973,8 @@
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) :-
-
+polymorphism__init_const_type_ctor_info_var(Type, TypeCtor, TypeCtorInfoVar,
+ TypeCtorInfoGoal, ModuleInfo, !VarSet, !VarTypes) :-
type_util__type_ctor_module(ModuleInfo, TypeCtor, ModuleName),
type_util__type_ctor_name(ModuleInfo, TypeCtor, TypeName),
TypeCtor = _ - Arity,
@@ -2941,14 +2982,12 @@
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, !VarSet, !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, no),
UnifyMode = (free -> ground(shared, none)) -
(ground(shared, none) -> ground(shared, none)),
UnifyContext = unify_context(explicit, []),
@@ -2973,8 +3012,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) },
@@ -2987,31 +3025,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.
@@ -3026,9 +3066,8 @@
% Generate code to get the value of a type variable.
-:- pred get_type_info(type_info_locn, tvar, list(hlds_goal),
- prog_var, poly_info, poly_info).
-:- mode get_type_info(in, in, out, out, in, out) is det.
+:- pred get_type_info(type_info_locn::in, tvar::in, list(hlds_goal)::out,
+ prog_var::out, poly_info::in, poly_info::out) is det.
get_type_info(TypeInfoLocn, TypeVar, ExtraGoals, Var, Info0, Info) :-
(
@@ -3067,9 +3106,8 @@
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", predicate,
@@ -3236,20 +3274,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.56
diff -u -b -r1.56 post_typecheck.m
--- compiler/post_typecheck.m 19 Sep 2003 11:10:04 -0000 1.56
+++ compiler/post_typecheck.m 21 Sep 2003 23:32:29 -0000
@@ -334,9 +334,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_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 30 Sep 2003 07:28:35 -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.
@@ -238,16 +257,23 @@
mercury_table_builtin_module(mercury_table_builtin_module).
mercury_profiling_builtin_module = unqualified("profiling_builtin").
mercury_profiling_builtin_module(mercury_profiling_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)
; mercury_private_builtin_module(Module)
; mercury_table_builtin_module(Module)
; mercury_profiling_builtin_module(Module)
+ ; mercury_term_size_prof_builtin_module(Module)
; aditi_private_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 22 Sep 2003 01:29:35 -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, 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, 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_key.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/rl_key.m,v
retrieving revision 1.14
diff -u -b -r1.14 rl_key.m
--- compiler/rl_key.m 27 May 2003 05:57:19 -0000 1.14
+++ compiler/rl_key.m 30 Sep 2003 08:08:03 -0000
@@ -131,9 +131,16 @@
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
+ % XXX The next four categories used to be part of the
+ % user_ctor_type category; we should think about whether
+ % they should be included here.
+ ; TypeCategory = type_ctor_info_type
+ ; TypeCategory = type_info_type
+ ; TypeCategory = typeclass_info_type
+ ; TypeCategory = base_typeclass_info_type
),
module_info_types(ModuleInfo, Types),
type_to_ctor_and_args(Type, TypeCtor, _),
Index: compiler/size_prof.m
===================================================================
RCS file: compiler/size_prof.m
diff -N compiler/size_prof.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ compiler/size_prof.m 23 Sep 2003 08:05:38 -0000
@@ -0,0 +1,1253 @@
+%-----------------------------------------------------------------------------%
+% Copyright (C) 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.
+%-----------------------------------------------------------------------------%
+%
+% File: size_prof.m
+% Author: zs.
+%
+% This module performs a source-to-source program transformation that
+% implements term size profiling. The objective of the transformation is
+% to make it possible to find out the size of every term in constant time,
+% i.e. *without* traversing the term. (If finding out the size of a term
+% required traversing the term, the cost of this traversal would dominate
+% the cost of most procedures that took that term as input, and thus the
+% traversal overhead would introduce a "noise" that would overwhelm the
+% "signal" that profiling is trying to measure.) We can thus match the time
+% taken by a procedure against the size of its inputs, and use curve-fitting
+% to find out its actual complexity. (The theoretical minimum and maxiumum
+% complexities of most real algorithms are so different that they are of no
+% use.)
+%
+% The obvious way to avoid the traversal overhead on size lookup is to
+% calculate the size when the term is being constructed, which requires
+% traversing it anyway. In term profiling grades, we reserve an extra word
+% at the start of every memory cell (with a few exceptions explained below)
+% that stores the size of the whole term the memory cell is the top of.
+% The size is defined as the memory words in the term or the number of memory
+% cells in the term, depending on the grade.
+%
+% The main job of this module is to annotate every construction unification
+% with the information that the code generator needs to fill in the term size
+% slot. In order to do this, it must be able to find out the sizes of the
+% arguments, which in turn requires knowing the arguments' types.
+% (Without type information, we cannot distinguish a pointer from an integer.)
+% Most of the code in this module is concerned with adding code to the
+% procedure being transformed to find or construct the typeinfos we need
+% in order to find out the sizes of subterms. mainly because we want to
+% minimize the number of goals that construct typeinfos that we add to the
+% procedure body.
+%
+% A minor job of this transformation is to look for places where the procedure
+% fills in a previously undefined field in a cell, and to add code at those
+% places to destructively increment the size slot of the cell by the size of
+% the newly added subterm.
+%
+% In theory, when this happens, we should also increase the sizes of
+% all the terms containing the term that had one or more of its fields
+% instantiated. We do not do so, because doing that would require
+% a lot more machinery. However, given our lack of support for partially
+% instantiated data structures, and the fact that the correctness of the
+% program does not in fact require term sizes to be computed accurately,
+% the problem this poses can be safely ignored.
+%
+% The transformation we perform is not optimal: for example, if two branches
+% of a switch bind a variable to terms of the same size, we don't exploit
+% this fact. The transformation tries to get all the "low-hanging fruit";
+% we will go afer higher hanging fruit if and when a performance evaluation
+% says we need to.
+%
+% We do not associate sizes with the memory cells of a small set of types,
+% including type_infos, type_class_infos, closures and boxed floats.
+% The two reasons for this are that (1) the sizes of values of these types
+% practically never control the complexity of a procedure, so there is no
+% need for their sizes, and (2) this allows us to create e.g. static type_info
+% structures without worrying about term size slots. The set of type categories
+% whose values are always considered zero sized is defined by the predicate
+% zero_size_type in term_util.m.
+%
+% We currently do not associate sizes with data types which are handled mostly
+% by hand-written C code in the runtime system or in the standard library:
+% strings, arrays, higher-order values and foreign types. Keeping their sizes
+% would require a lot of extra work and (in the case of foreign types)
+% cooperation from the programmer. In the case of arrays, their destructive
+% updates also pose the same problems with respect to the propagation of size
+% changes as the instantiation of free variables in cells. Maintaining sizes
+% for strings and arrays would be desirable, since real programs do contain
+% predicates whose complexity is governed by the length of an array or a
+% string, but this remains future work.
+%
+%-----------------------------------------------------------------------------%
+
+:- module transform_hlds__size_prof.
+
+:- interface.
+
+:- import_module hlds__hlds_module.
+:- import_module hlds__hlds_pred.
+
+:- import_module io.
+
+% Specifies how term sizes are to be measured.
+:- type construct_transform
+ ---> term_words
+ ; term_cells.
+
+% Perform the transformation on the specified predicate.
+:- pred process_proc_msg(construct_transform::in, pred_id::in, proc_id::in,
+ proc_info::in, proc_info::out, module_info::in, module_info::out,
+ io__state::di, io__state::uo) is det.
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+:- implementation.
+
+:- import_module check_hlds__inst_match.
+:- import_module check_hlds__polymorphism.
+:- import_module check_hlds__simplify.
+:- import_module check_hlds__type_util.
+:- import_module hlds__goal_util.
+:- import_module hlds__hlds_data.
+:- import_module hlds__hlds_goal.
+:- import_module hlds__hlds_out.
+:- import_module hlds__quantification.
+:- import_module libs__globals.
+:- import_module libs__options.
+:- import_module check_hlds__mode_util.
+:- import_module parse_tree__inst.
+:- import_module parse_tree__prog_data.
+:- import_module parse_tree__prog_util.
+:- import_module transform_hlds__term_util.
+
+:- import_module bool, int, string, list, assoc_list, map, set, std_util.
+:- import_module varset, term, require.
+
+%-----------------------------------------------------------------------------%
+
+% The transformation maintains several maps that allows it to minimize
+% the number of constructions of typeinfos it needs to add to the procedure
+% body.
+%
+% If there is a variable live at the current program point that already
+% contains a type_info for a given type, then the type_info_map will record
+% its identity. The type_ctor_map does likewise for variables that contain
+% the type_ctor_infos of type constructors. However, we treat type_ctor_map
+% differently from type_info_maps, because the tradeoff are different.
+% Creating a new type_ctor_info reference is cheap: just return a pointer
+% to static compiler-generated data structure. Creating a new type_info isn't
+% cheap: it requires memory allocation. This is why in some places (calls, ends
+% of branched control structures) we simply clean out the type_ctor_map:
+% it is cheaper to recreate a type_ctor_info than to store it or move it
+% around.
+%
+% The rev_type_info_map and rev_type_ctor_map contain the same information
+% as type_info_map and type_ctor_map respectively, only indexed by the
+% program variable, not by the type or type constructor.
+%
+% If each arm of a branched control structure creates a type_info for a given
+% type but make different variables hold this type_info, then the code after
+% the branched control structure, not knowing which branch was taken, cannot
+% look up the type_info in any one of these variables, and is instead forced
+% to allocate that same type_info anew. The purpose of the target_type_info_map
+% is to minimize the number of places where we have to do this. If an earlier
+% branch has put the typeinfo for a given type into a given variable, then we
+% record this fact in the target_type_info_map, so that when a later branch
+% needs a type_info for the same type, it will put it into the same variable.
+% Of course, this pays off only if all branches allocate a type_info for the
+% type, but this does happen reasonably often. When it doesn't, the variable
+% that two or more branches use to store the type_into may need to be named
+% apart, which is why we invoke quantification after our transformation is
+% finished.
+%
+% It is of course better to find out the sizes of terms at compile time
+% than at runtime. The known_size_map maps each variable whose size is known
+% to its size.
+%
+% The varset and vartypes fields come from the proc_info of the procedure being
+% transformed, and their modified versions (updated when the transformation
+% creates new variables) are put back into the procedure's new proc_info.
+%
+% The construct_transform field specifies how term sizes are to be measured.
+%
+% The type_info_varmap specifies which program variables hold the type_infos
+% of which type variables.
+%
+% The module_info is needed by some utility predicates called by the
+% transformation.
+
+:- type type_info_map == map(type, prog_var).
+:- type type_ctor_map == map(type_ctor, prog_var).
+:- type rev_type_info_map == map(prog_var, type).
+:- type rev_type_ctor_map == map(prog_var, type_ctor).
+:- type known_size_map == map(prog_var, int).
+
+:- type size_prof__info --->
+ size_prof_info(
+ type_ctor_map :: type_ctor_map,
+ type_info_map :: type_info_map,
+ rev_type_ctor_map :: rev_type_ctor_map,
+ rev_type_info_map :: rev_type_info_map,
+ target_type_info_map :: type_info_map,
+ known_size_map :: known_size_map,
+ varset :: prog_varset,
+ vartypes :: vartypes,
+ transform_op :: construct_transform,
+ type_info_varmap :: type_info_varmap,
+ module_info :: module_info
+ ).
+
+process_proc_msg(Transform, PredId, ProcId, ProcInfo0, ProcInfo,
+ ModuleInfo0, ModuleInfo, !IO) :-
+ globals__io_lookup_bool_option(very_verbose, VeryVerbose, !IO),
+ ( VeryVerbose = yes ->
+ io__write_string("% Adding typeinfos in ", !IO),
+ hlds_out__write_pred_proc_id(ModuleInfo0, PredId, ProcId, !IO),
+ io__write_string(": ", !IO),
+ process_proc(Transform, PredId, ProcId, ProcInfo0, ProcInfo,
+ ModuleInfo0, ModuleInfo),
+ io__write_string("done.\n", !IO)
+ ;
+ process_proc(Transform, PredId, ProcId, ProcInfo0, ProcInfo,
+ ModuleInfo0, ModuleInfo)
+ ).
+
+:- pred process_proc(construct_transform::in, pred_id::in, proc_id::in,
+ proc_info::in, proc_info::out, module_info::in, module_info::out)
+ is det.
+
+process_proc(Transform, PredId, ProcId, !ProcInfo, !ModuleInfo) :-
+ Simplifications = [],
+ simplify__proc_2(Simplifications, PredId, ProcId, !ModuleInfo,
+ !ProcInfo, _Msgs),
+
+ proc_info_goal(!.ProcInfo, Goal0),
+ proc_info_varset(!.ProcInfo, VarSet0),
+ proc_info_vartypes(!.ProcInfo, VarTypes0),
+ proc_info_get_initial_instmap(!.ProcInfo, !.ModuleInfo, InstMap0),
+ proc_info_typeinfo_varmap(!.ProcInfo, TypeInfoVarmap),
+ % The with_types are needed to avoid a combinatorial explosion
+ % of ambiguity in the type checker.
+ TypeCtorMap0 = map__init `with_type` type_ctor_map,
+ TypeInfoMap0 = map__init `with_type` type_info_map,
+ RevTypeCtorMap0 = map__init `with_type` rev_type_ctor_map,
+ RevTypeInfoMap0 = map__init `with_type` rev_type_info_map,
+ TargetTypeInfoMap0 = map__init `with_type` type_info_map,
+ KnownSizeMap0 = map__init `with_type` known_size_map,
+ Info0 = size_prof_info(TypeCtorMap0, TypeInfoMap0,
+ RevTypeCtorMap0, RevTypeInfoMap0, TargetTypeInfoMap0,
+ KnownSizeMap0, VarSet0, VarTypes0, Transform, TypeInfoVarmap,
+ !.ModuleInfo),
+ map__to_assoc_list(TypeInfoVarmap, TypeInfoVarAssocList),
+ list__foldl(record_typeinfo_in_type_info_varmap, TypeInfoVarAssocList,
+ Info0, Info1),
+ process_goal(Goal0, Goal1, Info1, Info),
+
+ % We need to fix up goal_infos by recalculating
+ % the nonlocal vars and the non-atomic instmap deltas.
+ proc_info_headvars(!.ProcInfo, HeadVars),
+ proc_info_inst_varset(!.ProcInfo, InstVarSet),
+ implicitly_quantify_clause_body(HeadVars,
+ Goal1, Info ^ varset, Info ^ vartypes,
+ Goal2, VarSet, VarTypes, _Warnings),
+ recompute_instmap_delta(no, Goal2, Goal, VarTypes, InstVarSet,
+ InstMap0, !ModuleInfo),
+ proc_info_set_goal(!.ProcInfo, Goal, !:ProcInfo),
+ proc_info_set_varset(!.ProcInfo, VarSet, !:ProcInfo),
+ proc_info_set_vartypes(!.ProcInfo, VarTypes, !:ProcInfo).
+
+:- pred process_goal(hlds_goal::in, hlds_goal::out, info::in, info::out)
+ is det.
+
+process_goal(Goal0, Goal, !Info) :-
+ Goal0 = GoalExpr0 - GoalInfo0,
+ (
+ GoalExpr0 = unify(LHS, RHS, UniMode, Unify0, UnifyContext),
+ (
+ Unify0 = construct(Var, ConsId, Args, ArgModes, How,
+ Unique, _)
+ ->
+ process_construct(LHS, RHS, UniMode, UnifyContext,
+ Var, ConsId, Args, ArgModes, How, Unique,
+ GoalInfo0, GoalExpr, !Info)
+ ;
+ Unify0 = deconstruct(Var, ConsId, Args, ArgModes,
+ _CanFail, _CanCGC),
+ % The following test is an optimization. If
+ % BindingArgModes = [], which is almost 100% likely,
+ % then process_deconstruct would return GoalExpr0 as
+ % GoalExpr anyway, but would take longer.
+ list__filter(binds_arg_in_cell(!.Info), ArgModes,
+ BindingArgModes),
+ BindingArgModes \= []
+ ->
+ process_deconstruct(Var, ConsId, Args, ArgModes,
+ Goal0, GoalExpr, !Info)
+ ;
+ GoalExpr = GoalExpr0
+ )
+ ;
+ GoalExpr0 = call(_, _, _, _, _, _),
+ % We don't want to save type_ctor_info variables across calls,
+ % because saving/restoring them is more expensive than defining
+ % them again.
+ !:Info = !.Info ^ type_ctor_map := map__init,
+ GoalExpr = GoalExpr0
+ ;
+ GoalExpr0 = generic_call(_, _, _, _),
+ % We don't want to save type_ctor_info variables across calls,
+ % because saving/restoring them is more expensive than defining
+ % them again.
+ !:Info = !.Info ^ type_ctor_map := map__init,
+ GoalExpr = GoalExpr0
+ ;
+ GoalExpr0 = foreign_proc(_, _, _, _, _, _, _),
+ GoalExpr = GoalExpr0
+ ;
+ GoalExpr0 = conj(Goals0),
+ process_conj(Goals0, Goals, !Info),
+ GoalExpr = conj(Goals)
+ ;
+ GoalExpr0 = par_conj(Goals0),
+ % This transformation produces code that is much less than
+ % optimal. However, it ought to be more robust than any better
+ % transformation, and there is no point in spending time on a
+ % better transformation while parallel conjunctions are rare.
+ TargetTypeInfoMap0 = !.Info ^ target_type_info_map,
+ TypeInfoMap0 = !.Info ^ type_info_map,
+ TypeCtorMap0 = !.Info ^ type_ctor_map,
+ KnownSizeMap0 = !.Info ^ known_size_map,
+ process_par_conj(Goals0, Goals, !Info,
+ TargetTypeInfoMap0, TypeInfoMap0, TypeCtorMap0,
+ KnownSizeMap0),
+ !:Info = !.Info ^ target_type_info_map := TargetTypeInfoMap0,
+ !:Info = !.Info ^ type_info_map := TypeInfoMap0,
+ !:Info = !.Info ^ type_ctor_map := map__init,
+ !:Info = !.Info ^ known_size_map := KnownSizeMap0,
+ GoalExpr = par_conj(Goals)
+ ;
+ GoalExpr0 = switch(SwitchVar, CanFail, Cases0),
+ (
+ Cases0 = [First0 | Later0],
+ TargetTypeInfoMap0 = !.Info ^ target_type_info_map,
+ TypeInfoMap0 = !.Info ^ type_info_map,
+ TypeCtorMap0 = !.Info ^ type_ctor_map,
+ KnownSizeMap0 = !.Info ^ known_size_map,
+ process_switch(First0, First, Later0, Later, !Info,
+ TargetTypeInfoMap0, TypeInfoMap0, TypeCtorMap0,
+ KnownSizeMap0, TypeInfoMap, KnownSizeMap),
+ !:Info = !.Info ^ type_info_map := TypeInfoMap,
+ !:Info = !.Info ^ type_ctor_map := map__init,
+ !:Info = !.Info ^ known_size_map := KnownSizeMap,
+ Cases = [First | Later]
+ ;
+ Cases0 = [],
+ error("size_prof__process_goal: empty switch")
+ ),
+ update_rev_maps(!Info),
+ update_target_map(!Info),
+ GoalExpr = switch(SwitchVar, CanFail, Cases)
+ ;
+ GoalExpr0 = disj(Disjuncts0),
+ (
+ Disjuncts0 = [First0 | Later0],
+ TargetTypeInfoMap0 = !.Info ^ target_type_info_map,
+ TypeInfoMap0 = !.Info ^ type_info_map,
+ TypeCtorMap0 = !.Info ^ type_ctor_map,
+ KnownSizeMap0 = !.Info ^ known_size_map,
+ process_disj(First0, First, Later0, Later, !Info,
+ TargetTypeInfoMap0, TypeInfoMap0, TypeCtorMap0,
+ KnownSizeMap0, TypeInfoMap, KnownSizeMap),
+ !:Info = !.Info ^ type_info_map := TypeInfoMap,
+ !:Info = !.Info ^ type_ctor_map := map__init,
+ !:Info = !.Info ^ known_size_map := KnownSizeMap,
+ Disjuncts = [First | Later]
+ ;
+ Disjuncts0 = [],
+ % An empty disj represents `fail'.
+ !:Info = !.Info ^ type_info_map := map__init,
+ !:Info = !.Info ^ type_ctor_map := map__init,
+ Disjuncts = []
+ ),
+ update_rev_maps(!Info),
+ update_target_map(!Info),
+ GoalExpr = disj(Disjuncts)
+ ;
+ GoalExpr0 = if_then_else(Quant, Cond0, Then0, Else0),
+ TargetTypeInfoMap0 = !.Info ^ target_type_info_map,
+ TypeInfoMap0 = !.Info ^ type_info_map,
+ TypeCtorMap0 = !.Info ^ type_ctor_map,
+ KnownSizeMap0 = !.Info ^ known_size_map,
+
+ !:Info = !.Info ^ target_type_info_map := map__init,
+ process_goal(Cond0, Cond, !Info),
+ !:Info = !.Info ^ target_type_info_map := TargetTypeInfoMap0,
+ process_goal(Then0, Then, !Info),
+ TargetTypeInfoMapThen = !.Info ^ target_type_info_map,
+ TypeInfoMapThen = !.Info ^ type_info_map,
+ KnownSizeMapThen = !.Info ^ known_size_map,
+
+ map__det_union(insist_on_same, TargetTypeInfoMapThen,
+ TargetTypeInfoMap0, ElseTargetTypeInfoMap),
+ !:Info = !.Info ^ target_type_info_map :=
+ ElseTargetTypeInfoMap,
+ !:Info = !.Info ^ type_info_map := TypeInfoMap0,
+ !:Info = !.Info ^ type_ctor_map := TypeCtorMap0,
+ !:Info = !.Info ^ known_size_map := KnownSizeMap0,
+ process_goal(Else0, Else, !Info),
+ TypeInfoMapElse = !.Info ^ type_info_map,
+ KnownSizeMapElse = !.Info ^ known_size_map,
+
+ TypeInfoMap = map__common_subset(TypeInfoMapThen,
+ TypeInfoMapElse),
+ KnownSizeMap = map__common_subset(KnownSizeMapThen,
+ KnownSizeMapElse),
+ !:Info = !.Info ^ type_info_map := TypeInfoMap,
+ !:Info = !.Info ^ type_ctor_map := map__init,
+ !:Info = !.Info ^ known_size_map := KnownSizeMap,
+ update_rev_maps(!Info),
+ update_target_map(!Info),
+ GoalExpr = if_then_else(Quant, Cond, Then, Else)
+ ;
+ GoalExpr0 = not(NegGoal0),
+ TargetTypeInfoMap0 = !.Info ^ target_type_info_map,
+ TypeInfoMap0 = !.Info ^ type_info_map,
+ TypeCtorMap0 = !.Info ^ type_ctor_map,
+ KnownSizeMap0 = !.Info ^ known_size_map,
+ process_goal(NegGoal0, NegGoal, !Info),
+ % Variables constructed in negated goals are not available
+ % after the negated goal fails and the negation succeeds.
+ % The sizes we learn in NegGoal0 don't apply after NegGoal0
+ % fails.
+ !:Info = !.Info ^ target_type_info_map := TargetTypeInfoMap0,
+ !:Info = !.Info ^ type_info_map := TypeInfoMap0,
+ !:Info = !.Info ^ type_ctor_map := TypeCtorMap0,
+ !:Info = !.Info ^ known_size_map := KnownSizeMap0,
+ GoalExpr = not(NegGoal)
+ ;
+ GoalExpr0 = some(Vars, CanRemove, SomeGoal0),
+ process_goal(SomeGoal0, SomeGoal, !Info),
+ GoalExpr = some(Vars, CanRemove, SomeGoal)
+ ;
+ GoalExpr0 = shorthand(_),
+ error("size_prof__process_goal: shorthand")
+ ),
+ Goal = GoalExpr - GoalInfo0.
+
+%---------------------------------------------------------------------------%
+
+:- pred process_conj(list(hlds_goal)::in, list(hlds_goal)::out,
+ info::in, info::out) is det.
+
+process_conj([], [], !Info).
+process_conj([Goal0 | Goals0], Conj, !Info) :-
+ process_goal(Goal0, Goal, !Info),
+ process_conj(Goals0, Goals, !Info),
+ ( Goal = conj(SubConj) - _ ->
+ % Flatten out any conjunction introduced by process_goal.
+ % We never create conjunctions more than one level deep,
+ % so this single test is sufficient to ensure that we never
+ % leave conjunctions nested more deeply than the input goal.
+ Conj = list__append(SubConj, Goals)
+ ;
+ Conj = [Goal | Goals]
+ ).
+
+%---------------------------------------------------------------------------%
+
+:- pred process_par_conj(list(hlds_goal)::in, list(hlds_goal)::out,
+ info::in, info::out, type_info_map::in, type_info_map::in,
+ type_ctor_map::in, known_size_map::in) is det.
+
+process_par_conj([], [], !Info, _, _, _, _).
+process_par_conj([Goal0 | Goals0], [Goal | Goals], !Info, TargetTypeInfoMap0,
+ TypeInfoMap0, TypeCtorMap0, KnownSizeMap0) :-
+ !:Info = !.Info ^ target_type_info_map := TargetTypeInfoMap0,
+ !:Info = !.Info ^ type_info_map := TypeInfoMap0,
+ !:Info = !.Info ^ type_ctor_map := TypeCtorMap0,
+ !:Info = !.Info ^ known_size_map := KnownSizeMap0,
+ process_goal(Goal0, Goal, !Info),
+ process_par_conj(Goals0, Goals, !Info, TargetTypeInfoMap0,
+ TypeInfoMap0, TypeCtorMap0, KnownSizeMap0).
+
+%---------------------------------------------------------------------------%
+
+:- pred process_disj(hlds_goal::in, hlds_goal::out,
+ list(hlds_goal)::in, list(hlds_goal)::out, info::in, info::out,
+ type_info_map::in, type_info_map::in, type_ctor_map::in,
+ known_size_map::in, type_info_map::out, known_size_map::out) is det.
+
+process_disj(First0, First, Later0, Later, !Info, TargetTypeInfoMap,
+ TypeInfoMap0, TypeCtorMap0, KnownSizeMap0,
+ TypeInfoMap, KnownSizeMap) :-
+ !:Info = !.Info ^ type_info_map := TypeInfoMap0,
+ !:Info = !.Info ^ type_ctor_map := TypeCtorMap0,
+ !:Info = !.Info ^ known_size_map := KnownSizeMap0,
+ process_goal(First0, First, !Info),
+ TypeInfoMapFirst = !.Info ^ type_info_map,
+ KnownSizeMapFirst = !.Info ^ known_size_map,
+ (
+ Later0 = [Head0 | Tail0],
+ map__det_union(insist_on_same, TypeInfoMapFirst,
+ TargetTypeInfoMap, LaterTargetTypeInfoMap),
+ !:Info = !.Info ^ target_type_info_map :=
+ LaterTargetTypeInfoMap,
+ process_disj(Head0, Head, Tail0, Tail, !Info,
+ TargetTypeInfoMap, TypeInfoMap0, TypeCtorMap0,
+ KnownSizeMap0, TypeInfoMapLater, KnownSizeMapLater),
+ TypeInfoMap = map__common_subset(TypeInfoMapFirst,
+ TypeInfoMapLater),
+ KnownSizeMap = map__common_subset(KnownSizeMapFirst,
+ KnownSizeMapLater),
+ Later = [Head | Tail]
+ ;
+ Later0 = [],
+ Later = [],
+ TypeInfoMap = TypeInfoMapFirst,
+ KnownSizeMap = KnownSizeMapFirst
+ ).
+
+%---------------------------------------------------------------------------%
+
+:- pred process_switch(case::in, case::out,
+ list(case)::in, list(case)::out, info::in, info::out,
+ type_info_map::in, type_info_map::in, type_ctor_map::in,
+ known_size_map::in, type_info_map::out, known_size_map::out) is det.
+
+process_switch(First0, First, Later0, Later, !Info, TargetTypeInfoMap,
+ TypeInfoMap0, TypeCtorMap0, KnownSizeMap0,
+ TypeInfoMap, KnownSizeMap) :-
+ !:Info = !.Info ^ type_info_map := TypeInfoMap0,
+ !:Info = !.Info ^ type_ctor_map := TypeCtorMap0,
+ !:Info = !.Info ^ known_size_map := KnownSizeMap0,
+ First0 = case(FirstConsId, FirstGoal0),
+ process_goal(FirstGoal0, FirstGoal, !Info),
+ TypeInfoMapFirst = !.Info ^ type_info_map,
+ KnownSizeMapFirst = !.Info ^ known_size_map,
+ First = case(FirstConsId, FirstGoal),
+ (
+ Later0 = [Head0 | Tail0],
+ map__det_union(insist_on_same, TypeInfoMapFirst,
+ TargetTypeInfoMap, LaterTargetTypeInfoMap),
+ !:Info = !.Info ^ target_type_info_map :=
+ LaterTargetTypeInfoMap,
+ process_switch(Head0, Head, Tail0, Tail, !Info,
+ TargetTypeInfoMap, TypeInfoMap0, TypeCtorMap0,
+ KnownSizeMap0, TypeInfoMapLater, KnownSizeMapLater),
+ TypeInfoMap = map__common_subset(TypeInfoMapFirst,
+ TypeInfoMapLater),
+ KnownSizeMap = map__common_subset(KnownSizeMapFirst,
+ KnownSizeMapLater),
+ Later = [Head | Tail]
+ ;
+ Later0 = [],
+ Later = [],
+ TypeInfoMap = TypeInfoMapFirst,
+ KnownSizeMap = KnownSizeMapFirst
+ ).
+
+%---------------------------------------------------------------------------%
+
+:- pred process_construct(prog_var::in, unify_rhs::in, unify_mode::in,
+ unify_context::in, prog_var::in, cons_id::in, list(prog_var)::in,
+ list(uni_mode)::in, how_to_construct::in, cell_is_unique::in,
+ hlds_goal_info::in, hlds_goal_expr::out, info::in, info::out) is det.
+
+process_construct(LHS, RHS, UniMode, UnifyContext, Var, ConsId, Args, ArgModes,
+ How, Unique, GoalInfo, GoalExpr, !Info) :-
+ map__lookup(!.Info ^ vartypes, Var, VarType),
+ ( type_to_ctor_and_args(VarType, VarTypeCtorPrime, _VarTypeArgs) ->
+ VarTypeCtor = VarTypeCtorPrime
+ ;
+ error("size_prof__process_construct: "
+ ++ "constructing term of variable type")
+ ),
+ type_ctor_module(!.Info ^ module_info, VarTypeCtor, VarTypeCtorModule),
+ type_ctor_name(!.Info ^ module_info, VarTypeCtor, VarTypeCtorName),
+ (
+ ctor_is_type_info_related(VarTypeCtorModule, VarTypeCtorName)
+ ->
+ ( VarTypeCtorName = "type_info" ->
+ (
+ ConsId = type_info_cell_constructor,
+ Args = [TypeCtorInfoVar | ArgTypeInfoVars]
+ ->
+ record_known_type_info(Var, TypeCtorInfoVar,
+ ArgTypeInfoVars, !Info)
+ ;
+ ConsId = type_ctor_info_const(M, N, A)
+ ->
+ % When type specialization creates a procedure
+ % with a type substitution such as K=int, it
+ % leaves the type of TypeInfo_for_K as
+ % type_info, not type_ctor_info.
+ record_known_type_ctor_info(Var, M, N, A, !Info)
+ ;
+ error("size_prof__process_construct: "
+ ++ "bad type_info")
+ )
+ ; VarTypeCtorName = "type_ctor_info" ->
+ ( ConsId = type_ctor_info_const(M, N, A) ->
+ record_known_type_ctor_info(Var, M, N, A, !Info)
+ ;
+ error("size_prof__process_construct: "
+ ++ "bad type_ctor_info")
+ )
+ ;
+ !:Info = !.Info
+ ),
+ Unification = construct(Var, ConsId, Args, ArgModes,
+ How, Unique, no),
+ GoalExpr = unify(LHS, RHS, UniMode, Unification, UnifyContext)
+ ;
+ ConsId = cons(_Name, _Arity),
+ Args \= []
+ ->
+ process_cons_construct(LHS, RHS, UniMode, UnifyContext,
+ Var, VarType, ConsId, Args, ArgModes, How,
+ Unique, GoalInfo, GoalExpr, !Info)
+ ;
+ % All ConsIds other than cons/2 with at least one argument
+ % construct terms that we consider zero-sized.
+ record_known_size(Var, 0, !Info),
+ Unification = construct(Var, ConsId, Args, ArgModes,
+ How, Unique, no),
+ GoalExpr = unify(LHS, RHS, UniMode, Unification, UnifyContext)
+ ).
+
+%-----------------------------------------------------------------------------%
+
+:- pred process_deconstruct(prog_var::in, cons_id::in, list(prog_var)::in,
+ list(uni_mode)::in, hlds_goal::in, hlds_goal_expr::out,
+ info::in, info::out) is det.
+
+process_deconstruct(Var, ConsId, Args, ArgModes, Goal0, GoalExpr, !Info) :-
+ map__lookup(!.Info ^ vartypes, Var, VarType),
+ ( type_to_ctor_and_args(VarType, VarTypeCtorPrime, _VarTypeArgs) ->
+ VarTypeCtor = VarTypeCtorPrime
+ ;
+ error("size_prof__process_deconstruct: "
+ ++ "deconstructing term of variable type")
+ ),
+ type_ctor_module(!.Info ^ module_info, VarTypeCtor, VarTypeCtorModule),
+ type_ctor_name(!.Info ^ module_info, VarTypeCtor, VarTypeCtorName),
+ (
+ ctor_is_type_info_related(VarTypeCtorModule, VarTypeCtorName)
+ ->
+ Goal0 = GoalExpr - _
+ ;
+ ConsId = cons(_Name, _Arity),
+ Args \= []
+ ->
+ process_cons_deconstruct(Var, Args, ArgModes,
+ Goal0, GoalExpr, !Info)
+ ;
+ % All ConsIds other than cons/2 deconstruct terms that we
+ % consider zero-sized.
+ record_known_size(Var, 0, !Info),
+ Goal0 = GoalExpr - _
+ ).
+
+%-----------------------------------------------------------------------------%
+
+:- pred process_cons_construct(prog_var::in, unify_rhs::in, unify_mode::in,
+ unify_context::in, prog_var::in, (type)::in, cons_id::in,
+ list(prog_var)::in, list(uni_mode)::in, how_to_construct::in,
+ cell_is_unique::in, hlds_goal_info::in, hlds_goal_expr::out,
+ info::in, info::out) is det.
+
+process_cons_construct(LHS, RHS, UniMode, UnifyContext, Var, _Type, ConsId,
+ Args, ArgModes, How, Unique, GoalInfo0, GoalExpr, !Info) :-
+ FunctorSize = compute_functor_size(Args, !.Info),
+ find_defined_args(Args, ArgModes, DefinedArgs, NonDefinedArgs, !.Info),
+ goal_info_get_context(GoalInfo0, Context),
+ process_args(DefinedArgs, FunctorSize, KnownSize,
+ no, MaybeDynamicSizeVar, Context, ArgGoals, !Info),
+ (
+ MaybeDynamicSizeVar = no,
+ require(unify(ArgGoals, []),
+ "process_cons_construct: nonempty ArgGoals"),
+ ( NonDefinedArgs = [] ->
+ record_known_size(Var, KnownSize, !Info)
+ ;
+ % The size of the term may change as some of its
+ % currently free arguments become bound.
+ true
+ ),
+ Unification = construct(Var, ConsId, Args, ArgModes,
+ How, Unique, yes(known_size(KnownSize))),
+ GoalExpr = unify(LHS, RHS, UniMode, Unification, UnifyContext)
+ ;
+ MaybeDynamicSizeVar = yes(SizeVar0),
+ generate_size_var(SizeVar0, KnownSize, Context,
+ SizeVar, SizeGoals, !Info),
+ Unification = construct(Var, ConsId, Args, ArgModes,
+ How, Unique, yes(dynamic_size(SizeVar))),
+ UnifyExpr = unify(LHS, RHS, UniMode, Unification,
+ UnifyContext),
+ goal_info_get_nonlocals(GoalInfo0, NonLocals0),
+ set__insert(NonLocals0, SizeVar, NonLocals),
+ goal_info_set_nonlocals(GoalInfo0, NonLocals, GoalInfo),
+ UnifyGoal = UnifyExpr - GoalInfo,
+ Goals = list__condense([ArgGoals, SizeGoals, [UnifyGoal]]),
+ GoalExpr = conj(Goals)
+ ).
+
+%-----------------------------------------------------------------------------%
+
+:- pred process_cons_deconstruct(prog_var::in, list(prog_var)::in,
+ list(uni_mode)::in, hlds_goal::in, hlds_goal_expr::out,
+ info::in, info::out) is det.
+
+process_cons_deconstruct(Var, Args, ArgModes, UnifyGoal, GoalExpr, !Info) :-
+ find_defined_args(Args, ArgModes, DefinedArgs, _NonDefArgs, !.Info),
+ UnifyGoal = GoalExpr0 - GoalInfo0,
+ goal_info_get_context(GoalInfo0, Context),
+ process_args(DefinedArgs, 0, KnownSize,
+ no, MaybeDynamicSizeVar, Context, ArgGoals, !Info),
+ (
+ MaybeDynamicSizeVar = no,
+ require(unify(ArgGoals, []),
+ "process_cons_deconstruct: nonempty ArgGoals"),
+ GoalExpr = GoalExpr0
+ ;
+ MaybeDynamicSizeVar = yes(SizeVar0),
+ generate_size_var(SizeVar0, KnownSize, Context,
+ SizeVar, SizeGoals, !Info),
+ % The increment_size primitive doesn't actually use the
+ % type_info passed to it, so give it the cheapest type_info
+ % we can build, which is a zero-arity type_ctor_info such as
+ % that of void.
+ make_type_info(Context, void_type, TypeInfoVar,
+ TypeInfoGoals, !Info),
+ TermSizeProfBuiltin = mercury_term_size_prof_builtin_module,
+ goal_util__generate_simple_call(TermSizeProfBuiltin,
+ "increment_size", predicate,
+ [TypeInfoVar, Var, SizeVar], only_mode, det,
+ yes(impure), [], !.Info ^ module_info,
+ Context, UpdateGoal),
+ % Put UnifyGoal first in case it fails.
+ Goals = list__condense([[UnifyGoal], ArgGoals, SizeGoals,
+ TypeInfoGoals, [UpdateGoal]]),
+ GoalExpr = conj(Goals)
+ ).
+
+%-----------------------------------------------------------------------------%
+
+% Process the variables representing the fields being bound in a memory cell,
+% computing the contribution they make to the increase in size of that cell.
+% The increase is in two parts: the statically known part, and the part that
+% can be known only at runtime. We record the former in the KnownSize
+% accumulator and the latter in the MaybeSizeVar accumulator. We allocate
+% a variable to hold the dynamically-computed part of the size only if the
+% sum of the arguments' sizes is not static. In that case, the Goals we return
+% will be nonempty.
+
+:- pred process_args(list(prog_var)::in, int::in, int::out,
+ maybe(prog_var)::in, maybe(prog_var)::out, prog_context::in,
+ list(hlds_goal)::out, info::in, info::out) is det.
+
+process_args([], !KnownSize, !MaybeSizeVar, _, [], !Info).
+process_args([Arg | Args], !KnownSize, !MaybeSizeVar, Context, Goals, !Info) :-
+ map__lookup(!.Info ^ vartypes, Arg, Type),
+ ( map__search(!.Info ^ known_size_map, Arg, ArgSize) ->
+ !:KnownSize = !.KnownSize + ArgSize,
+ ArgGoals = []
+ ; zero_size_type(Type, !.Info ^ module_info) ->
+ ArgGoals = []
+ ;
+ make_type_info(Context, Type, TypeInfoVar, TypeInfoGoals,
+ !Info),
+ make_size_goal(TypeInfoVar, Arg, Context, SizeGoal,
+ !MaybeSizeVar, !Info),
+ list__append(TypeInfoGoals, [SizeGoal], ArgGoals)
+ ),
+ process_args(Args, !KnownSize, !MaybeSizeVar, Context, LaterGoals,
+ !Info),
+ list__append(ArgGoals, LaterGoals, Goals).
+
+%-----------------------------------------------------------------------------%
+
+% Given that KnownSize is the static part of the sum of sizes of the fields
+% being defined and SizeVar0 is a variable containing the dynamic part,
+% return a variable SizeVar that contains their sum and the Goals needed to
+% compute it.
+
+:- pred generate_size_var(prog_var::in, int::in, prog_context::in,
+ prog_var::out, list(hlds_goal)::out, info::in, info::out) is det.
+
+generate_size_var(SizeVar0, KnownSize, Context, SizeVar, Goals, !Info) :-
+ ( KnownSize = 0 ->
+ SizeVar = SizeVar0,
+ Goals = []
+ ;
+ VarSet0 = !.Info ^ varset,
+ VarTypes0 = !.Info ^ vartypes,
+ make_int_const_construction(KnownSize,
+ yes("KnownSize"), KnownSizeGoal, KnownSizeVar,
+ VarTypes0, VarTypes1,
+ VarSet0, VarSet1),
+ !:Info = !.Info ^ varset := VarSet1,
+ !:Info = !.Info ^ vartypes := VarTypes1,
+ get_new_var(int_type, "FinalSizeVar", SizeVar, !Info),
+ TermSizeProfModule = mercury_term_size_prof_builtin_module,
+ goal_util__generate_simple_call(TermSizeProfModule,
+ "term_size_plus", function,
+ [SizeVar0, KnownSizeVar, SizeVar], mode_no(0), det, no,
+ [SizeVar - ground(shared, none)],
+ !.Info ^ module_info, Context, AddGoal),
+ Goals = [KnownSizeGoal, AddGoal]
+ ).
+
+%-----------------------------------------------------------------------------%
+
+% Create a type_info for a given type as cheaply as possible, with the
+% cheapest methods involving the reuse of existing type_infos and/or
+% type_ctor_infos. Return the variable holding the type_info in TypeInfoVar,
+% and the goals needed to create it in TypeInfoGoals.
+
+:- pred make_type_info(prog_context::in, (type)::in, prog_var::out,
+ list(hlds_goal)::out, info::in, info::out) is det.
+
+make_type_info(Context, Type, TypeInfoVar, TypeInfoGoals, !Info) :-
+ ( map__search(!.Info ^ type_info_map, Type, TypeInfoVarPrime) ->
+ TypeInfoVar = TypeInfoVarPrime,
+ TypeInfoGoals = []
+ ; type_has_variable_arity_ctor(Type, TypeCtor, ArgTypes) ->
+ construct_type_info(Context, Type, TypeCtor, ArgTypes, yes,
+ TypeInfoVar, TypeInfoGoals, !Info)
+ ; type_to_ctor_and_args(Type, TypeCtor, ArgTypes0) ->
+ canonicalize_type_args(TypeCtor, ArgTypes0, ArgTypes),
+ ( ArgTypes = [] ->
+ make_type_ctor_info(TypeCtor, TypeCtorVar,
+ TypeCtorGoals, !Info),
+ TypeInfoVar = TypeCtorVar,
+ TypeInfoGoals = TypeCtorGoals
+ ;
+ construct_type_info(Context, Type, TypeCtor, ArgTypes,
+ no, TypeInfoVar, TypeInfoGoals, !Info)
+ )
+ ; Type = term__variable(TVar) ->
+ map__lookup(!.Info ^ type_info_varmap, TVar, TVarLocn),
+ (
+ TVarLocn = type_info(TypeInfoVar),
+ TypeInfoGoals = []
+ ;
+ TVarLocn = typeclass_info(TypeClassInfoVar, Slot),
+ TargetTypeInfoMap = !.Info ^ target_type_info_map,
+ VarSet0 = !.Info ^ varset,
+ VarTypes0 = !.Info ^ vartypes,
+ ( map__search(TargetTypeInfoMap, Type, TargetVar) ->
+ TypeInfoVar = TargetVar,
+ VarSet1 = VarSet0,
+ VarTypes1 = VarTypes0
+ ;
+ polymorphism__new_type_info_var_raw(Type,
+ type_info, TypeInfoVar,
+ VarSet0, VarSet1, VarTypes0, VarTypes1)
+ ),
+ make_int_const_construction(Slot,
+ yes("TypeClassInfoSlot"), SlotGoal, SlotVar,
+ VarTypes1, VarTypes, VarSet1, VarSet),
+ !:Info = !.Info ^ varset := VarSet,
+ !:Info = !.Info ^ vartypes := VarTypes,
+ PrivateBuiltin = mercury_private_builtin_module,
+ goal_util__generate_simple_call(PrivateBuiltin,
+ "type_info_from_typeclass_info", predicate,
+ [TypeClassInfoVar, SlotVar, TypeInfoVar],
+ only_mode, det, no,
+ [TypeInfoVar - ground(shared, none)],
+ !.Info ^ module_info, Context, ExtractGoal),
+ record_type_info_var(Type, TypeInfoVar, !Info),
+ TypeInfoGoals = [SlotGoal, ExtractGoal]
+ )
+ ;
+ % type_to_ctor_and_args can fail only if Type is a type
+ % variable, or acts like one. The tests in our callers should
+ % have filtered out both cases.
+ error("size_prof__make_type_info: cannot happen")
+ ).
+
+% Construct a type_info for Type = TypeCtor(ArgTypes), given that we know
+% there is no variable that currently holds a type_info for Type. Return
+% the variable holding the type_info in TypeInfoVar, and the goals needed
+% to create it in TypeInfoGoals.
+
+:- pred construct_type_info(prog_context::in, (type)::in, type_ctor::in,
+ list(type)::in, bool::in, prog_var::out, list(hlds_goal)::out,
+ info::in, info::out) is det.
+
+construct_type_info(Context, Type, TypeCtor, ArgTypes, CtorIsVarArity,
+ TypeInfoVar, TypeInfoGoals, !Info) :-
+ list__map2_foldl(make_type_info(Context), ArgTypes,
+ ArgTypeInfoVars, ArgTypeInfoGoalLists, !Info),
+ ArgTypeInfoGoals = list__condense(ArgTypeInfoGoalLists),
+ make_type_ctor_info(TypeCtor, TypeCtorVar, TypeCtorGoals, !Info),
+ (
+ CtorIsVarArity = yes,
+ list__length(ArgTypes, Arity),
+ VarSet0 = !.Info ^ varset,
+ VarTypes0 = !.Info ^ vartypes,
+ make_int_const_construction(Arity, yes("TupleArity"),
+ ArityGoal, ArityVar, VarTypes0, VarTypes1,
+ VarSet0, VarSet1),
+ !:Info = !.Info ^ varset := VarSet1,
+ !:Info = !.Info ^ vartypes := VarTypes1,
+ FrontGoals = list__append(TypeCtorGoals, [ArityGoal]),
+ ArgVars = [TypeCtorVar, ArityVar | ArgTypeInfoVars]
+ ;
+ CtorIsVarArity = no,
+ FrontGoals = TypeCtorGoals,
+ ArgVars = [TypeCtorVar | ArgTypeInfoVars]
+ ),
+ VarSet2 = !.Info ^ varset,
+ VarTypes2 = !.Info ^ vartypes,
+ TargetTypeInfoMap = !.Info ^ target_type_info_map,
+ ( map__search(TargetTypeInfoMap, Type, PrefTIVar) ->
+ MaybePreferredVar = yes(PrefTIVar)
+ ;
+ MaybePreferredVar = no
+ ),
+ polymorphism__init_type_info_var(Type, ArgVars,
+ MaybePreferredVar, TypeInfoVar, TypeInfoGoal,
+ VarSet2, VarSet, VarTypes2, VarTypes),
+ !:Info = !.Info ^ varset := VarSet,
+ !:Info = !.Info ^ vartypes := VarTypes,
+ TypeInfoGoals = list__condense([ArgTypeInfoGoals, FrontGoals,
+ [TypeInfoGoal]]).
+
+% Create a type_ctor_info for a given type constructor as cheaply as possible,
+% with the cheapest method being the reuse of an existing type_ctor_info.
+% Return the variable holding the type_ctor_info in TypeCtorVar,
+% and the goals needed to create it in TypeCtorGoals.
+
+:- pred make_type_ctor_info(type_ctor::in, prog_var::out, list(hlds_goal)::out,
+ info::in, info::out) is det.
+
+make_type_ctor_info(TypeCtor, TypeCtorVar, TypeCtorGoals, !Info) :-
+ ( map__search(!.Info ^ type_ctor_map, TypeCtor, TypeCtorVarPrime) ->
+ TypeCtorVar = TypeCtorVarPrime,
+ TypeCtorGoals = []
+ ;
+ construct_type(TypeCtor, [], Type),
+ VarSet0 = !.Info ^ varset,
+ VarTypes0 = !.Info ^ vartypes,
+ polymorphism__init_const_type_ctor_info_var(Type, TypeCtor,
+ TypeCtorVar, TypeCtorGoal, !.Info ^ module_info,
+ VarSet0, VarSet, VarTypes0, VarTypes),
+ TypeCtorGoals = [TypeCtorGoal],
+ !:Info = !.Info ^ varset := VarSet,
+ !:Info = !.Info ^ vartypes := VarTypes
+ ).
+
+%-----------------------------------------------------------------------------%
+
+% Generate a goal that looks up the size of Arg at runtime, given that the
+% type_info of Arg's type is in TypeInfoVar.
+%
+% We ultimately always want to compute the sum of the sizes of the fields
+% being defined, so if we have previously looked up the sizes of other fields,
+% then combine the operation of looking up Arg's size with adding that size to
+% the sum of the (dynamic) sizes so far: measure_size_acc does both these
+% operations.
+
+:- pred make_size_goal(prog_var::in, prog_var::in, prog_context::in,
+ hlds_goal::out, maybe(prog_var)::in, maybe(prog_var)::out,
+ info::in, info::out) is det.
+
+make_size_goal(TypeInfoVar, Arg, Context, SizeGoal,
+ MaybeSizeVar0, MaybeSizeVar, !Info) :-
+ get_new_var(int_type, "SizeVar", SizeVar, !Info),
+ (
+ MaybeSizeVar0 = yes(SizeVar0),
+ Pred = "measure_size_acc",
+ Args = [TypeInfoVar, Arg, SizeVar0, SizeVar]
+ ;
+ MaybeSizeVar0 = no,
+ Pred = "measure_size",
+ Args = [TypeInfoVar, Arg, SizeVar]
+ ),
+ TermSizeProfBuiltin = mercury_term_size_prof_builtin_module,
+ goal_util__generate_simple_call(TermSizeProfBuiltin, Pred, predicate,
+ Args, only_mode, det, no, [SizeVar - ground(shared, none)],
+ !.Info ^ module_info, Context, SizeGoal),
+ MaybeSizeVar = yes(SizeVar).
+
+%---------------------------------------------------------------------------%
+
+% Create a new variable with a name constructed from Prefix and the variable
+% number.
+
+:- pred get_new_var((type)::in, string::in, prog_var::out,
+ info::in, info::out) is det.
+
+get_new_var(Type, Prefix, Var, !Info) :-
+ VarSet0 = !.Info ^ varset,
+ VarTypes0 = !.Info ^ vartypes,
+ varset__new_var(VarSet0, Var, VarSet1),
+ term__var_to_int(Var, VarNum),
+ string__int_to_string(VarNum, VarNumStr),
+ string__append(Prefix, VarNumStr, Name),
+ varset__name_var(VarSet1, Var, Name, VarSet),
+ map__set(VarTypes0, Var, Type, VarTypes),
+ !:Info = !.Info ^ varset := VarSet,
+ !:Info = !.Info ^ vartypes := VarTypes.
+
+%---------------------------------------------------------------------------%
+
+% These predicates record information about the procedure body (that was
+% either there originally or was made true by our transformation) for later
+% use in optimizating the transformation of the rest of the procedure body.
+%
+% The reason why the implementation uses map__set instead of map__det_insert
+% is that it is possible for Var to already exist in the maps. This can happen
+% e.g. when each branch of a branched structure generates a value of an
+% existential type, and thus also generates the type_info describing that type.
+% The first branch will insert the variable holding that type_info into the
+% maps, and the later branches will be given the resulting map as guidance.
+%
+% We override any old settings here, for use in the rest of the current
+% branch. Other branches will do likewise. The correct handling of the code
+% after the branched structure is ensured by process_goal returning only
+% the common subsets of the maps constructed by the various branches to
+% be used when processing the following code.
+
+:- pred record_known_type_ctor_info(prog_var::in, module_name::in, string::in,
+ int::in, info::in, info::out) is det.
+
+record_known_type_ctor_info(Var, TypeCtorModule, TypeCtorName, TypeCtorArity,
+ !Info) :-
+ TypeCtor = qualified(TypeCtorModule, TypeCtorName) - TypeCtorArity,
+ TypeCtorMap0 = !.Info ^ type_ctor_map,
+ RevTypeCtorMap0 = !.Info ^ rev_type_ctor_map,
+ map__set(TypeCtorMap0, TypeCtor, Var, TypeCtorMap),
+ map__set(RevTypeCtorMap0, Var, TypeCtor, RevTypeCtorMap),
+ !:Info = !.Info ^ type_ctor_map := TypeCtorMap,
+ !:Info = !.Info ^ rev_type_ctor_map := RevTypeCtorMap.
+
+:- pred record_known_type_info(prog_var::in, prog_var::in, list(prog_var)::in,
+ info::in, info::out) is det.
+
+record_known_type_info(Var, TypeCtorInfoVar, ArgTypeInfoVars, !Info) :-
+ RevTypeCtorMap0 = !.Info ^ rev_type_ctor_map,
+ map__lookup(RevTypeCtorMap0, TypeCtorInfoVar, TypeCtor0),
+ RevTypeInfoMap0 = !.Info ^ rev_type_info_map,
+ (
+ list__map(map__search(RevTypeInfoMap0), ArgTypeInfoVars,
+ ArgTypes)
+ ->
+ list__length(ArgTypes, Arity),
+ % Just in case TypeCtorInfo0 has fake arity,
+ % e.g. if it is a tuple.
+ TypeCtor0 = SymName - _DeclArity,
+ TypeCtor1 = SymName - Arity,
+ construct_type(TypeCtor1, ArgTypes, Type),
+ record_type_info_var(Type, Var, !Info)
+ ;
+ !:Info = !.Info
+ ).
+
+:- pred record_type_info_var((type)::in, prog_var::in, info::in, info::out)
+ is det.
+
+record_type_info_var(Type, Var, !Info) :-
+ RevTypeInfoMap0 = !.Info ^ rev_type_info_map,
+ TypeInfoMap0 = !.Info ^ type_info_map,
+ map__set(TypeInfoMap0, Type, Var, TypeInfoMap),
+ ( map__insert(RevTypeInfoMap0, Var, Type, RevTypeInfoMap1) ->
+ RevTypeInfoMap = RevTypeInfoMap1
+ ;
+ % This can happen because inlining XXX can leave a
+ % type_info_varmap saying that one type_info variable
+ % holds the typeinfo for more than one type.
+ RevTypeInfoMap = RevTypeInfoMap0
+ ),
+ !:Info = !.Info ^ type_info_map := TypeInfoMap,
+ !:Info = !.Info ^ rev_type_info_map := RevTypeInfoMap.
+
+:- pred record_known_size(prog_var::in, int::in, info::in, info::out) is det.
+
+record_known_size(Var, KnownSize, !Info) :-
+ KnownSizeMap0 = !.Info ^ known_size_map,
+ map__det_insert(KnownSizeMap0, Var, KnownSize, KnownSizeMap),
+ !:Info = !.Info ^ known_size_map := KnownSizeMap.
+
+:- pred record_typeinfo_in_type_info_varmap(pair(tvar, type_info_locn)::in,
+ info::in, info::out) is det.
+
+record_typeinfo_in_type_info_varmap(TVar - TypeInfoLocn, !Info) :-
+ Type = term__variable(TVar),
+ (
+ TypeInfoLocn = type_info(TypeInfoVar),
+ record_type_info_var(Type, TypeInfoVar, !Info)
+ ;
+ TypeInfoLocn = typeclass_info(_TypeClassInfoVar, _Offset)
+ % We could record this information and then look for calls that
+ % extract typeinfos from typeclass_infos, but code that does
+ % that is rare enough that it is not worth optimizing.
+ % TypeClassInfoMap0 = !.Info ^ type_class_info_map,
+ % map__det_insert(TypeClassInfoMap0,
+ % TypeClassInfoVar - Offset, Type, TypeClassInfoMap),
+ % !:Info = !.Info ^ type_class_info_map := TypeClassInfoMap
+ ).
+
+%---------------------------------------------------------------------------%
+
+% We must ensure that we record that a branched control structure is considered
+% to generate a type_ctor_info or type_info variable only if all the branches
+% generate it. The code above takes the intersections of the forward maps
+% (type to type_info or type_ctor_info var maps) produced by different branches
+% directly, but calls update_rev_maps to ensure that the reverse maps
+%
+% (a) contain only entries that are also in the forward maps, i.e. do not
+% contain entries that the intersection process removed, and
+% (b) do not contain entries derived from inconsistent forward map entries
+% (since a forward map can say that e.g. both the type int and the type
+% constructor int/0 have their typeinfo in the same variable).
+
+:- pred update_rev_maps(info::in, info::out) is det.
+
+update_rev_maps(!Info) :-
+ map__to_sorted_assoc_list(!.Info ^ type_info_map, TypeInfoList),
+ map__to_sorted_assoc_list(!.Info ^ type_ctor_map, TypeCtorList),
+ map__init(VarCounts0),
+ count_appearances(TypeInfoList, VarCounts0, VarCounts1),
+ count_appearances(TypeCtorList, VarCounts1, VarCounts),
+ construct_rev_map(TypeInfoList, VarCounts, map__init, RevTypeInfoMap),
+ construct_rev_map(TypeCtorList, VarCounts, map__init, RevTypeCtorMap),
+ !:Info = !.Info ^ rev_type_info_map := RevTypeInfoMap,
+ !:Info = !.Info ^ rev_type_ctor_map := RevTypeCtorMap.
+
+:- pred count_appearances(assoc_list(T, prog_var)::in,
+ map(prog_var, int)::in, map(prog_var, int)::out) is det.
+
+count_appearances([], VarCounts, VarCounts).
+count_appearances([_ - Var | AssocList], VarCounts0, VarCounts) :-
+ ( map__search(VarCounts0, Var, Count) ->
+ map__det_update(VarCounts0, Var, Count + 1, VarCounts1)
+ ;
+ map__det_insert(VarCounts0, Var, 1, VarCounts1)
+ ),
+ count_appearances(AssocList, VarCounts1, VarCounts).
+
+:- pred construct_rev_map(assoc_list(T, prog_var)::in,
+ map(prog_var, int)::in,
+ map(prog_var, T)::in, map(prog_var, T)::out) is det.
+
+construct_rev_map([], _, RevMap, RevMap).
+construct_rev_map([T - Var | AssocList], VarCounts, RevMap0, RevMap) :-
+ map__lookup(VarCounts, Var, Count),
+ ( Count = 1 ->
+ map__det_insert(RevMap0, Var, T, RevMap1)
+ ;
+ RevMap1 = RevMap0
+ ),
+ construct_rev_map(AssocList, VarCounts, RevMap1, RevMap).
+
+%---------------------------------------------------------------------------%
+
+% During the processing of a branched control structure, we add entries to the
+% target type_info map in an effort to encourage different branches to use the
+% same variable to store the type_info for the same type, since this increases
+% the probability that all branches define a type_info for the type and that
+% thus we will be able to use the variable holding that type_info after the
+% branched control structure without recreating it. However, if some branches
+% define the target variable but others don't, then the branched control
+% structure cannot define the variable for later code. We must therefore
+% remove the variable from the target type_info map used by later code.
+
+:- pred update_target_map(info::in, info::out) is det.
+
+update_target_map(!Info) :-
+ TargetTypeInfoMap0 = !.Info ^ target_type_info_map,
+ TypeInfoMap = !.Info ^ type_info_map,
+ map__to_sorted_assoc_list(TargetTypeInfoMap0, TargetTypeInfoList),
+ list__foldl(include_in_target_map(TypeInfoMap), TargetTypeInfoList,
+ map__init, TargetTypeInfoMap),
+ !:Info = !.Info ^ target_type_info_map := TargetTypeInfoMap.
+
+:- pred include_in_target_map(type_info_map::in, pair(type, prog_var)::in,
+ type_info_map::in, type_info_map::out) is det.
+
+include_in_target_map(TypeInfoMap, Type - TypeInfoVar,
+ TargetTypeInfoMap0, TargetTypeInfoMap) :-
+ ( map__search(TypeInfoMap, Type, TypeInfoVar) ->
+ map__det_insert(TargetTypeInfoMap0, Type, TypeInfoVar,
+ TargetTypeInfoMap)
+ ;
+ TargetTypeInfoMap = TargetTypeInfoMap0
+ ).
+
+%---------------------------------------------------------------------------%
+
+:- func compute_functor_size(list(prog_var), info) = int.
+
+compute_functor_size(Args, Info) = FunctorSize :-
+ TransformOp = Info ^ transform_op,
+ (
+ TransformOp = term_cells,
+ FunctorSize = 1
+ ;
+ TransformOp = term_words,
+ FunctorSize = list__length(Args)
+ ).
+
+:- pred find_defined_args(list(prog_var)::in, list(uni_mode)::in,
+ list(prog_var)::out, list(prog_var)::out, info::in) is det.
+
+find_defined_args(Args, Modes, DefinedArgs, NonDefinedArgs, Info) :-
+ (
+ Args = [],
+ Modes = [],
+ DefinedArgs = [],
+ NonDefinedArgs = []
+ ;
+ Args = [],
+ Modes = [_ | _],
+ error("size_prof__find_defined_args: length mismatch")
+ ;
+ Args = [_ | _],
+ Modes = [],
+ error("size_prof__find_defined_args: length mismatch")
+ ;
+ Args = [FirstArg | LaterArgs],
+ Modes = [FirstMode | LaterModes],
+ find_defined_args(LaterArgs, LaterModes, LaterDefinedArgs,
+ LaterNonDefinedArgs, Info),
+ ( binds_arg_in_cell(Info, FirstMode) ->
+ DefinedArgs = [FirstArg | LaterDefinedArgs],
+ NonDefinedArgs = LaterNonDefinedArgs
+ ;
+ DefinedArgs = LaterDefinedArgs,
+ NonDefinedArgs = [FirstArg | LaterNonDefinedArgs]
+ )
+ ).
+
+:- pred binds_arg_in_cell(info::in, uni_mode::in) is semidet.
+
+binds_arg_in_cell(Info, (CellInitInst - _ArgInitInst) ->
+ (CellFinalInst - _ArgFinalInst)) :-
+ ModuleInfo = Info ^ module_info,
+ inst_is_free(ModuleInfo, CellInitInst),
+ inst_is_bound(ModuleInfo, CellFinalInst).
+
+%---------------------------------------------------------------------------%
+
+:- pred insist_on_same(T::in, T::in, T::out) is semidet.
+
+insist_on_same(X, X, X).
+
+%---------------------------------------------------------------------------%
+
+:- pred ctor_is_type_info_related(module_name::in, string::in) is semidet.
+
+ctor_is_type_info_related(VarTypeCtorModule, VarTypeCtorName) :-
+ VarTypeCtorModule = mercury_private_builtin_module,
+ ( VarTypeCtorName = "type_info"
+ ; VarTypeCtorName = "type_ctor_info"
+ ; VarTypeCtorName = "typeclass_info"
+ ; VarTypeCtorName = "base_typeclass_info"
+ ).
+
+%---------------------------------------------------------------------------%
Index: compiler/special_pred.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/special_pred.m,v
retrieving revision 1.40
diff -u -b -r1.40 special_pred.m
--- compiler/special_pred.m 25 Jul 2003 02:27:23 -0000 1.40
+++ compiler/special_pred.m 29 Jul 2003 07:55:53 -0000
@@ -160,11 +160,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),
@@ -174,11 +174,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.83
diff -u -b -r1.83 stack_layout.m
--- compiler/stack_layout.m 29 May 2003 16:00:38 -0000 1.83
+++ compiler/stack_layout.m 4 Jul 2003 06:09:31 -0000
@@ -174,7 +174,7 @@
:- pragma c_header_code("
#include ""mercury_tags.h"" /* for MR_list_*() */
- #include ""mercury_heap.h"" /* for MR_incr_hp_atomic*() */
+ #include ""mercury_heap.h"" /* for MR_offset_incr_hp_atomic*() */
#include ""mercury_misc.h"" /* for MR_fatal_error() */
").
@@ -187,7 +187,7 @@
MR_Integer cur_offset;
MR_Word tmp;
- MR_incr_hp_atomic(tmp,
+ MR_offset_incr_hp_atomic(tmp, 0,
(ArenaSize + sizeof(MR_Word)) / sizeof(MR_Word));
Arena = (char *) tmp;
@@ -793,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,
@@ -972,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),
@@ -986,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)) }
).
@@ -1081,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),
@@ -1160,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,
@@ -1247,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/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/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.14
diff -u -b -r1.14 switch_util.m
--- compiler/switch_util.m 25 Jul 2003 02:27:23 -0000 1.14
+++ compiler/switch_util.m 29 Jul 2003 07:55:54 -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.52
diff -u -b -r1.52 table_gen.m
--- compiler/table_gen.m 25 Jul 2003 02:27:23 -0000 1.52
+++ compiler/table_gen.m 29 Jul 2003 07:55:54 -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,
@@ -1386,12 +1386,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)
@@ -1409,7 +1406,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,
@@ -1519,14 +1516,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,
@@ -1539,7 +1536,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),
@@ -1632,13 +1629,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.
@@ -1646,7 +1643,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),
@@ -1832,51 +1829,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_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/term_util.m,v
retrieving revision 1.26
diff -u -b -r1.26 term_util.m
--- compiler/term_util.m 25 Jul 2003 02:27:24 -0000 1.26
+++ compiler/term_util.m 29 Jul 2003 07:55:54 -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_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/type_util.m,v
retrieving revision 1.126
diff -u -b -r1.126 type_util.m
--- compiler/type_util.m 19 Sep 2003 11:10:04 -0000 1.126
+++ compiler/type_util.m 21 Sep 2003 23:32:30 -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,
@@ -128,6 +135,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
@@ -145,23 +157,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.
@@ -174,6 +191,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.
@@ -197,6 +217,7 @@
:- 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).
@@ -204,6 +225,10 @@
:- func comparison_result_type = (type).
:- func aditi_state_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.
@@ -533,6 +558,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.
@@ -555,11 +581,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).
@@ -576,14 +616,32 @@
; Body = foreign_type(_, _) ).
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 :-
@@ -601,30 +659,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) :-
@@ -681,6 +750,24 @@
EvalMethod = (aditi_bottom_up)
).
+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),
(
@@ -893,6 +980,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,
@@ -965,6 +1068,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).
@@ -988,10 +1094,19 @@
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).
+
aditi_state_type = Type :-
aditi_public_builtin_module(BuiltinModule),
- construct_type(qualified(BuiltinModule,
- "state") - 0, [], Type).
+ construct_type(qualified(BuiltinModule, "state") - 0, [], Type).
%-----------------------------------------------------------------------------%
@@ -1133,7 +1248,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, _).
@@ -1374,7 +1488,6 @@
map__init(TypeSubst0),
type_unify_list(TypesA, TypesB, TypesBVars, TypeSubst0, TypeSubst).
-
arg_type_list_subsumes(TVarSet, ArgTypes, CalleeTVarSet,
CalleeExistQVars0, CalleeArgTypes0) :-
@@ -1660,7 +1773,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/unify_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/unify_gen.m,v
retrieving revision 1.132
diff -u -b -r1.132 unify_gen.m
--- compiler/unify_gen.m 19 Sep 2003 11:10:04 -0000 1.132
+++ compiler/unify_gen.m 30 Sep 2003 07:33:20 -0000
@@ -83,10 +83,10 @@
{ Code = empty }
)
;
- { Uni = construct(Var, ConsId, Args, Modes, _, _, _) },
+ { Uni = construct(Var, ConsId, Args, Modes, _, _, Size) },
( code_info__variable_is_forward_live(Var) ->
unify_gen__generate_construction(Var, ConsId,
- Args, Modes, GoalInfo, Code)
+ Args, Modes, Size, GoalInfo, Code)
;
{ Code = empty }
)
@@ -332,28 +332,31 @@
% instantiate the arguments of that term.
:- pred unify_gen__generate_construction(prog_var::in, cons_id::in,
- list(prog_var)::in, list(uni_mode)::in, hlds_goal_info::in,
- code_tree::out, code_info::in, code_info::out) is det.
+ list(prog_var)::in, list(uni_mode)::in, 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, GoalInfo, Code) -->
+unify_gen__generate_construction(Var, Cons, Args, Modes, Size, GoalInfo,
+ Code) -->
code_info__cons_id_to_tag(Var, Cons, Tag),
unify_gen__generate_construction_2(Tag, Var, Args,
- Modes, GoalInfo, Code).
+ Modes, Size, GoalInfo, Code).
:- pred unify_gen__generate_construction_2(cons_tag::in, prog_var::in,
- list(prog_var)::in, list(uni_mode)::in, hlds_goal_info::in,
- code_tree::out, code_info::in, code_info::out) is det.
+ list(prog_var)::in, list(uni_mode)::in, 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),
@@ -363,21 +366,21 @@
"unify_gen__generate_construction_2: no_tag: arity != 1") }
).
unify_gen__generate_construction_2(single_functor,
- Var, Args, Modes, GoalInfo, Code) -->
+ Var, Args, Modes, Size, GoalInfo, Code) -->
% treat single_functor the same as unshared_tag(0)
unify_gen__generate_construction_2(unshared_tag(0),
- Var, Args, Modes, GoalInfo, Code).
+ Var, Args, Modes, 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,
@@ -386,13 +389,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 = [] } ->
[]
;
@@ -400,19 +403,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 = [] } ->
[]
;
@@ -422,28 +427,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(reserved_address(RA),
- Var, Args, _Modes, _, empty) -->
+ Var, Args, _Modes, _, _, empty) -->
( { Args = [] } ->
[]
;
@@ -453,15 +461,15 @@
unify_gen__generate_reserved_address(RA)).
unify_gen__generate_construction_2(
shared_with_reserved_addresses(_RAs, ThisTag),
- Var, Args, Modes, GoalInfo, Code) -->
+ Var, Args, Modes, 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, GoalInfo, Code).
+ Var, Args, Modes, Size, GoalInfo, Code).
unify_gen__generate_construction_2(
pred_closure_tag(PredId, ProcId, EvalMethod),
- Var, Args, _Modes, GoalInfo, Code) -->
+ Var, Args, _Modes, _, GoalInfo, Code) -->
% This code constructs or extends a closure.
% The structure of closures is defined in runtime/mercury_ho_call.h.
@@ -546,7 +554,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",
@@ -621,7 +629,7 @@
code_info__add_static_cell_natural_types(AditiCallArgs,
CallArgsDataAddr),
{ CallArgsRval =
- const(data_addr_const(CallArgsDataAddr)) }
+ const(data_addr_const(CallArgsDataAddr, no)) }
),
{ continuation_info__generate_closure_layout(
ModuleInfo, PredId, ProcId, ClosureInfo) },
@@ -641,10 +649,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) },
@@ -654,7 +664,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/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.87
diff -u -b -r1.87 compiler_design.html
--- compiler/notes/compiler_design.html 23 Sep 2003 04:28:21 -0000 1.87
+++ compiler/notes/compiler_design.html 23 Sep 2003 04:30:44 -0000
@@ -798,10 +798,12 @@
<p>
-The last HLDS-to-HLDS transformation implements deep profiling
-(deep_profiling.m, in the ll_backend.m package).
-This pass inserts calls to impure procedures that record profiling
-information.
+The last two HLDS-to-HLDS transformations implement
+term size profiling (size_prof.m) and
+deep profiling (deep_profiling.m, in the ll_backend.m package).
+Both passes insert into procedure bodies, among other things,
+calls to procedures (some of which are impure)
+that record profiling information.
<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.35
diff -u -b -r1.35 Mmakefile
--- doc/Mmakefile 23 Jul 2003 03:38:45 -0000 1.35
+++ doc/Mmakefile 29 Jul 2003 07:55:55 -0000
@@ -236,6 +236,8 @@
;; \
$(LIBRARY_DIR)/table_builtin.m) \
;; \
+ $(LIBRARY_DIR)/term_size_prof_builtin.m) \
+ ;; \
*) \
echo "* `basename $$filename .m`::"; \
;; \
@@ -255,6 +257,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.375
diff -u -b -r1.375 user_guide.texi
--- doc/user_guide.texi 25 Sep 2003 07:56:44 -0000 1.375
+++ doc/user_guide.texi 30 Sep 2003 03:15:36 -0000
@@ -2474,6 +2474,13 @@
@sp 1
The options @samp{-f} or @samp{--flat}, @samp{-p} or @samp{--pretty},
and @samp{-v} or @samp{--verbose} specify the format to use for printing.
+ at c @sp 1
+ at c @item print [-fpv] proc_body
+ at c Prints a representation c of the body of the current procedure,
+ at c if it is available.
+ at c @sp 1
+ at c The options @samp{-f} or @samp{--flat}, @samp{-p} or @samp{--pretty},
+ at c and @samp{-v} or @samp{--verbose} specify the format to use for printing.
@sp 1
@item browse [-fpv] @var{name}
@itemx browse [-fpv] @var{num}
@@ -2518,6 +2525,13 @@
@sp 1
The options @samp{-f} or @samp{--flat}, @samp{-p} or @samp{--pretty},
and @samp{-v} or @samp{--verbose} specify the format to use for browsing.
+ at c @sp 1
+ at c @item browse [-fpv] proc_body
+ at c Invokes an interactive term browser to browse a representation
+ at c of the body of the current procedure, if it is available.
+ at c @sp 1
+ at c The options @samp{-f} or @samp{--flat}, @samp{-p} or @samp{--pretty},
+ at c and @samp{-v} or @samp{--verbose} specify the format to use for browsing.
@sp 1
@item stack [-d] [@var{num}]
@kindex stack (mdb command)
@@ -3185,6 +3199,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.
@@ -4702,7 +4724,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,
@@ -5090,6 +5112,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}.
@@ -5157,6 +5183,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}.
@@ -5372,6 +5406,21 @@
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 end ignore
+
+ 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.125
diff -u -b -r1.125 array.m
--- library/array.m 28 Aug 2003 06:56:50 -0000 1.125
+++ library/array.m 29 Aug 2003 03:55:48 -0000
@@ -473,9 +473,22 @@
#include ""mercury_heap.h"" /* for MR_maybe_record_allocation() */
#include ""mercury_library_types.h"" /* for MR_ArrayPtr */
+/*
+** We do not yet record term sizes for arrays in term size profiling
+** grades. Doing so would require
+**
+** - modifying ML_alloc_array to allocate an extra word for the size;
+** - modifying all the predicates that call ML_alloc_array to compute the
+** size of the array (the sum of the sizes of the elements and the size of
+** the array itself);
+** - modifying all the predicates that update array elements to compute the
+** difference between the sizes of the terms being added to and deleted from
+** the array, and updating the array size accordingly.
+*/
+
#define ML_alloc_array(newarray, arraysize, proclabel) \
- MR_incr_hp_msg(MR_LVALUE_CAST(MR_Word, (newarray)), (arraysize), \
- proclabel, ""array:array/1"")
+ MR_offset_incr_hp_msg(MR_LVALUE_CAST(MR_Word, (newarray)), \
+ 0, (arraysize), proclabel, ""array:array/1"")
").
:- pragma foreign_decl("C", "
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 30 Sep 2003 08:15:14 -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.304
diff -u -b -r1.304 io.m
--- library/io.m 14 Sep 2003 22:24:32 -0000 1.304
+++ library/io.m 14 Sep 2003 22:26:55 -0000
@@ -1916,8 +1916,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';
@@ -3015,7 +3015,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"");
@@ -3042,17 +3042,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"");
@@ -6296,17 +6295,18 @@
:- 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],
-"
+"{
+ 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),
@@ -6412,7 +6412,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);
").
@@ -6632,7 +6632,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) {
@@ -6747,7 +6747,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, error, msg, procname, error_msg) \\
@@ -6759,7 +6759,7 @@
if (was_error) { \\
errno_msg = strerror(error); \\
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.70
diff -u -b -r1.70 library.m
--- library/library.m 10 Jun 2003 10:03:31 -0000 1.70
+++ library/library.m 12 Jun 2003 06:40:14 -0000
@@ -97,6 +97,7 @@
:- import_module profiling_builtin.
:- import_module rtti_implementation.
:- import_module table_builtin.
+:- import_module term_size_prof_builtin.
% library__version must be implemented using pragma foreign_proc,
% so we can get at the MR_VERSION and MR_FULLARCH configuration
Index: library/private_builtin.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/private_builtin.m,v
retrieving revision 1.123
diff -u -b -r1.123 private_builtin.m
--- library/private_builtin.m 25 Jul 2003 06:05:52 -0000 1.123
+++ library/private_builtin.m 29 Jul 2003 07:55:59 -0000
@@ -1097,6 +1097,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.40
diff -u -b -r1.40 store.m
--- library/store.m 28 Aug 2003 06:56:51 -0000 1.40
+++ library/store.m 29 Aug 2003 03:55:49 -0000
@@ -291,7 +291,9 @@
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;
").
@@ -324,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;
").
@@ -339,7 +343,9 @@
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;
").
@@ -446,7 +452,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;
Index: library/string.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/string.m,v
retrieving revision 1.205
diff -u -b -r1.205 string.m
--- library/string.m 17 Aug 2003 13:30:12 -0000 1.205
+++ library/string.m 19 Aug 2003 02:52:55 -0000
@@ -928,7 +928,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);
}
}").
@@ -1263,8 +1263,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;
@@ -1278,8 +1277,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);
@@ -1756,11 +1754,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;
").
@@ -2849,7 +2849,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
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 30 Sep 2003 08:18:25 -0000
@@ -0,0 +1,124 @@
+%---------------------------------------------------------------------------%
+% 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", "
+#ifndef MR_TERM_SIZE_PROFILING_GUARD
+#define 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
+ MR_TypeInfo type_info;
+
+ type_info = (MR_TypeInfo) TypeInfo_for_T;
+ Size = MR_term_size(type_info, 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
+ MR_TypeInfo type_info;
+
+ type_info = (MR_TypeInfo) TypeInfo_for_T;
+ Size = MR_term_size(type_info, 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.103
diff -u -b -r1.103 Mmakefile
--- runtime/Mmakefile 13 Jul 2003 08:19:18 -0000 1.103
+++ runtime/Mmakefile 29 Jul 2003 07:56:00 -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.72
diff -u -b -r1.72 mercury_conf_param.h
--- runtime/mercury_conf_param.h 21 Jul 2003 14:08:41 -0000 1.72
+++ runtime/mercury_conf_param.h 30 Sep 2003 08:56:41 -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).
@@ -294,6 +300,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.
@@ -303,6 +319,19 @@
** save/restore approach (the two approaches are documented in the deep
** 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:
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.17
diff -u -b -r1.17 mercury_debug.c
--- runtime/mercury_debug.c 1 Jun 2003 06:52:35 -0000 1.17
+++ runtime/mercury_debug.c 19 Jun 2003 11:06:41 -0000
@@ -40,6 +40,43 @@
/* 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 *) type_info, (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 *) type_info, (void *) value, (void *) univ);
+ fflush(stdout);
+ }
+}
+
+void
+MR_debug_tag_offset_incr_hp_base_msg(MR_Word ptr, int tag, int offset,
+ int count, int is_atomic)
+{
+ if (MR_lld_print_enabled && MR_heapdebug) {
+ printf("tag_offset_incr_hp: "
+ "tag %d, offset %d, count %d%s => %p\n",
+ tag, offset, count, (is_atomic ? ", atomic" : ""),
+ (void *) ptr);
+ fflush(stdout);
+ }
+}
+
+#endif /* MR_DEBUG_HEAP_ALLOC */
+
#ifdef MR_LOWLEVEL_DEBUG
void
@@ -265,25 +302,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;
+ }
+
+#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(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("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_cr2_msg(MR_Word val0, MR_Word val1, const MR_Word *addr)
+MR_cr3_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("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);
}
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 30 Sep 2003 08:48:54 -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,32 @@
#endif
+#ifndef MR_DEBUG_HEAP_ALLOC
+
+#define MR_debug_unravel_univ(univ, typeinfo, value) ((void)0)
+#define MR_debug_new_univ_on_hp(univ, typeinfo, value) ((void)0)
+#define MR_debug_tag_offset_incr_hp_base(ptr, tag, offset, count, is_atomic) \
+ ((void)0)
+
+#else
+
+#define MR_debug_unravel_univ(univ, typeinfo, value) \
+ MR_unravel_univ_msg((univ), (typeinfo), (value))
+
+#define MR_debug_new_univ_on_hp(univ, typeinfo, value) \
+ MR_new_univ_on_hp_msg((univ), (typeinfo), (value))
+
+#define MR_debug_tag_offset_incr_hp_base(ptr, tag, offset, count, is_atomic) \
+ MR_debug_tag_offset_incr_hp_base_msg((ptr), (tag), \
+ (offset), (count), (is_atomic))
+
+#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 +87,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 +113,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 +184,15 @@
/*---------------------------------------------------------------------------*/
+#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_debug_tag_offset_incr_hp_base_msg(MR_Word ptr, int tag,
+ int offset, int count, int is_atomic);
+#endif
+
#ifdef MR_LOWLEVEL_DEBUG
extern void MR_mkframe_msg(const char *);
extern void MR_mktempframe_msg(void);
@@ -167,8 +205,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);
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_grade.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_grade.h,v
retrieving revision 1.48
diff -u -b -r1.48 mercury_grade.h
--- runtime/mercury_grade.h 29 May 2003 17:11:12 -0000 1.48
+++ runtime/mercury_grade.h 29 May 2003 18:18:19 -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 30 Sep 2003 08:42:52 -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,45 @@
#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, is_atomic) \
+ ( \
+ MR_tag_offset_sanity_check((offset), (count)), \
+ (dest) = (MR_Word) MR_mkword((tag), (MR_Word) \
+ (((MR_Word *) alloc((count) * sizeof(MR_Word))) \
+ + (offset))), \
+ MR_debug_tag_offset_incr_hp_base((dest), (tag), (offset), \
+ (count), (is_atomic)), \
+ /* 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, 0)
+ #define MR_tag_offset_incr_hp_atomic(dest, tag, offset, count) \
+ MR_tag_offset_incr_hp_base(dest, tag, offset, count, \
+ GC_MALLOC_ATOMIC, 1)
#ifdef MR_INLINE_ALLOC
@@ -67,22 +102,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 */
@@ -91,12 +127,14 @@
/* we use `MR_hp' as a convenient temporary here */
#define MR_hp_alloc(count) ( \
- MR_incr_hp(MR_LVALUE_CAST(MR_Word, MR_hp), (count)), \
+ MR_offset_incr_hp(MR_LVALUE_CAST(MR_Word, MR_hp), \
+ 0, (count)), \
MR_hp += (count), \
(void) 0 \
)
#define MR_hp_alloc_atomic(count) ( \
- MR_incr_hp_atomic(MR_LVALUE_CAST(MR_Word, MR_hp), (count)),\
+ MR_offset_incr_hp_atomic(MR_LVALUE_CAST(MR_Word, MR_hp), \
+ 0, (count)), \
MR_hp += (count), \
(void) 0 \
)
@@ -105,16 +143,22 @@
#else /* not MR_CONSERVATIVE_GC */
- #define MR_tag_incr_hp(dest, tag, count) \
+ #define MR_tag_offset_incr_hp_base(dest, tag, offset, count, is_atomic) \
( \
- (dest) = (MR_Word) MR_mkword(tag, (MR_Word) MR_hp),\
- MR_debugincrhp(count, MR_hp), \
+ MR_tag_offset_sanity_check((offset), (count)), \
+ (dest) = (MR_Word) MR_mkword(tag, (MR_Word) \
+ (((MR_Word *) MR_hp) + (offset))), \
+ MR_debug_tag_offset_incr_hp_base((dest), (tag), (offset), \
+ (count), (is_atomic)), \
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(dest, tag, offset, count) \
+ MR_tag_offset_incr_hp_base((dest), (tag), (offset), (count), 0)
+ #define MR_tag_offset_incr_hp_atomic(dest, tag, offset, count) \
+ MR_tag_offset_incr_hp_base((dest), (tag), (offset), (count), 1)
#define MR_mark_hp(dest) ((dest) = (MR_Word) MR_hp)
@@ -140,10 +184,12 @@
)
*/
- #define MR_hp_alloc(count) MR_incr_hp( \
- MR_LVALUE_CAST(MR_Word, MR_hp), count)
- #define MR_hp_alloc_atomic(count) MR_incr_hp_atomic( \
- MR_LVALUE_CAST(MR_Word, MR_hp), count)
+ #define MR_hp_alloc(count) MR_offset_incr_hp( \
+ MR_LVALUE_CAST(MR_Word, MR_hp), \
+ 0, (count))
+ #define MR_hp_alloc_atomic(count) MR_offset_incr_hp_atomic( \
+ MR_LVALUE_CAST(MR_Word, MR_hp), \
+ 0, (count))
#define MR_free_heap(ptr) ((void) 0)
@@ -166,33 +212,59 @@
((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.
+** The MR_offset_incr_hp*() macros are defined in terms of the
+** MR_tag_offset_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))
+
+#ifndef MR_RECORD_TERM_SIZES
+
#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))
+
+#endif
+
#define MR_incr_hp_type(dest, typename) \
do { \
MR_Word tmp; \
@@ -215,12 +287,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 +301,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 +311,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 +321,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 +349,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 +469,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,8 +509,12 @@
/* XXX this assumes that nothing requires */ \
/* stricter alignment than MR_Float */ \
MR_make_hp_float_aligned(); \
- MR_incr_hp(MR_LVALUE_CAST(MR_Word, (box)), \
- size_in_words); \
+ /* \
+ ** This assumes that we don't keep term sizes \
+ ** in grades that use boxes. \
+ */ \
+ MR_offset_incr_hp(MR_LVALUE_CAST(MR_Word, (box)),\
+ 0, size_in_words); \
MR_assign_structure(*(T *)(box), (value)); \
MR_maybe_record_allocation(size_in_words, \
"", "foreign type: " MR_STRINGIFY(T)); \
Index: runtime/mercury_ho_call.c
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_ho_call.c,v
retrieving revision 1.64
diff -u -b -r1.64 mercury_ho_call.c
--- runtime/mercury_ho_call.c 30 Sep 2003 01:54:39 -0000 1.64
+++ runtime/mercury_ho_call.c 30 Sep 2003 03:23:56 -0000
@@ -1082,7 +1082,8 @@
#else
num_hidden_args = 0;
#endif
- MR_incr_hp(MR_LVALUE_CAST(MR_Word, closure), 3 + num_hidden_args);
+ MR_offset_incr_hp(MR_LVALUE_CAST(MR_Word, closure), 0,
+ 3 + num_hidden_args);
closure->MR_closure_layout = (MR_Closure_Layout *) closure_layout;
closure->MR_closure_code = proc_addr;
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.40
diff -u -b -r1.40 mercury_init.h
--- runtime/mercury_init.h 14 Sep 2003 22:24:36 -0000 1.40
+++ runtime/mercury_init.h 14 Sep 2003 22:55:59 -0000
@@ -78,7 +78,7 @@
#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(),
@@ -125,6 +125,15 @@
extern void ML_io_print_to_stream(MR_Word, MercuryFilePtr, 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.73
diff -u -b -r1.73 mercury_stack_layout.h
--- runtime/mercury_stack_layout.h 24 Jun 2003 01:21:21 -0000 1.73
+++ runtime/mercury_stack_layout.h 24 Jun 2003 01:22:03 -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 */
/*-------------------------------------------------------------------------*/
/*
@@ -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.
-*/
-
-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_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.
**
@@ -820,7 +766,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
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 19 Jun 2003 09:51:31 -0000
@@ -9,7 +9,7 @@
#ifndef MERCURY_STRING_H
#define MERCURY_STRING_H
-#include "mercury_heap.h" /* for MR_incr_hp_atomic */
+#include "mercury_heap.h" /* for MR_offset_incr_hp_atomic */
#include <string.h> /* for strcmp() etc. */
#include <stdarg.h>
@@ -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.
**
@@ -89,7 +90,7 @@
MR_Word make_aligned_string_tmp; \
char * make_aligned_string_ptr; \
\
- MR_incr_hp_atomic(make_aligned_string_tmp, \
+ MR_offset_incr_hp_atomic(make_aligned_string_tmp, 0, \
(strlen(string) + sizeof(MR_Word)) / sizeof(MR_Word)); \
make_aligned_string_ptr = \
(char *) make_aligned_string_tmp; \
@@ -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_offset_incr_saved_hp_atomic instead of MR_offset_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_allocate_aligned_string_msg(MR_ConstString &ptr, size_t len,
+/*
+** 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,
** 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
@@ -114,7 +153,7 @@
MR_Word make_aligned_string_tmp; \
char * make_aligned_string_ptr; \
\
- MR_incr_hp_atomic_msg(make_aligned_string_tmp, \
+ MR_offset_incr_hp_atomic_msg(make_aligned_string_tmp, 0,\
((len) + sizeof(MR_Word)) / sizeof(MR_Word), \
proclabel, "string:string/0"); \
make_aligned_string_ptr = \
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 29 Aug 2003 03:25:12 -0000
@@ -0,0 +1,313 @@
+/*
+** 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;
+ int arity;
+ int size;
+
+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:
+ arity = MR_TYPEINFO_GET_VAR_ARITY_ARITY(type_info);
+ if (arity == 0) {
+ /* term may be a NULL pointer, so don't follow it */
+ size = 0;
+ } else {
+ size = MR_field(MR_mktag(0), term, -1);
+ }
+
+#ifdef MR_DEBUG_TERM_SIZES
+ if (MR_heapdebug && MR_lld_print_enabled) {
+ printf("MR_term_size: tuple %p -> %d\n",
+ (void *) term, size);
+ }
+#endif
+ return size;
+
+ 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.52
diff -u -b -r1.52 mercury_trace_base.c
--- runtime/mercury_trace_base.c 14 Sep 2003 22:24:37 -0000 1.52
+++ runtime/mercury_trace_base.c 14 Sep 2003 22:26:57 -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>
@@ -452,7 +453,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_type_desc.c
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_type_desc.c,v
retrieving revision 1.5
diff -u -b -r1.5 mercury_type_desc.c
--- runtime/mercury_type_desc.c 21 Mar 2003 08:00:30 -0000 1.5
+++ runtime/mercury_type_desc.c 19 Jun 2003 09:50:22 -0000
@@ -15,7 +15,7 @@
#endif
#include "mercury_type_info.h"
#include "mercury_type_desc.h"
-#include "mercury_heap.h" /* for MR_incr_hp_atomic_msg() */
+#include "mercury_heap.h" /* for MR_offset_incr_hp_atomic_msg() */
#include "mercury_misc.h" /* for MR_fatal_error() */
MR_TypeCtorDesc
@@ -96,9 +96,9 @@
type_ctor_desc);
MR_restore_transient_registers();
- MR_incr_hp_atomic_msg(
+ MR_offset_incr_hp_atomic_msg(
MR_LVALUE_CAST(MR_Word, new_type_info_arena),
- MR_var_arity_type_info_size(arity),
+ 0, MR_var_arity_type_info_size(arity),
"MR_make_type", "type_info");
MR_save_transient_registers();
MR_fill_in_var_arity_type_info(new_type_info_arena,
@@ -113,9 +113,9 @@
}
MR_restore_transient_registers();
- MR_incr_hp_atomic_msg(
+ MR_offset_incr_hp_atomic_msg(
MR_LVALUE_CAST(MR_Word, new_type_info_arena),
- MR_fixed_arity_type_info_size(arity),
+ 0, MR_fixed_arity_type_info_size(arity),
"MR_make_type", "type_info");
MR_save_transient_registers();
MR_fill_in_fixed_arity_type_info(new_type_info_arena,
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.106
diff -u -b -r1.106 mercury_type_info.h
--- runtime/mercury_type_info.h 5 Aug 2003 08:26:53 -0000 1.106
+++ runtime/mercury_type_info.h 8 Aug 2003 02:27:30 -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' */
/*---------------------------------------------------------------------------*/
@@ -406,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_univ.h
===================================================================
RCS file: runtime/mercury_univ.h
diff -N runtime/mercury_univ.h
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ runtime/mercury_univ.h 19 Jun 2003 11:08:28 -0000
@@ -0,0 +1,70 @@
+/*
+** 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_univ.h - definitions for manipulating univs.
+*/
+
+#ifndef MERCURY_UNIV_H
+#define MERCURY_UNIV_H
+
+#include "mercury_conf_param.h" /* for MR_RECORD_TERM_SIZES */
+#include "mercury_tags.h" /* for MR_field */
+#include "mercury_heap.h" /* for MR_tag_offset_incr_hp_msg */
+#include "mercury_debug.h"
+
+/*
+** `univ' is usually 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. With MR_RECORD_TERM_SIZES,
+** we add an extra field at offset -1 to record the size of the term.
+*/
+
+#define MR_UNIV_OFFSET_FOR_TYPEINFO 0
+#define MR_UNIV_OFFSET_FOR_DATA 1
+
+#ifdef MR_RECORD_TERM_SIZES
+ #define MR_define_univ_size_slot(univ, typeinfo, value) \
+ do { \
+ MR_define_size_slot(MR_UNIV_TAG, (univ), \
+ MR_term_size((typeinfo), (value))); \
+ } while (0)
+#else
+ #define MR_define_univ_size_slot(univ, typeinfo, value) ((void) 0)
+#endif
+
+#define MR_define_univ_fields(univ, typeinfo, value) \
+ do { \
+ MR_define_univ_size_slot((univ), (typeinfo), (value)); \
+ 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)
+
+#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); \
+ MR_debug_unravel_univ((univ), (typeinfo), (value)); \
+ } while (0)
+
+ /* Allocate a univ on the heap */
+ /* XXX we should use MR_tag_offset_incr_hp_msg() here */
+#define MR_new_univ_on_hp(univ, typeinfo, value) \
+ do { \
+ MR_tag_offset_incr_hp((univ), MR_UNIV_TAG, MR_SIZE_SLOT_SIZE, \
+ MR_SIZE_SLOT_SIZE + 2); \
+ MR_define_univ_fields((univ), (typeinfo), (value)); \
+ MR_debug_new_univ_on_hp((univ), (typeinfo), (value)); \
+ } while (0)
+
+#endif /* MERCURY_UNIV_H */
Index: runtime/mercury_wrapper.c
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_wrapper.c,v
retrieving revision 1.122
diff -u -b -r1.122 mercury_wrapper.c
--- runtime/mercury_wrapper.c 14 Sep 2003 22:24:37 -0000 1.122
+++ runtime/mercury_wrapper.c 1 Oct 2003 08:20:43 -0000
@@ -267,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;
+
MR_Box (*MR_address_of_do_load_aditi_rl_code)(MR_Box, MR_Box);
char *(*MR_address_of_trace_getline)(const char *, FILE *, FILE *);
@@ -542,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)
{
@@ -583,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.59
diff -u -b -r1.59 mercury_wrapper.h
--- runtime/mercury_wrapper.h 14 Sep 2003 22:24:37 -0000 1.59
+++ runtime/mercury_wrapper.h 14 Sep 2003 22:26:57 -0000
@@ -99,6 +99,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/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.97
diff -u -b -r1.97 Mmakefile
--- tests/debugger/Mmakefile 2 Sep 2003 09:25:25 -0000 1.97
+++ tests/debugger/Mmakefile 30 Sep 2003 13:27:14 -0000
@@ -103,6 +103,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
@@ -123,9 +129,22 @@
ENUM_PROGS =
endif
+# The tests term_size_words and term_size_cells are each meant to be used
+# in their respective grades only.
+ifneq "$(findstring .tsw,$(GRADE))" ""
+ TERM_SIZE_PROGS = term_size_words
+else
+ ifneq "$(findstring .tsc,$(GRADE))" ""
+ TERM_SIZE_PROGS = term_size_cells
+ else
+ TERM_SIZE_PROGS =
+ endif
+endif
+
ALL_RETRY_PROGS = $(RETRY_PROGS) $(INTERACTIVE_PROGS)
ALL_NONRETRY_PROGS = $(NONRETRY_PROGS) $(SENSITIVE_PROGS) \
- $(SHALLOW_PROGS) $(DEBUG_GRADE_PROGS) $(ENUM_PROGS)
+ $(SHALLOW_PROGS) $(DEBUG_GRADE_PROGS) $(ENUM_PROGS) \
+ $(TERM_SIZE_PROGS)
# Debugging doesn't yet don't work in MLDS grades (hl*, il*, and java),
# and the retry command doesn't and will not work in deep profiling
@@ -384,6 +403,14 @@
tabled_read_decl.out: tabled_read_decl tabled_read_decl.inp tabled_read_decl.data
$(MDB_STD) ./tabled_read_decl < tabled_read_decl.inp \
> tabled_read_decl.out 2>&1
+
+term_size_cells.out: term_size_cells term_size_cells.inp
+ $(MDB_STD) ./term_size_cells < term_size_cells.inp \
+ > term_size_cells.out 2>&1
+
+term_size_words.out: term_size_words term_size_words.inp
+ $(MDB_STD) ./term_size_words < term_size_words.inp \
+ > term_size_words.out 2>&1
type_desc_test.out: type_desc_test type_desc_test.inp
$(MDB_STD) ./type_desc_test < type_desc_test.inp \
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 31 Aug 2003 03:58:16 -0000
@@ -3,27 +3,27 @@
Command echo enabled.
mdb> register --quiet
mdb>
-? document_category level s
-P down maxdepth save
-alias e mindepth scope
-all_regs echo mmc_options scroll
-b enable modules set
-break exception next source
-browse excp nondet_stack stack
-c f p stack_regs
-cc_query finish pneg_stack step
-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
-disable io_query retry
-document label_stats return
+? document_category level save
+P down maxdepth scope
+alias e mindepth scroll
+all_regs echo mmc_options set
+b enable modules source
+break exception next stack
+browse excp nondet_stack stack_regs
+c f p step
+cc_query finish pneg_stack subgoal
+clear_histogram flag print table
+consumer forward print_optionals table_io
+context g printlevel term_size
+continue gen_stack proc_stats unalias
+current goto procedures unhide_events
+cut_stack h query up
+d help quit v
+dd histogram_all r vars
+dd_dd histogram_exp register view
+delete ignore retry
+disable io_query return
+document label_stats s
h help histogram_all histogram_exp
vars view
help vars
@@ -40,7 +40,7 @@
stack --detailed
0 1 1 1 pred completion.main/2-0 (det) (completion.m:13) (empty)
mdb>
-proc_body proc_stats procedures
+proc_stats procedures
completion completion.sub2
completion.sub1 completion.sub2.sub3
completion.sub1 completion.sub2 completion.sub2.sub3
Index: tests/debugger/term_size_cells.exp
===================================================================
RCS file: tests/debugger/term_size_cells.exp
diff -N tests/debugger/term_size_cells.exp
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/debugger/term_size_cells.exp 1 Oct 2003 04:12:26 -0000
@@ -0,0 +1,49 @@
+ E1: C1 1 CALL pred term_size_cells.main/2-0 (det) term_size_cells.m:18
+mdb> echo on
+Command echo enabled.
+mdb> register --quiet
+mdb> context none
+Contexts will not be printed.
+mdb> break static
+ 0: + stop interface pred term_size_cells.static/3-0 (det)
+mdb> continue
+ E2: C2 2 CALL pred term_size_cells.static/3-0 (det)
+mdb> finish
+ E3: C2 2 EXIT pred term_size_cells.static/3-0 (det)
+mdb> print *
+ IntList (arg 1) [1, 2, 3]
+ StringList (arg 2) ["a", "bb", "ccc"]
+ Tree (arg 3) node(leaf, "one", 1, node(leaf, "two", 2, leaf))
+mdb> term_size *
+IntList 3
+StringList 3
+Tree 2
+mdb> break dynamic
+ 1: + stop interface pred term_size_cells.dynamic/6-0 (det)
+mdb> continue
+ E4: C3 2 CALL pred term_size_cells.dynamic/6-0 (det)
+mdb> finish
+ E5: C3 2 EXIT pred term_size_cells.dynamic/6-0 (det)
+mdb> print *
+ IntList (arg 1) [1, 2, 3]
+ DoubleIntList (arg 2) [1, 2, 3, 1, 2, 3]
+ FloatList (arg 3) [1.00000000000000, 2.00000000000000, 3.00000000000000]
+ PairList (arg 4) [-(1, 1.00000000000000), -(2, 2.00000000000000), -(3, 3.00000000000000)]
+ UnivList (arg 5) [univ_cons(1), univ_cons(2), univ_cons(3)]
+ Univ (arg 6) univ_cons(node(node(leaf, 2, -/2, leaf), 1, -(1.00000000000000, "one"), leaf))
+mdb> term_size *
+IntList 3
+DoubleIntList 6
+FloatList 3
+PairList 6
+UnivList 6
+Univ 5
+mdb> continue -n -S
+[1, 2, 3]
+["a", "bb", "ccc"]
+node(leaf, "one", 1, node(leaf, "two", 2, leaf))
+[1, 2, 3, 1, 2, 3]
+[1.00000000000000, 2.00000000000000, 3.00000000000000]
+[1 - 1.00000000000000, 2 - 2.00000000000000, 3 - 3.00000000000000]
+[univ_cons(1), univ_cons(2), univ_cons(3)]
+univ_cons(node(node(leaf, 2, 2.00000000000000 - "two", leaf), 1, 1.00000000000000 - "one", leaf))
Index: tests/debugger/term_size_cells.inp
===================================================================
RCS file: tests/debugger/term_size_cells.inp
diff -N tests/debugger/term_size_cells.inp
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/debugger/term_size_cells.inp 30 Sep 2003 13:26:27 -0000
@@ -0,0 +1,14 @@
+echo on
+register --quiet
+context none
+break static
+continue
+finish
+print *
+term_size *
+break dynamic
+continue
+finish
+print *
+term_size *
+continue -n -S
Index: tests/debugger/term_size_cells.m
===================================================================
RCS file: tests/debugger/term_size_cells.m
diff -N tests/debugger/term_size_cells.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/debugger/term_size_cells.m 1 Oct 2003 00:24:45 -0000
@@ -0,0 +1,68 @@
+:- module term_size_cells.
+
+:- interface.
+
+:- import_module io.
+
+:- pred main(io__state, io__state).
+:- mode main(di, uo) is det.
+
+:- implementation.
+
+:- import_module std_util, list, int, float.
+
+:- type tree(K, V)
+ ---> leaf
+ ; node(tree(K, V), K, V, tree(K, V)).
+
+main(!IO) :-
+ static(IntList, StringList, Tree),
+ dynamic(IntList, DoubleIntList, FloatList, PairList, UnivList, Univ),
+ io__write(IntList, !IO),
+ io__nl(!IO),
+ io__write(StringList, !IO),
+ io__nl(!IO),
+ io__write(Tree, !IO),
+ io__nl(!IO),
+ io__write(DoubleIntList, !IO),
+ io__nl(!IO),
+ io__write(FloatList, !IO),
+ io__nl(!IO),
+ io__write(PairList, !IO),
+ io__nl(!IO),
+ io__write(UnivList, !IO),
+ io__nl(!IO),
+ io__write(Univ, !IO),
+ io__nl(!IO).
+
+% Return some static terms.
+
+:- pred static(list(int)::out, list(string)::out, tree(string, int)::out)
+ is det.
+
+static(IntList, StringList, Tree) :-
+ IntList = [1,2,3],
+ StringList = ["a", "bb", "ccc"],
+ Tree = node(leaf, "one", 1, node(leaf, "two", 2, leaf)).
+
+% Return some dynamic terms.
+
+:- pred dynamic(list(int)::in, list(int)::out, list(float)::out,
+ list(pair(int, float))::out, list(univ)::out, univ::out) is det.
+
+dynamic(IntList, DoubleIntList, FloatList, PairList, UnivList, Univ) :-
+ list__append(IntList, IntList, DoubleIntList),
+ FloatList = list__map(float, IntList),
+ PairList = list__map(pair_float, IntList),
+ UnivList = list__map(convert_type_to_univ, IntList),
+ Univ = convert_type_to_univ(
+ node(node(leaf, 2, 2.0 - "two", leaf), 1, 1.0 - "one", leaf)).
+
+:- func pair_float(int) = pair(int, float).
+
+pair_float(Int) = Int - float(Int).
+
+:- func convert_type_to_univ(T) = univ.
+
+convert_type_to_univ(T) = Univ :-
+ type_to_univ(T, Univ).
Index: tests/debugger/term_size_words.inp
===================================================================
RCS file: tests/debugger/term_size_words.inp
diff -N tests/debugger/term_size_words.inp
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/debugger/term_size_words.inp 30 Sep 2003 13:26:19 -0000
@@ -0,0 +1,14 @@
+echo on
+register --quiet
+context none
+break static
+continue
+finish
+print *
+term_size *
+break dynamic
+continue
+finish
+print *
+term_size *
+continue -n -S
Index: tests/debugger/term_size_words.m
===================================================================
RCS file: tests/debugger/term_size_words.m
diff -N tests/debugger/term_size_words.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/debugger/term_size_words.m 1 Oct 2003 00:24:26 -0000
@@ -0,0 +1,68 @@
+:- module term_size_words.
+
+:- interface.
+
+:- import_module io.
+
+:- pred main(io__state, io__state).
+:- mode main(di, uo) is det.
+
+:- implementation.
+
+:- import_module std_util, list, int, float.
+
+:- type tree(K, V)
+ ---> leaf
+ ; node(tree(K, V), K, V, tree(K, V)).
+
+main(!IO) :-
+ static(IntList, StringList, Tree),
+ dynamic(IntList, DoubleIntList, FloatList, PairList, UnivList, Univ),
+ io__write(IntList, !IO),
+ io__nl(!IO),
+ io__write(StringList, !IO),
+ io__nl(!IO),
+ io__write(Tree, !IO),
+ io__nl(!IO),
+ io__write(DoubleIntList, !IO),
+ io__nl(!IO),
+ io__write(FloatList, !IO),
+ io__nl(!IO),
+ io__write(PairList, !IO),
+ io__nl(!IO),
+ io__write(UnivList, !IO),
+ io__nl(!IO),
+ io__write(Univ, !IO),
+ io__nl(!IO).
+
+% Return some static terms.
+
+:- pred static(list(int)::out, list(string)::out, tree(string, int)::out)
+ is det.
+
+static(IntList, StringList, Tree) :-
+ IntList = [1,2,3],
+ StringList = ["a", "bb", "ccc"],
+ Tree = node(leaf, "one", 1, node(leaf, "two", 2, leaf)).
+
+% Return some dynamic terms.
+
+:- pred dynamic(list(int)::in, list(int)::out, list(float)::out,
+ list(pair(int, float))::out, list(univ)::out, univ::out) is det.
+
+dynamic(IntList, DoubleIntList, FloatList, PairList, UnivList, Univ) :-
+ list__append(IntList, IntList, DoubleIntList),
+ FloatList = list__map(float, IntList),
+ PairList = list__map(pair_float, IntList),
+ UnivList = list__map(convert_type_to_univ, IntList),
+ Univ = convert_type_to_univ(
+ node(node(leaf, 2, 2.0 - "two", leaf), 1, 1.0 - "one", leaf)).
+
+:- func pair_float(int) = pair(int, float).
+
+pair_float(Int) = Int - float(Int).
+
+:- func convert_type_to_univ(T) = univ.
+
+convert_type_to_univ(T) = Univ :-
+ type_to_univ(T, Univ).
cvs diff: Diffing tests/debugger/declarative
Index: tests/debugger/declarative/dependency.exp
===================================================================
RCS file: /home/mercury1/repository/tests/debugger/declarative/dependency.exp,v
retrieving revision 1.3
diff -u -b -r1.3 dependency.exp
--- tests/debugger/declarative/dependency.exp 17 Jan 2003 05:57:00 -0000 1.3
+++ tests/debugger/declarative/dependency.exp 31 Aug 2003 03:59:17 -0000
@@ -19,7 +19,7 @@
mdb> set depth 20
mdb> set size 201
mdb> set format pretty
-mdb> proc_body
+mdb> p proc_body
proc_rep(
[|](2, []),
Index: tests/debugger/declarative/dependency.inp
===================================================================
RCS file: /home/mercury1/repository/tests/debugger/declarative/dependency.inp,v
retrieving revision 1.1
diff -u -b -r1.1 dependency.inp
--- tests/debugger/declarative/dependency.inp 23 Apr 2002 08:52:41 -0000 1.1
+++ tests/debugger/declarative/dependency.inp 30 Aug 2003 00:27:20 -0000
@@ -9,7 +9,7 @@
set depth 20
set size 201
set format pretty
-proc_body
+p proc_body
dd
browse 1
^1
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
Index: tests/hard_coded/nondet_c.m
===================================================================
RCS file: /home/mercury1/repository/tests/hard_coded/nondet_c.m,v
retrieving revision 1.3
diff -u -b -r1.3 nondet_c.m
--- tests/hard_coded/nondet_c.m 31 Jan 2001 18:52:06 -0000 1.3
+++ tests/hard_coded/nondet_c.m 30 Aug 2003 12:23:29 -0000
@@ -79,12 +79,12 @@
MR_Word temp;
/* this code gets executed for both calls and retries */
- MR_incr_hp_atomic(temp,
+ MR_offset_incr_hp_atomic(temp, 0,
(LOCALS->count + sizeof(MR_Word)) / sizeof(MR_Word));
LeftHalf = (MR_String) temp;
memcpy(LeftHalf, LOCALS->s, LOCALS->count);
LeftHalf[LOCALS->count] = '\\0';
- MR_incr_hp_atomic(temp,
+ MR_offset_incr_hp_atomic(temp, 0,
(LOCALS->len - LOCALS->count + sizeof(MR_Word))
/ sizeof(MR_Word));
RightHalf = (MR_String) temp;
@@ -122,12 +122,12 @@
MR_Word temp;
/* this code gets executed for both calls and retries */
- MR_incr_hp_atomic(temp,
+ MR_offset_incr_hp_atomic(temp, 0,
(LOCALS->count + sizeof(MR_Word)) / sizeof(MR_Word));
LeftHalf = (MR_String) temp;
memcpy(LeftHalf, LOCALS->s, LOCALS->count);
LeftHalf[LOCALS->count] = '\\0';
- MR_incr_hp_atomic(temp,
+ MR_offset_incr_hp_atomic(temp, 0,
(LOCALS->len - LOCALS->count + sizeof(MR_Word))
/ sizeof(MR_Word));
RightHalf = (MR_String) temp;
@@ -165,12 +165,12 @@
MR_Word temp;
/* this code gets executed for both calls and retries */
- MR_incr_hp_atomic(temp,
+ MR_offset_incr_hp_atomic(temp, 0,
(LOCALS->count + sizeof(MR_Word)) / sizeof(MR_Word));
LeftHalf = (MR_String) temp;
memcpy(LeftHalf, LOCALS->s, LOCALS->count);
LeftHalf[LOCALS->count] = '\\0';
- MR_incr_hp_atomic(temp,
+ MR_offset_incr_hp_atomic(temp, 0,
(LOCALS->len - LOCALS->count + sizeof(MR_Word))
/ sizeof(MR_Word));
RightHalf = (MR_String) temp;
Index: tests/hard_coded/pragma_inline.m
===================================================================
RCS file: /home/mercury1/repository/tests/hard_coded/pragma_inline.m,v
retrieving revision 1.9
diff -u -b -r1.9 pragma_inline.m
--- tests/hard_coded/pragma_inline.m 28 Nov 2002 16:33:45 -0000 1.9
+++ tests/hard_coded/pragma_inline.m 27 Aug 2003 12:38:29 -0000
@@ -43,7 +43,7 @@
MR_Word tmp;
len_1 = strlen(S1);
len_2 = strlen(S2);
- MR_incr_hp_atomic(tmp, (len_1 + len_2 + sizeof(MR_Word))
+ MR_offset_incr_hp_atomic(tmp, 0, (len_1 + len_2 + sizeof(MR_Word))
/ sizeof(MR_Word));
S3 = (char *) tmp;
strcpy(S3, S1);
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
Index: tests/valid/Mmakefile
===================================================================
RCS file: /home/mercury1/repository/tests/valid/Mmakefile,v
retrieving revision 1.130
diff -u -b -r1.130 Mmakefile
--- tests/valid/Mmakefile 25 Jul 2003 02:27:37 -0000 1.130
+++ tests/valid/Mmakefile 27 Aug 2003 12:35:53 -0000
@@ -242,7 +242,8 @@
# Aditi is not yet implemented for the MLDS back-end
# (i.e. grades hl* java* il*).
-# It will never be implemented for deep profiling grades.
+# It will never be implemented for deep profiling and
+# term size profiling grades.
ifneq "$(filter hl% java% il%,$(GRADE))$(findstring profdeep,$(GRADE))" ""
# We currently don't do any testing in grade java on this directory.
ifneq "$(findstring java,$(GRADE))$" ""
@@ -257,10 +258,18 @@
ifneq "$(findstring profdeep,$(GRADE))$(findstring java,$(GRADE))" ""
ALL_RLO_PROGS =
else
+ ifneq "$(findstring tsw,$(GRADE))$(findstring tsc,$(GRADE))" ""
+ ALL_RLO_PROGS =
+ else
ALL_RLO_PROGS = $(RLO_PROGS)
+ endif
endif
-PROGS = $(OBJ_PROGS) $(ALL_RLO_PROGS) $(IL_PROGS)
+ifneq "$(findstring tsw,$(GRADE))$(findstring tsc,$(GRADE))" ""
+ PROGS = $(OBJ_PROGS) $(ALL_RLO_PROGS)
+else
+ PROGS = $(OBJ_PROGS) $(ALL_RLO_PROGS) $(IL_PROGS)
+endif
# `mmc --make' doesn't expect subdirectories to appear in targets.
ifeq ($(MMAKE_USE_MMC_MAKE),yes)
cvs diff: Diffing tests/warnings
cvs diff: Diffing tools
cvs diff: Diffing trace
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.70
diff -u -b -r1.70 mercury_trace_external.c
--- trace/mercury_trace_external.c 12 Jun 2003 15:38:36 -0000 1.70
+++ trace/mercury_trace_external.c 12 Jun 2003 16:11:41 -0000
@@ -1135,7 +1135,7 @@
);
MR_TRACE_USE_HP(
- var_list = MR_list_cons(univ, var_list);
+ var_list = MR_univ_list_cons(univ, var_list);
);
}
@@ -1173,7 +1173,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);
);
}
@@ -1215,8 +1215,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);
);
}
@@ -1473,16 +1473,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.
@@ -1545,7 +1544,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.158
diff -u -b -r1.158 mercury_trace_internal.c
--- trace/mercury_trace_internal.c 12 Jun 2003 15:38:36 -0000 1.158
+++ trace/mercury_trace_internal.c 27 Aug 2003 11:39:15 -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;
@@ -590,6 +591,9 @@
static const char *MR_trace_browse_exception(MR_Event_Info *event_info,
MR_Browser browser, MR_Browse_Caller_Type caller,
MR_Browse_Format format);
+static const char *MR_trace_browse_proc_body(MR_Event_Info *event_info,
+ MR_Browser browser, MR_Browse_Caller_Type caller,
+ MR_Browse_Format format);
static const char *MR_trace_read_help_text(void);
static const char *MR_trace_parse_line(char *line,
@@ -1201,7 +1205,24 @@
MR_unravel_univ(exception, type_info, value);
- (*browser)((MR_Word)type_info, value, caller, format);
+ (*browser)((MR_Word) type_info, value, caller, format);
+
+ return (const char *) NULL;
+}
+
+static const char *
+MR_trace_browse_proc_body(MR_Event_Info *event_info, MR_Browser browser,
+ MR_Browse_Caller_Type caller, MR_Browse_Format format)
+{
+ const MR_Proc_Layout *entry;
+
+ entry = event_info->MR_event_sll->MR_sll_entry;
+ if (entry->MR_sle_proc_rep == NULL) {
+ return "current procedure has no body info";
+ }
+
+ (*browser)(ML_proc_rep_type(), (MR_Word) entry->MR_sle_proc_rep,
+ caller, format);
return (const char *) NULL;
}
@@ -1914,9 +1935,13 @@
problem = MR_trace_browse_exception(event_info,
MR_trace_browse_internal,
MR_BROWSE_CALLER_PRINT, format);
+ } else if (MR_streq(words[1], "proc_body")) {
+ problem = MR_trace_browse_proc_body(event_info,
+ MR_trace_browse_internal,
+ 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);
}
@@ -1979,9 +2004,13 @@
problem = MR_trace_browse_exception(event_info,
MR_trace_browse_internal,
MR_BROWSE_CALLER_BROWSE, format);
+ } else if (MR_streq(words[1], "proc_body")) {
+ problem = MR_trace_browse_proc_body(event_info,
+ 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);
}
@@ -3182,6 +3211,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)
@@ -3678,28 +3735,6 @@
}
static MR_Next
-MR_trace_cmd_proc_body(char **words, int word_count, MR_Trace_Cmd_Info *cmd,
- MR_Event_Info *event_info, MR_Event_Details *event_details,
- MR_Code **jumpaddr)
-{
- const MR_Proc_Layout *entry;
-
- entry = event_info->MR_event_sll->MR_sll_entry;
- if (entry->MR_sle_proc_rep == NULL) {
- fprintf(MR_mdb_out,
- "current procedure has no body info\n");
- } else {
- MR_trace_browse_internal(
- ML_proc_rep_type(),
- (MR_Word) entry->MR_sle_proc_rep,
- MR_BROWSE_CALLER_PRINT,
- MR_BROWSE_DEFAULT_FORMAT);
- }
-
- return KEEP_INTERACTING;
-}
-
-static MR_Next
MR_trace_cmd_print_optionals(char **words, int word_count,
MR_Trace_Cmd_Info *cmd, MR_Event_Info *event_info,
MR_Event_Details *event_details, MR_Code **jumpaddr)
@@ -6371,6 +6406,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,
@@ -6393,8 +6430,6 @@
NULL, MR_trace_filename_completer },
{ "developer", "label_stats", MR_trace_cmd_label_stats,
NULL, MR_trace_filename_completer },
- { "developer", "proc_body", MR_trace_cmd_proc_body,
- NULL, MR_trace_null_completer },
{ "developer", "print_optionals", MR_trace_cmd_print_optionals,
MR_trace_on_off_args, MR_trace_null_completer },
{ "developer", "unhide_events", MR_trace_cmd_unhide_events,
Index: trace/mercury_trace_vars.c
===================================================================
RCS file: /home/mercury1/repository/mercury/trace/mercury_trace_vars.c,v
retrieving revision 1.54
diff -u -b -r1.54 mercury_trace_vars.c
--- trace/mercury_trace_vars.c 4 Sep 2003 11:08:49 -0000 1.54
+++ trace/mercury_trace_vars.c 30 Sep 2003 17:41:03 -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);
@@ -741,6 +747,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)
@@ -749,75 +798,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);
}
);
@@ -852,8 +887,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;
@@ -894,76 +929,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) {
@@ -972,8 +975,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++;
@@ -987,18 +990,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
@@ -1035,7 +1095,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);
}
@@ -1059,8 +1119,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;
@@ -1126,7 +1186,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.
@@ -1154,6 +1218,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)
{
@@ -1266,9 +1395,16 @@
** closely by a call or an exit, this should be sufficient to catch
** most misconstructed terms.
*/
- (void) MR_trace_browse_var(stdout, &MR_point.MR_point_vars[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);
+
+ /*
+ ** Looking up the term size can lead to a crash if the term has a
+ ** memory cell that should have but doesn't have a size slot.
+ */
+ (void) MR_term_size(MR_point.MR_point_vars[i].MR_var_type,
+ MR_point.MR_point_vars[i].MR_var_value);
}
}
@@ -1307,8 +1443,8 @@
#if 0
/* enable this code if necessary for debugging */
fprintf(stdout, "%s", buf);
-#endif
fflush(stdout);
+#endif
MR_trace_check_integrity_on_cur_level();
level++;
problem = MR_trace_set_level(level, MR_TRUE);
Index: trace/mercury_trace_vars.h
===================================================================
RCS file: /home/mercury1/repository/mercury/trace/mercury_trace_vars.h,v
retrieving revision 1.22
diff -u -b -r1.22 mercury_trace_vars.h
--- trace/mercury_trace_vars.h 12 Jun 2003 15:38:37 -0000 1.22
+++ trace/mercury_trace_vars.h 12 Jun 2003 16:11:42 -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);
@@ -224,6 +234,21 @@
const MR_Label_Layout *level_layout,
MR_Word *base_sp, MR_Word *base_curfr,
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
cvs diff: Diffing util
Index: util/mkinit.c
===================================================================
RCS file: /home/mercury1/repository/mercury/util/mkinit.c,v
retrieving revision 1.91
diff -u -b -r1.91 mkinit.c
--- util/mkinit.c 23 Aug 2003 13:31:05 -0000 1.91
+++ util/mkinit.c 25 Aug 2003 04:43:30 -0000
@@ -288,6 +288,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