mercurylang/mercury
1
0
Fork 0
mirror of https://github.com/Mercury-Language/mercury.git synced 2025-12-09 02:43:21 +00:00
Code Issues Projects Releases Wiki Activity
Files
026148c907be6be23f45cf69862d1fcfc2b7e947
mercury/runtime/mercury_deep_copy_body.h
Zoltan Somogyi 86f563a94d Pack subword-sized arguments next to a remote sectag. 
compiler/du_type_layout.m:
    If the --allow-packing-remote-sectag option is set, then try to pack
    an initial subsequence of subword-sized arguments next to remote sectags.

    To allow the polymorphism transformation to put the type_infos and/or
    typeclass_infos it adds to a function symbol's argument list at the
    *front* of that argument list, pack arguments next to remote sectags
    only in function symbols that won't have any such extra arguments
    added to them.

    Do not write all new code for the new optimization; instead, generalize
    the code that already does a very similar job for packing args next to
    local sectags.

    Delete the code we used to have that picked the packed representation
    over the base unpacked representation only if it reduced the
    "rounded-to-even" number of words. A case could be made for its usefulness,
    but in the presence of the new optimization the extra code complexity
    it requires is not worth it (in my opinion).

    Extend the code that informs users about possible argument order
    rearrangements that yield better packing to take packing next to sectags
    into account.

compiler/hlds_data.m:
    Provide a representation for cons_tags that use the new optimization.
    Instead of adding a new cons_tag, we do this by replacing several old
    cons_tags that all represent pointers to memory cells with a single
    cons_tag named remote_args_tag with an argument that selects among
    the old cons_tags being replaced, and adding a new alternative inside
    this new type. The new alternative is remote_args_shared with a
    remote_sectag whose size is rsectag_subword(...).

    Instead of representing the value of the "data" field in classes
    on the Java and C# backends as a strange kind of secondary tag
    that is added to a memory cell by a class constructor instead of
    having to be explicitly added to the front of the argument vector
    by the code of a unification, represent it more directly as separate
    kind of remote_args_tag. Continuing to treat it as a sectag would have
    been very confusing to readers of the code of ml_unify_gen_*.m in the
    presence of the new optimization.

    Replacing several cons_tags that were usually treated similarly with
    one cons_tag simplifies many switches. Instead of an switch with that
    branches to the same switch arm for single_functor_tag, unshared_tag
    and shared_remote_tag, and then switches on these three tags again
    to get e.g. the primary tag of each, the new code of the switch arm
    is executed for just cons_tag value (remote_args_tag), and switches
    on the various kinds of remote args tags only when it needs to.
    In is also more natural to pass around the argument of remote_args_tag
    than to pass around a variable of type cons_tag that can be bound to only
    single_functor_tag, unshared_tag or shared_remote_tag.

    Add an XXX about possible further steps along these lines, such as
    making a new cons_tag named something like "user_const_tag" represent
    all user-visible constants.

compiler/unify_gen_construct.m:
compiler/unify_gen_deconstruct.m:
compiler/unify_gen_test.m:
compiler/unify_gen_util.m:
compiler/ml_unify_gen_construct.m:
compiler/ml_unify_gen_deconstruct.m:
compiler/ml_unify_gen_test.m:
compiler/ml_unify_gen_util.m:
    Implement X = f(Yi) unifications where f uses the new representation,
    i.e. some of its arguments are stored next to a remote sectag.

    Some of the Yi are stored in a tagword (a word that also contains a tag,
    in this case the remote secondary tag), while some are stored in other
    words in a memory cell. This means that such unifications have similarities
    both to unifications involving arguments being packed next to local
    sectags, and to unifications involving ordinary arguments in memory cells.
    Therefore wherever possible, their implemenation uses suitably generalized
    versions of existing code that did those two jobs for two separate kinds of
    cons_tags.

    Making such generalizations possible in some cases required shifting the
    boundary between predicates, moving work from a caller to a callee
    or vice versa.

    In unify_gen_deconstruct.m, stop using uni_vals to represent *either* a var
    *or* a word in a memory cell. While this enabled us to factor out some
    common code, the predicate boundaries it lead to are unsuitable for the
    generalizations we now need.

    Consistently use unsigned ints to represent both the whole and the parts
    of words containing packed arguments (and maybe sectags), except when
    comparing ptag constants with the result of applying the "tag" unop
    to a word, (since that unop returns an int, at least for now).

    In a few cases, avoid the recomputation of some information that we
    already know. The motivation is not efficiency, since the recomputation
    we avoid is usually cheap, but the simplification of the code's correctness
    argument.

    Use more consistent terminology in things such as variable names.

    Note the possibility of further future improvements in several places.

compiler/ml_foreign_proc_gen.m:
    Delete a long unused predicate.

compiler/mlds.m:
    Add an XXX documenting a possible improvement.

compiler/rtti.m:
    Update the compiler's internal representation of RTTI data structures
    to make them able to describe secondary tags that are smaller than
    a full word.

compiler/rtti_out.m:
    Conform to the changes above, and delete a long-unused predicate.

compiler/type_ctor_info.m:
    Use the RTTI's du_hl_rep to represent cons_tags that distinguish
    between function symbols using a field in a class.

compiler/ml_type_gen.m:
    Provide a specialized form of a function for code in ml_unify_gen_*.m.
    Conform to the changes above.

compiler/add_special_pred.m:
compiler/bytecode_gen.m:
compiler/export.m:
compiler/hlds_code_util.m:
compiler/lco.m:
compiler/ml_closure_gen.m:
compiler/ml_switch_gen.m:
compiler/ml_tag_switch.m:
compiler/rtti_to_mlds.m:
compiler/switch_util.m:
compiler/tag_switch.m:
    Conform to the changes above.

runtime/mercury_type_info.h:
    Update the runtime's representation of RTTI data structures to make them
    able to describe remote secondary tags that are smaller than a full word.

runtime/mercury_deconstruct.[ch]:
runtime/mercury_deconstruct.h:
runtime/mercury_deconstruct_macros.h:
runtime/mercury_ml_expand_body.h:
runtime/mercury_ml_arg_body.h:
runtime/mercury_ml_deconstruct_body.h:
runtime/mercury_ml_functor_body.h:
    These modules collectively implement the predicates in deconstruct.m
    in the library, and provide access to its functionality to other C code,
    e.g. in the debugger. Update these to be able to handle terms with the
    new data representation optimization.

    This update requires a significant change in the distribution of work
    between these files for the predicates deconstruct.deconstruct and
    deconstruct.limited_deconstruct. We used to have mercury_ml_expand_body.h
    fill in the fields of their expand_info structures (whose types are
    defined in mercury_deconstruct.h) with pointers to three vectors:
    (a) a vector of arg_locns with one element per argument, with a NULL
    pointer being equivalent to a vector with a given element in every slot;
    (b) a vector of type_infos with one element per argument, constructed
    dynamically (and later freed) if necessary; and (c) a vector of argument
    words. Once upon a time, before double-word and sub-word arguments,
    vector (c) also had one word per argument, but that hasn't been true
    for a while; we added vector (a) help the consumers of the expand_info
    decode the difference. The consumers of this info  always used these
    vectors to build up a Mercury term containing a list of univs,
    with one univ for each argument.

    This structure could be stretched to handle function symbols that store
    *all* their arguments in a tagword next to a local sectag, but I found
    that stretching it to cover function symbols that have *some* of their
    arguments packed next to a remote sectag and *some other* of their
    arguments in a memory cell as usual would have required a well-nigh
    incomprehensibly complex, and therefore almost undebuggable, interface
    between mercury_ml_expand_body.h and the other files above. This diff
    therefore changes the interface to have mercury_ml_expand_body.h
    build the list of univs directly. This make its code relatively simple
    and self-contained, and it should be somewhat faster then the old code
    as well, since it never needs to allocate, fill in and then free
    vectors of type_infos (each such typeinfo now gets put into a univ
    as soon as it is constructed). The downside is that if we ever wanted
    to get all the arguments at once for a purpose other than constructing
    a list of univs from them, it would nevertheless require constructing
    that list of univs anyway as an intermediate data structure. I don't see
    this downside is significant, because (a) I don't think such a use case
    is very likely, and (b) even if one arises, debuggable but a bit slow
    is probably preferable to faster but very hard to debug.

    Reduce the level of indentation of some of these files to make the code
    easier to edit. Do this by

    - not adding an indent level from switch statements to their cases; and
    - not adding an indent level when a case in a switch has a local block.

    Move the break or return ending a case inside that case's block,
    if it has one.

runtime/mercury_deep_copy_body.h:
runtime/mercury_table_type_body.h:
    Update these to enable the copying or tabling of terms whose
    representations uses the new optimization.

    Use the techniques listed above to reduce the level of indentation
    make the code easier to edit.

runtime/mercury_tabling.c:
runtime/mercury_term_size.c:
    Conform to the changes above.

runtime/mercury_unify_compare_body.h:
    Make this code compile after the changes above. It does need to work
    correctly, since we only ever used this code to compare the speed
    of unify-by-rtti with the speed of unify-by-compiler-generated-code,
    and in real life, we always use the latter. (It hasn't been updated
    to work right with previous arg packing changes either.)

library/construct.m:
    Update to enable the code to construct terms whose representations
    uses the new optimization.

    Add some sanity checks.

library/private_builtin.m:
runtime/mercury_dotnet.cs.in:
java/runtime/Sectag_Locn.java:
    Update the list of possible sectag kinds.

library/store.m:
    Conform to the changes above.

trace/mercury_trace_vars.c:
    Conform to the changes above.

tests/hard_coded/deconstruct_arg.{m,exp,exp2}:
    Extend this test to test the deconstruction of terms whose
    representations uses the new optimization.

    Modify some of the existing terms being tested to make them more diverse,
    in order to make the output easier to navigate.

tests/hard_coded/construct_packed.{m,exp}:
    A new test case to test the construction of terms whose
    representations uses the new optimization.

tests/debugger/browse_packed.{m,exp}:
    A new test case to test access to the fields of terms whose
    representations uses the new optimization.

tests/tabling/test_packed.{m,exp}:
    A new test case to test the tabling of terms whose
    representations uses the new optimization.

tests/debugger/Mmakefile:
tests/hard_coded/Mmakefile:
tests/tabling/Mmakefile:
    Enable the new test cases.
2018-08-30 05:14:38 +10:00

1178 lines
49 KiB
C
Raw Blame History

// vim: ts=4 sw=4 expandtab ft=c
// Copyright (C) 1997-2005, 2007, 2012 The University of Melbourne.
// Copyright (C) 2014-2018 The Mercury team.
// This file is distributed under the terms specified in COPYING.LIB.
// The internals of deep copy.
//
// Functions such as "copy", "copy_arg", "copy_type_info", "in_range",
// etc can be #defined to whatever functions are needed for a particular
// copying application.
// Prototypes.
static MR_Word copy_arg(const MR_Word *parent_data_ptr,
MR_Word data,
const MR_DuFunctorDesc *functor_descriptor,
const MR_TypeInfoParams type_params,
const MR_PseudoTypeInfo arg_pseudotype_info,
const MR_Word *lower_limit,
const MR_Word *upper_limit);
static MR_TypeInfo copy_type_info(MR_TypeInfo type_info,
const MR_Word *lower_limit,
const MR_Word *upper_limit);
static MR_PseudoTypeInfo copy_pseudo_type_info(
MR_PseudoTypeInfo pseudo_type_info,
const MR_Word *lower_limit,
const MR_Word *upper_limit);
static MR_Word copy_typeclass_info(MR_Word typeclass_info,
const MR_Word *lower_limit,
const MR_Word *upper_limit);
#ifdef MR_MPROF_PROFILE_MEMORY_ATTRIBUTION
static MR_AllocSiteInfoPtr maybe_attrib(MR_Word *data_value);
#else
#define maybe_attrib(x) NULL
#endif
// We need to make sure that we don't clobber any part of the closure
// which might be used by the collector for tracing stack frames of
// closure wrapper functions. So we store the forwarding pointer for closure
// in the MR_closure_code field (which is not used by the collector),
// rather than at offset zero (where it would clobber the closure layout,
// which is used by the collector).
#define CLOSURE_FORWARDING_PTR_OFFSET \
(offsetof(MR_Closure, MR_closure_code) / sizeof(MR_Word))
// We must not clobber type_infos or typeclass_infos with forwarding pointers,
// since they may be referenced by the garbage collector during collection.
// Unfortunately in this case there is no spare field which we can use.
// So we allocate an extra word before the front of the object (see the code
// for new_object in compiler/mlds_to_c.m), and use that for the forwarding
// pointer. Hence the offsets here are -1, meaning one word before the start
// of the object.
#define TYPEINFO_FORWARDING_PTR_OFFSET -1
#define TYPECLASSINFO_FORWARDING_PTR_OFFSET -1
// RETURN_IF_OUT_OF_RANGE(MR_Word tagged_pointer, MR_Word *pointer,
// int forwarding_pointer_offset, rettype):
//
// Check if `pointer' is either out of range, or has already been processed,
// and if so, return (from the function that called this macro) with the
// appropriate value.
//
// If the pointer is out of range, we return the original tagged pointer
// value unchanged. If the pointer has already been processed, then return
// the forwarding pointer that was saved in the object, which will be stored
// at pointer[forwarding_pointer_offset].
#define RETURN_IF_OUT_OF_RANGE(tagged_pointer, pointer, offset, rettype) \
do { \
if (!in_range(pointer)) { \
found_out_of_range_pointer(pointer); \
return (rettype) (tagged_pointer); \
} \
if_forwarding_pointer((pointer), \
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)
{
MR_Word new_data;
MR_TypeCtorInfo type_ctor_info;
MR_DuTypeLayout du_type_layout;
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_STRINGIFY(copy) ": term of unknown representation");
}
switch (MR_type_ctor_rep(type_ctor_info)) {
case MR_TYPECTOR_REP_ENUM:
case MR_TYPECTOR_REP_ENUM_USEREQ:
case MR_TYPECTOR_REP_FOREIGN_ENUM:
case MR_TYPECTOR_REP_FOREIGN_ENUM_USEREQ:
return data; // Just a copy of the actual item.
case MR_TYPECTOR_REP_DUMMY:
// The value we are asked to copy is a dummy, and the return value
// won't be looked at either, so what we return doesn't really matter.
return data;
case MR_TYPECTOR_REP_DU:
case MR_TYPECTOR_REP_DU_USEREQ:
{
MR_Word *data_value;
const MR_DuPtagLayout *ptag_layout;
int ptag;
int sectag_word;
int sectag;
du_type_layout = MR_type_ctor_layout(type_ctor_info).MR_layout_du;
ptag = MR_tag(data);
ptag_layout = &du_type_layout[ptag];
switch (ptag_layout->MR_sectag_locn) {
case MR_SECTAG_LOCAL_REST_OF_WORD: // fall-through
case MR_SECTAG_LOCAL_BITS:
return data; // Just a copy of the actual item.
// case MR_SECTAG_REMOTE_FULL_WORD:
// case MR_SECTAG_REMOTE_BITS:
// case MR_SECTAG_NONE:
// case MR_SECTAG_NONE_DIRECT_ARG:
// The code we want to execute for the MR_SECTAG_REMOTE_*
// and MR_SECTAG_NONE cases is very similar. However,
// speed is important here, and we don't want to check
// the secondary tag location multiple times at run-time.
// So we define the code for these two cases as a macro,
// `MR_handle_sectag_remote_or_none(have_sectag)',
// and invoke it twice below, with constant values for the
// `have_sectag' argument. This ensures that the C
// preprocessor will duplicate the code and the C compiler
// will then optimize away the tests at compile time.
//
// Likewise, we are careful to avoid testing
// `exist_info != NULL' multiple times at run-time.
// This requires two copies of the MR_maybe_copy_sectag_word()
// code, which is why we define that as a macro too.
#define MR_maybe_copy_sectag_word(have_sectag, tagword, new_data, cur_slot) \
do { \
/* This `if' will get evaluated at compile time. */ \
if (have_sectag) { \
MR_field(0, new_data, 0) = tagword; \
cur_slot = 1; \
} else { \
cur_slot = 0; \
} \
} while (0)
#define MR_copy_full_word_arg(fdesc, argnum, pdp, dv, nd, slot, lo, hi) \
do { \
if (MR_arg_type_may_contain_var(fdesc, argnum)) { \
MR_field(0, nd, slot) = \
copy_arg(pdp, dv[slot], fdesc, \
MR_TYPEINFO_GET_FIXED_ARITY_ARG_VECTOR(type_info), \
fdesc->MR_du_functor_arg_types[argnum], lo, hi); \
} else { \
MR_field(0, nd, slot) = \
copy(dv[slot], MR_pseudo_type_info_is_ground( \
fdesc->MR_du_functor_arg_types[argnum]), lo, hi); \
} \
} while (0)
#define MR_handle_sectag_remote_or_none(have_sectag, sectag_word, sectag) \
do { \
const MR_DuFunctorDesc *functor_desc; \
const MR_DuArgLocn *arg_locns; \
const MR_DuExistInfo *exist_info; \
MR_AllocSiteInfoPtr attrib; \
MR_Word *parent_data_ptr; \
int cell_size; \
int cur_slot; \
int arity; \
int i; \
\
/* This `if' will get evaluated at compile time. */ \
if (have_sectag) { \
cell_size = 1; \
} else { \
cell_size = 0; \
} \
\
functor_desc = ptag_layout->MR_sectag_alternatives[sectag]; \
arity = functor_desc->MR_du_functor_orig_arity; \
arg_locns = functor_desc->MR_du_functor_arg_locns; \
exist_info = functor_desc->MR_du_functor_exist_info; \
\
cell_size += MR_cell_size_for_args(arity, arg_locns); \
cell_size += MR_SIZE_SLOT_SIZE; \
\
if (exist_info == NULL) { \
attrib = maybe_attrib(data_value); \
MR_offset_incr_saved_hp(new_data, MR_SIZE_SLOT_SIZE, \
cell_size, attrib, NULL); \
\
MR_copy_size_slot(0, new_data, ptag, data); \
MR_maybe_copy_sectag_word(have_sectag, sectag_word, new_data, \
cur_slot); \
} else { \
int num_ti_plain; \
int num_tci; \
\
num_ti_plain = exist_info->MR_exist_typeinfos_plain; \
num_tci = exist_info->MR_exist_tcis; \
cell_size += num_ti_plain + num_tci; \
\
attrib = maybe_attrib(data_value); \
MR_offset_incr_saved_hp(new_data, MR_SIZE_SLOT_SIZE, \
cell_size, attrib, NULL); \
\
MR_copy_size_slot(0, new_data, ptag, data); \
MR_maybe_copy_sectag_word(have_sectag, sectag_word, new_data, \
cur_slot); \
\
for (i = 0; i < num_ti_plain; i++) { \
MR_field(0, new_data, cur_slot) = (MR_Word) \
copy_type_info((MR_TypeInfo) data_value[cur_slot], \
lower_limit, upper_limit); \
cur_slot++; \
} \
\
for (i = 0; i < num_tci; i++) { \
MR_field(0, new_data, cur_slot) = (MR_Word) \
copy_typeclass_info(data_value[cur_slot], \
lower_limit, upper_limit); \
cur_slot++; \
} \
} \
\
/* This `if' will get evaluated at compile time. */ \
if (have_sectag) { \
parent_data_ptr = ((MR_Word *) new_data) + 1; \
} else { \
parent_data_ptr = (MR_Word *) new_data; \
} \
\
if (arg_locns == NULL) { \
for (i = 0; i < arity; i++) { \
MR_copy_full_word_arg(functor_desc, i, \
parent_data_ptr, data_value, new_data, cur_slot, \
lower_limit, upper_limit); \
cur_slot++; \
} \
} else { \
for (i = 0; i < arity; i++) { \
/* \
** The meanings of the various special values of \
** MR_arg_{offset,bits} are documented next to the \
** the MR_DuArgLocn type in mercury_type_info.h. \
*/ \
\
if (arg_locns[i].MR_arg_offset == -1) { \
/* \
** This argument is part of the tagword, \
** and therefore it has already been copied by \
** MR_maybe_copy_sectag_word. \
*/ \
continue; \
} \
\
if (arg_locns[i].MR_arg_bits == 0) { \
MR_copy_full_word_arg(functor_desc, i, \
parent_data_ptr, data_value, new_data, cur_slot, \
lower_limit, upper_limit); \
cur_slot++; \
} else if (arg_locns[i].MR_arg_bits > 0) { \
/* \
** Copy words holding packed arguments \
** when we encounter the first one. \
** Args packed next to a remote sectag will never \
** be at offset zero, but that is ok, since they \
** are copied together with the sectag itself. \
** (The first packed argument is an enum.) \
*/ \
if (arg_locns[i].MR_arg_shift == 0) { \
MR_field(0, new_data, cur_slot) = \
data_value[cur_slot]; \
cur_slot++; \
} \
} else if (arg_locns[i].MR_arg_bits >= -3) { \
/* Double precision float, int64 or uint64. */ \
MR_field(0, new_data, cur_slot) = \
data_value[cur_slot]; \
MR_field(0, new_data, cur_slot + 1) = \
data_value[cur_slot + 1]; \
cur_slot += 2; \
} else if (arg_locns[i].MR_arg_bits >= -9) { \
/* \
** Copy words holding packed arguments \
** when we encounter the first one. \
** Args packed next to a remote sectag will never \
** be at offset zero, but that is ok, since they \
** are copied together with the sectag itself. \
** (The first packed argument is a small int.) \
*/ \
if (arg_locns[i].MR_arg_shift == 0) { \
MR_field(0, new_data, cur_slot) = \
data_value[cur_slot]; \
cur_slot++; \
} \
} else if (arg_locns[i].MR_arg_bits == -10) { \
/* Dummy argument; occupies zero bits. */ \
continue; \
} else { \
MR_fatal_error("MR_arg_bits < -10"); \
} \
} \
} \
\
new_data = (MR_Word) MR_mkword(ptag, new_data); \
leave_forwarding_pointer(data_value, 0, new_data); \
} while (0)
case MR_SECTAG_REMOTE_FULL_WORD:
// See comments above.
data_value = (MR_Word *) MR_body(data, ptag);
RETURN_IF_OUT_OF_RANGE(data, data_value, 0, MR_Word);
sectag_word = data_value[0];
sectag = sectag_word;
MR_handle_sectag_remote_or_none(MR_TRUE, sectag_word, sectag);
return new_data;
case MR_SECTAG_REMOTE_BITS:
// See comments above.
data_value = (MR_Word *) MR_body(data, ptag);
RETURN_IF_OUT_OF_RANGE(data, data_value, 0, MR_Word);
sectag_word = data_value[0];
sectag = sectag_word &
// XXX ARG_PACK
// Consider storing this mask in the ptag_layout.
((1 << ptag_layout->MR_sectag_numbits) - 1);
MR_handle_sectag_remote_or_none(MR_TRUE, sectag_word, sectag);
return new_data;
case MR_SECTAG_NONE:
// See comments above.
data_value = (MR_Word *) MR_body(data, ptag);
RETURN_IF_OUT_OF_RANGE(data, data_value, 0, MR_Word);
sectag_word = 0; // dummy; won't be used
sectag = 0; // dummy; won't be used
MR_handle_sectag_remote_or_none(MR_FALSE, sectag_word, sectag);
return new_data;
case MR_SECTAG_NONE_DIRECT_ARG:
// This code is a cut-down and specialized version
// of the code for MR_SECTAG_NONE.
data_value = (MR_Word *) MR_body(data, ptag);
RETURN_IF_OUT_OF_RANGE(data, data_value, 0, MR_Word);
{
const MR_DuFunctorDesc *functor_desc;
const MR_DuArgLocn *arg_locns;
const MR_DuExistInfo *exist_info;
int arity;
functor_desc = ptag_layout->MR_sectag_alternatives[0];
arity = functor_desc->MR_du_functor_orig_arity;
arg_locns = functor_desc->MR_du_functor_arg_locns;
exist_info = functor_desc->MR_du_functor_exist_info;
if (arity != 1) {
MR_fatal_error("arity != 1 in direct arg tag functor");
}
if (arg_locns != NULL) {
MR_fatal_error("arg_locns in direct arg tag functor");
}
if (exist_info != NULL) {
MR_fatal_error("exist_info in direct arg tag functor");
}
new_data = copy((MR_Word) data_value,
MR_pseudo_type_info_is_ground(
functor_desc->MR_du_functor_arg_types[0]),
lower_limit, upper_limit);
new_data = (MR_Word) MR_mkword(ptag, new_data);
// We cannot (and shouldn't need to) leave a forwarding
// pointer for the whole term that is separate from the
// forwarding pointer for the argument.
}
return new_data;
case MR_SECTAG_VARIABLE:
MR_fatal_error("copy(): attempt to copy variable");
default:
MR_fatal_error("copy(): unknown sectag_locn");
} // end switch on sectag_locn
break;
}
case MR_TYPECTOR_REP_NOTAG: // fallthru
case MR_TYPECTOR_REP_NOTAG_USEREQ:
return copy_arg(NULL, data, NULL,
MR_TYPEINFO_GET_FIXED_ARITY_ARG_VECTOR(type_info),
MR_type_ctor_layout(type_ctor_info).MR_layout_notag->
MR_notag_functor_arg_type, lower_limit, upper_limit);
case MR_TYPECTOR_REP_NOTAG_GROUND: // fallthru
case MR_TYPECTOR_REP_NOTAG_GROUND_USEREQ:
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_EQUIV:
return copy_arg(NULL, data, NULL,
MR_TYPEINFO_GET_FIXED_ARITY_ARG_VECTOR(type_info),
MR_type_ctor_layout(type_ctor_info).MR_layout_equiv,
lower_limit, upper_limit);
case MR_TYPECTOR_REP_EQUIV_GROUND:
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_INT: // fallthru
case MR_TYPECTOR_REP_UINT: // fallthru
case MR_TYPECTOR_REP_INT8: // fallthru
case MR_TYPECTOR_REP_UINT8: // fallthru
case MR_TYPECTOR_REP_INT16: // fallthru
case MR_TYPECTOR_REP_UINT16: // fallthru
case MR_TYPECTOR_REP_INT32: // fallthru
case MR_TYPECTOR_REP_UINT32: // fallthru
case MR_TYPECTOR_REP_CHAR:
return data;
case MR_TYPECTOR_REP_INT64:
{
#if defined(MR_BOXED_INT64S)
MR_Word *data_value;
assert(MR_tag(data) == 0);
data_value = (MR_Word *) MR_body(data, MR_mktag(0));
RETURN_IF_OUT_OF_RANGE(data, data_value, 0, MR_Word);
MR_restore_transient_hp();
#ifdef MR_HIGHLEVEL_CODE
// We can't use MR_int64_to_word, since it uses MR_hp,
// which in grade hlc.par.gc will be a reference to
// thread-local storage that we haven't allocated.
new_data = (MR_Word) MR_box_int64(MR_unbox_int64(data));
#else
new_data = MR_int64_to_word(MR_word_to_int64(data));
#endif
MR_save_transient_hp();
leave_forwarding_pointer(data_value, 0, new_data);
#else
new_data = data;
#endif
return new_data;
}
case MR_TYPECTOR_REP_UINT64:
{
#if defined(MR_BOXED_INT64S)
MR_Word *data_value;
assert(MR_tag(data) == 0);
data_value = (MR_Word *) MR_body(data, MR_mktag(0));
RETURN_IF_OUT_OF_RANGE(data, data_value, 0, MR_Word);
MR_restore_transient_hp();
#ifdef MR_HIGHLEVEL_CODE
// We can't use MR_uint64_to_word, since it uses MR_hp,
// which in grade hlc.par.gc will be a reference to
// thread-local storage that we haven't allocated.
new_data = (MR_Word) MR_box_uint64(MR_unbox_uint64(data));
#else
new_data = MR_uint64_to_word(MR_word_to_uint64(data));
#endif
MR_save_transient_hp();
leave_forwarding_pointer(data_value, 0, new_data);
#else
new_data = data;
#endif
return new_data;
}
case MR_TYPECTOR_REP_FLOAT:
{
#ifdef MR_BOXED_FLOAT
MR_Word *data_value;
assert(MR_tag(data) == 0);
data_value = (MR_Word *) MR_body(data, MR_mktag(0));
RETURN_IF_OUT_OF_RANGE(data, data_value, 0, MR_Word);
MR_restore_transient_hp();
#ifdef MR_HIGHLEVEL_CODE
// We can't use MR_float_to_word, since it uses MR_hp,
// which in grade hlc.par.gc will be a reference to
// thread-local storage that we haven't allocated.
new_data = (MR_Word) MR_box_float(MR_unbox_float(data));
#else
new_data = MR_float_to_word(MR_word_to_float(data));
#endif
MR_save_transient_hp();
leave_forwarding_pointer(data_value, 0, new_data);
#else
new_data = data;
#endif
return new_data;
}
case MR_TYPECTOR_REP_STRING:
{
MR_String new_string;
MR_AllocSiteInfoPtr attrib;
// Not all Mercury strings are aligned; in particular,
// string constants containing the empty string may be
// allocated unaligned storage by the C compiler.
// So we can't do `assert(MR_tag(data) == 0)' here.
RETURN_IF_OUT_OF_RANGE(data, (MR_Word *) data, 0, MR_Word);
attrib = maybe_attrib((MR_Word *) data);
MR_make_aligned_string_copy_saved_hp(new_string, (MR_String) data,
attrib);
new_data = (MR_Word) new_string;
leave_forwarding_pointer(data, 0, new_data);
return new_data;
}
case MR_TYPECTOR_REP_FUNC: // fallthru
case MR_TYPECTOR_REP_PRED:
{
MR_Word *data_value;
MR_Unsigned num_r_args;
MR_Unsigned num_f_args;
MR_Unsigned num_args;
MR_Unsigned r_offset;
MR_Unsigned f_offset;
MR_Unsigned i;
MR_Closure *old_closure;
MR_Closure *new_closure;
MR_Word new_closure_word;
MR_Closure_Layout *closure_layout;
MR_TypeInfo *type_info_arg_vector;
MR_AllocSiteInfoPtr attrib;
assert(MR_tag(data) == 0);
data_value = (MR_Word *) MR_body(data, MR_mktag(0));
RETURN_IF_OUT_OF_RANGE(data, data_value,
CLOSURE_FORWARDING_PTR_OFFSET, MR_Word);
// Closures have the structure given by the MR_Closure type.
//
// Their type_infos have a pointer to type_ctor_info for
// pred/0 or func/0, the number of argument typeinfos,
// and then the argument typeinfos themselves.
old_closure = (MR_Closure *) data_value;
closure_layout = old_closure->MR_closure_layout;
num_r_args = MR_closure_num_hidden_r_args(old_closure);
num_f_args = MR_closure_num_hidden_f_args(old_closure);
num_args = num_r_args + num_f_args;
// Create new closure.
attrib = maybe_attrib(data_value);
MR_offset_incr_saved_hp(new_closure_word, 0, num_args + 3,
attrib, NULL);
new_closure = (MR_Closure *) new_closure_word;
// Copy the fixed fields.
new_closure->MR_closure_layout = closure_layout;
new_closure->MR_closure_code = old_closure->MR_closure_code;
new_closure->MR_closure_num_hidden_args_rf =
old_closure->MR_closure_num_hidden_args_rf;
// Fill in the pseudo_typeinfos in the closure layout
// with the values from the closure.
type_info_arg_vector = MR_materialize_closure_type_params(old_closure);
// Copy the arguments.
r_offset = 0;
f_offset = num_r_args;
for (i = 0; i < num_args; i++) {
MR_PseudoTypeInfo arg_pti;
MR_Unsigned offset;
arg_pti = closure_layout->MR_closure_arg_pseudo_type_info[i];
#ifdef MR_MAY_REORDER_CLOSURE_HIDDEN_ARGS
if (MR_unify_pseudo_type_info_float(arg_pti)) {
offset = f_offset++;
} else {
offset = r_offset++;
}
#else
offset = i;
#endif
new_closure->MR_closure_hidden_args_0[offset] =
copy_arg(NULL, old_closure->MR_closure_hidden_args_0[offset],
NULL, type_info_arg_vector, arg_pti,
lower_limit, upper_limit);
}
if (type_info_arg_vector != NULL) {
MR_free(type_info_arg_vector);
}
new_data = (MR_Word) new_closure;
leave_forwarding_pointer(data, CLOSURE_FORWARDING_PTR_OFFSET,
new_data);
return new_data;
}
case MR_TYPECTOR_REP_TUPLE:
{
MR_Word *data_value;
MR_Word *new_data_ptr;
MR_TypeInfo *arg_typeinfo_vector;
MR_AllocSiteInfoPtr attrib;
int arity;
int i;
assert(MR_tag(data) == 0);
data_value = (MR_Word *) MR_body(data, MR_mktag(0));
RETURN_IF_OUT_OF_RANGE(data, data_value, 0, MR_Word);
arity = MR_TYPEINFO_GET_VAR_ARITY_ARITY(type_info);
if (arity == 0) {
new_data = (MR_Word) NULL;
} else {
// Allocate space for the new tuple.
attrib = maybe_attrib(data_value);
MR_offset_incr_saved_hp(new_data, MR_SIZE_SLOT_SIZE,
MR_SIZE_SLOT_SIZE + arity, attrib, NULL);
MR_copy_size_slot(0, new_data, 0, data);
new_data_ptr = (MR_Word *) new_data;
arg_typeinfo_vector =
MR_TYPEINFO_GET_VAR_ARITY_ARG_VECTOR(type_info);
for (i = 0; i < arity; i++) {
// Type_infos are counted from one.
new_data_ptr[i] = copy(data_value[i],
(const MR_TypeInfo) arg_typeinfo_vector[i + 1],
lower_limit, upper_limit);
}
leave_forwarding_pointer(data, 0, new_data);
}
return new_data;
}
case MR_TYPECTOR_REP_SUBGOAL:
MR_fatal_error("Cannot copy a subgoal type");
case MR_TYPECTOR_REP_VOID:
MR_fatal_error("Cannot copy a void type");
case MR_TYPECTOR_REP_ARRAY:
{
MR_Word *data_value;
MR_ArrayType *new_array;
MR_ArrayType *old_array;
MR_Integer array_size;
MR_AllocSiteInfoPtr attrib;
int i;
assert(MR_tag(data) == 0);
data_value = (MR_Word *) MR_body(data, MR_mktag(0));
RETURN_IF_OUT_OF_RANGE(data, data_value, 0, MR_Word);
old_array = (MR_ArrayType *) data_value;
array_size = old_array->size;
attrib = maybe_attrib(data_value);
MR_offset_incr_saved_hp(new_data, 0, array_size + 1, attrib, NULL);
new_array = (MR_ArrayType *) new_data;
new_array->size = array_size;
for (i = 0; i < array_size; i++) {
new_array->elements[i] = copy_arg(NULL, old_array->elements[i],
NULL, MR_TYPEINFO_GET_FIXED_ARITY_ARG_VECTOR(type_info),
(const MR_PseudoTypeInfo) 1, lower_limit, upper_limit);
}
leave_forwarding_pointer(data, 0, new_data);
return new_data;
}
case MR_TYPECTOR_REP_BITMAP:
{
MR_Word *data_value;
MR_BitmapPtr new_array;
MR_BitmapPtr old_array;
assert(MR_tag(data) == 0);
data_value = (MR_Word *) MR_body(data, MR_mktag(0));
RETURN_IF_OUT_OF_RANGE(data, data_value, 0, MR_Word);
old_array = (MR_BitmapPtr) data_value;
MR_allocate_bitmap_saved_hp(new_array, old_array->num_bits, NULL);
MR_copy_bitmap(new_array, old_array);
new_data = (MR_Word) new_array;
leave_forwarding_pointer(data, 0, new_data);
return new_data;
}
case MR_TYPECTOR_REP_TYPEINFO:
case MR_TYPECTOR_REP_TYPEDESC:
return (MR_Word) copy_type_info((MR_TypeInfo) data,
lower_limit, upper_limit);
case MR_TYPECTOR_REP_PSEUDOTYPEDESC:
return (MR_Word) copy_pseudo_type_info((MR_PseudoTypeInfo) data,
lower_limit, upper_limit);
case MR_TYPECTOR_REP_TYPECTORINFO:
// Type_ctor_infos are always pointers to static data.
return data;
case MR_TYPECTOR_REP_TYPECTORDESC:
// Type_ctor_descs are always either encoded integers,
// or pointers to static data.
return data;
case MR_TYPECTOR_REP_TYPECLASSINFO:
return (MR_Word) copy_typeclass_info(data,
lower_limit, upper_limit);
case MR_TYPECTOR_REP_BASETYPECLASSINFO:
// Base_typeclass_infos are always pointers to static data.
return data;
case MR_TYPECTOR_REP_STABLE_C_POINTER: // fallthru
case MR_TYPECTOR_REP_C_POINTER:
{
MR_Word *data_value;
int data_tag;
// XXX simplify: tag should be zero.
data_tag = MR_tag(data);
data_value = (MR_Word *) MR_body(data, data_tag);
if (in_range(data_value)) {
// This error occurs if we try to copy() a `c_pointer' type
// that points to memory allocated on the Mercury heap.
MR_fatal_error("Cannot copy a c_pointer type");
} else {
new_data = data;
}
return new_data;
}
case MR_TYPECTOR_REP_SUCCIP: // fallthru
case MR_TYPECTOR_REP_REDOIP:
// Code addresses are never relocated.
return data;
case MR_TYPECTOR_REP_HP:
assert(MR_tag(data) == 0);
if (in_range((MR_Word *) data)) {
MR_fatal_error("Sorry, not implemented: "
"copying saved heap pointer");
} else {
new_data = data;
}
return new_data;
case MR_TYPECTOR_REP_CURFR: // fallthru
case MR_TYPECTOR_REP_MAXFR: // fallthru
case MR_TYPECTOR_REP_REDOFR:
// We do not modify the layout of the nondet stack.
return data;
case MR_TYPECTOR_REP_TRAIL_PTR:
case MR_TYPECTOR_REP_TICKET:
// XXX We do not yet compress the trail when doing gc.
return data;
case MR_TYPECTOR_REP_REFERENCE:
{
MR_Word *ref;
MR_Word *new_ref;
MR_AllocSiteInfoPtr attrib;
assert(MR_tag(data) == 0);
ref = (MR_Word *) MR_body(data, MR_mktag(0));
RETURN_IF_OUT_OF_RANGE(data, ref, 0, MR_Word);
attrib = maybe_attrib(ref);
MR_offset_incr_saved_hp(new_data, 0, 1, attrib, NULL);
new_ref = (MR_Word *) new_data;
*new_ref = copy_arg(NULL, *ref, NULL,
MR_TYPEINFO_GET_FIXED_ARITY_ARG_VECTOR(type_info),
(const MR_PseudoTypeInfo) 1, lower_limit, upper_limit);
leave_forwarding_pointer(data, 0, new_data);
return new_data;
}
case MR_TYPECTOR_REP_STABLE_FOREIGN:
// By definition, stable foreign values are never relocated.
return data;
case MR_TYPECTOR_REP_FOREIGN:
{
MR_Word *data_value;
data_value = (MR_Word *) MR_strip_tag(data);
// Foreign types that are not pointers should not have
// MR_TYPECTOR_REP_FOREIGN; instead, they should have
// MR_TYPECTOR_REP_STABLE_FOREIGN.
if (lower_limit != NULL && !in_range(data_value)) {
// If the foreign value does not point into the area of
// the heap that we are copying, then it is safe to
// leave it unchanged.
//
// It is important to allow these cases, when doing partial
// copies (as occurs with accurate GC or solutions),
// since they include the common cases of pointer types
// that point to the C heap, global data, or stack data.
// io__stream is a particularly important example.
//
// However, when doing complete copies (lower_limit == NULL),
// we should not allow shallow copying of foreign types,
// because in cases where the foreign type is (or represents)
// a pointer of some kind, that might violate unique mode
// correctness. That's why we check lower_limit != NULL above.
new_data = data;
} else {
// The foreign value points into the Mercury heap.
// It might be a foreign pointer to a Mercury heap
// value; or it might be a pointer to a foreign struct
// which MR_MAYBE_BOX_FOREIGN_TYPE() has copied to the
// Mercury heap; or it might be a non-pointer type
// whose bit pattern happens to point to the heap.
//
// We don't know how to copy it, so we have to abort.
char *buf;
int len;
len = strlen(type_ctor_info->MR_type_ctor_module_name) +
strlen(type_ctor_info->MR_type_ctor_name) + 100;
buf = (char *) MR_malloc(len);
sprintf(buf, "Cannot copy foreign type %s.%s",
type_ctor_info->MR_type_ctor_module_name,
type_ctor_info->MR_type_ctor_name);
MR_fatal_error(buf);
}
return new_data;
}
case MR_TYPECTOR_REP_UNUSED1:
case MR_TYPECTOR_REP_UNUSED2:
case MR_TYPECTOR_REP_UNKNOWN:
MR_fatal_error("Unknown layout type in deep copy");
}
MR_fatal_error(MR_STRINGIFY(copy) ": unexpected fallthrough");
}
// copy_arg is like copy() except that it takes a pseudo_type_info
// (namely arg_pseudo_type_info) rather than a type_info.
// The pseudo_type_info may contain type variables,
// which refer to arguments of the term_type_info.
//
// It also takes a pointer to the data of the parent of this piece of data
// and a functor descriptor for the parent in case the data being copied is
// existentially quantified.
static MR_Word
copy_arg(const MR_Word *parent_data_ptr, MR_Word data,
const MR_DuFunctorDesc *functor_descriptor,
const MR_TypeInfoParams type_params,
const MR_PseudoTypeInfo arg_pseudo_type_info,
const MR_Word *lower_limit, const MR_Word *upper_limit)
{
MR_MemoryList allocated_memory_cells;
MR_TypeInfo new_type_info;
MR_Word new_data;
allocated_memory_cells = NULL;
new_type_info = MR_make_type_info_maybe_existq(type_params,
arg_pseudo_type_info, parent_data_ptr,
functor_descriptor, &allocated_memory_cells);
new_data = copy(data, new_type_info, lower_limit, upper_limit);
MR_deallocate(allocated_memory_cells);
return new_data;
}
static MR_TypeInfo
copy_type_info(MR_TypeInfo type_info,
const MR_Word *lower_limit, const MR_Word *upper_limit)
{
MR_TypeCtorInfo type_ctor_info;
MR_Word *new_type_info_arena;
MR_Word new_type_info_arena_word;
MR_TypeInfo *type_info_args;
MR_TypeInfo *new_type_info_args;
MR_AllocSiteInfoPtr attrib;
int forwarding_pointer_size;
int arity;
int i;
// Most changes here should also be done in copy_pseudo_type_info below.
RETURN_IF_OUT_OF_RANGE((MR_Word) type_info, (MR_Word *) type_info,
TYPEINFO_FORWARDING_PTR_OFFSET, MR_TypeInfo);
// Note that we assume type_ctor_infos will always be allocated
// statically, so we never copy them.
type_ctor_info = MR_TYPEINFO_GET_TYPE_CTOR_INFO(type_info);
// Optimize a special case: if there are no arguments,
// we don't need to construct a type_info; instead,
// we can just return the type_ctor_info.
if ((MR_Word) type_info == (MR_Word) type_ctor_info) {
return (MR_TypeInfo) type_ctor_info;
}
// Compute how many words to reserve for the forwarding pointer.
#ifdef MR_NATIVE_GC
forwarding_pointer_size = 1;
#else
forwarding_pointer_size = 0;
#endif
if (MR_type_ctor_has_variable_arity(type_ctor_info)) {
arity = MR_TYPEINFO_GET_VAR_ARITY_ARITY(type_info);
type_info_args =
MR_TYPEINFO_GET_VAR_ARITY_ARG_VECTOR(type_info);
attrib = maybe_attrib((MR_Word *) type_info);
MR_offset_incr_saved_hp(new_type_info_arena_word,
forwarding_pointer_size,
MR_var_arity_type_info_size(arity) + forwarding_pointer_size,
attrib, NULL);
new_type_info_arena = (MR_Word *) new_type_info_arena_word;
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);
attrib = maybe_attrib((MR_Word *) type_info);
MR_offset_incr_saved_hp(new_type_info_arena_word,
forwarding_pointer_size,
MR_fixed_arity_type_info_size(arity) + forwarding_pointer_size,
attrib, NULL);
new_type_info_arena = (MR_Word *) new_type_info_arena_word;
MR_fill_in_fixed_arity_type_info(new_type_info_arena,
type_ctor_info, new_type_info_args);
}
for (i = 1; i <= arity; i++) {
new_type_info_args[i] = copy_type_info(type_info_args[i],
lower_limit, upper_limit);
}
leave_forwarding_pointer((MR_Word) type_info,
TYPEINFO_FORWARDING_PTR_OFFSET, (MR_Word) new_type_info_arena);
return (MR_TypeInfo) new_type_info_arena;
}
static MR_PseudoTypeInfo
copy_pseudo_type_info(MR_PseudoTypeInfo pseudo_type_info,
const MR_Word *lower_limit, const MR_Word *upper_limit)
{
MR_TypeCtorInfo type_ctor_info;
MR_Word *new_pseudo_type_info_arena;
MR_Word new_pseudo_type_info_arena_word;
MR_PseudoTypeInfo *pseudo_type_info_args;
MR_PseudoTypeInfo *new_pseudo_type_info_args;
MR_AllocSiteInfoPtr attrib;
int forwarding_pointer_size;
int arity;
int i;
// Most changes here should also be done in copy_type_info above.
if (MR_PSEUDO_TYPEINFO_IS_VARIABLE(pseudo_type_info)) {
return pseudo_type_info;
}
RETURN_IF_OUT_OF_RANGE((MR_Word) pseudo_type_info,
(MR_Word *) pseudo_type_info, TYPEINFO_FORWARDING_PTR_OFFSET,
MR_PseudoTypeInfo);
// Note that we assume type_ctor_infos will always be allocated
// statically, so we never copy them.
type_ctor_info =
MR_PSEUDO_TYPEINFO_GET_TYPE_CTOR_INFO(pseudo_type_info);
// Optimize a special case: if there are no arguments,
// we don't need to construct a pseudo_type_info; instead,
// we can just return the type_ctor_info.
if ((MR_Word) pseudo_type_info == (MR_Word) type_ctor_info) {
return (MR_PseudoTypeInfo) type_ctor_info;
}
// Compute how many words to reserve for the forwarding pointer.
#ifdef MR_NATIVE_GC
forwarding_pointer_size = 1;
#else
forwarding_pointer_size = 0;
#endif
if (MR_type_ctor_has_variable_arity(type_ctor_info)) {
arity = MR_PSEUDO_TYPEINFO_GET_VAR_ARITY_ARITY(pseudo_type_info);
pseudo_type_info_args =
MR_PSEUDO_TYPEINFO_GET_VAR_ARITY_ARG_VECTOR(pseudo_type_info);
attrib = maybe_attrib((MR_Word *) pseudo_type_info);
MR_offset_incr_saved_hp(new_pseudo_type_info_arena_word,
forwarding_pointer_size,
MR_var_arity_pseudo_type_info_size(arity)
+ forwarding_pointer_size,
attrib, NULL);
new_pseudo_type_info_arena = (MR_Word *)
new_pseudo_type_info_arena_word;
MR_fill_in_var_arity_pseudo_type_info(new_pseudo_type_info_arena,
type_ctor_info, arity, new_pseudo_type_info_args);
} else {
arity = type_ctor_info->MR_type_ctor_arity;
pseudo_type_info_args =
MR_PSEUDO_TYPEINFO_GET_FIXED_ARITY_ARG_VECTOR(pseudo_type_info);
attrib = maybe_attrib((MR_Word *) pseudo_type_info);
MR_offset_incr_saved_hp(new_pseudo_type_info_arena_word,
forwarding_pointer_size,
MR_fixed_arity_pseudo_type_info_size(arity)
+ forwarding_pointer_size,
attrib, NULL);
new_pseudo_type_info_arena = (MR_Word *)
new_pseudo_type_info_arena_word;
MR_fill_in_fixed_arity_pseudo_type_info(new_pseudo_type_info_arena,
type_ctor_info, new_pseudo_type_info_args);
}
for (i = 1; i <= arity; i++) {
new_pseudo_type_info_args[i] =
copy_pseudo_type_info(pseudo_type_info_args[i],
lower_limit, upper_limit);
}
leave_forwarding_pointer((MR_Word) pseudo_type_info,
TYPEINFO_FORWARDING_PTR_OFFSET, (MR_Word) new_pseudo_type_info_arena);
return (MR_PseudoTypeInfo) new_pseudo_type_info_arena;
}
static MR_Word
copy_typeclass_info(MR_Word typeclass_info_param,
const MR_Word *lower_limit, const MR_Word *upper_limit)
{
MR_Word *typeclass_info;
MR_Word *base_typeclass_info;
MR_Word *new_typeclass_info;
MR_Word new_typeclass_info_word;
int num_arg_typeinfos;
int num_super;
int num_instance_constraints;
int num_unconstrained;
int forwarding_pointer_size;
int i;
typeclass_info = (MR_Word *) typeclass_info_param;
RETURN_IF_OUT_OF_RANGE(typeclass_info_param, typeclass_info,
TYPECLASSINFO_FORWARDING_PTR_OFFSET, MR_Word);
// Note that we assume base_typeclass_infos will always be
// allocated statically, so we never copy them.
base_typeclass_info = (MR_Word *) *typeclass_info;
// Compute how many words to reserve for the forwarding pointer.
#ifdef MR_NATIVE_GC
forwarding_pointer_size = 1;
#else
forwarding_pointer_size = 0;
#endif
num_instance_constraints =
MR_typeclass_info_num_instance_constraints(typeclass_info);
num_unconstrained =
MR_typeclass_info_num_extra_instance_args(typeclass_info)
- num_instance_constraints;
num_super = MR_typeclass_info_num_superclasses(typeclass_info);
num_arg_typeinfos = MR_typeclass_info_num_params(typeclass_info);
MR_offset_incr_saved_hp(new_typeclass_info_word,
forwarding_pointer_size,
forwarding_pointer_size + 1 // for basetypeclass_info
+ num_instance_constraints + num_super + num_arg_typeinfos,
NULL, NULL);
new_typeclass_info = (MR_Word *) new_typeclass_info_word;
new_typeclass_info[0] = (MR_Word) base_typeclass_info;
// First, copy typeinfos for unconstrained tvars from
// the instance declaration.
for (i = 1; i < num_unconstrained + 1; i++) {
new_typeclass_info[i] = (MR_Word) copy_type_info(
(MR_TypeInfo) typeclass_info[i], lower_limit, upper_limit);
}
// Next, copy all the typeclass infos: both the ones for constraints
// on the instance declaration (instance constraints), and the ones
// for constraints on the typeclass declaration
// (superclass constraints).
for (i = num_unconstrained + 1;
i <= num_unconstrained + num_instance_constraints + num_super;
i++)
{
new_typeclass_info[i] = (MR_Word) copy_typeclass_info(
typeclass_info[i], lower_limit, upper_limit);
}
// Then, copy all the type infos for types in the
// head of the type class declaration.
for (i = num_unconstrained + num_instance_constraints + num_super + 1;
i <= num_unconstrained + num_instance_constraints + num_super
+ num_arg_typeinfos;
i++)
{
new_typeclass_info[i] = (MR_Word) copy_type_info(
(MR_TypeInfo) typeclass_info[i], lower_limit, upper_limit);
}
leave_forwarding_pointer(typeclass_info,
TYPECLASSINFO_FORWARDING_PTR_OFFSET, (MR_Word) new_typeclass_info);
return (MR_Word) new_typeclass_info;
}
// Try to return the allocation identifier for the given object, or NULL.
// If present, allocation identifiers always occupy the first word of an
// allocated object, with the Mercury cell starting at the second word.
#ifdef MR_MPROF_PROFILE_MEMORY_ATTRIBUTION
static MR_AllocSiteInfoPtr
maybe_attrib(MR_Word *data_value)
{
MR_Word *base;
// Strings are not always aligned, for example.
if (MR_tag(data_value) == 0) {
base = GC_base(data_value);
if (&base[1] == data_value) {
return (MR_AllocSiteInfoPtr) *base;
}
}
return NULL;
}
#endif
Reference in New Issue View Git Blame Copy Permalink