mercurylang/mercury
1
0
Fork 0
mirror of https://github.com/Mercury-Language/mercury.git synced 2025-12-17 06:47:17 +00:00
Code Issues Projects Releases Wiki Activity
Files
faa18a15bd332b51ec6d6fdae4d999ec2bf3fa82
mercury/runtime/mercury_deep_copy_body.h
Zoltan Somogyi d609181cb9 Consider types of the form 
Estimated hours taken: 30
Branches: main

Consider types of the form

	:- type x ---> f.

to be dummy types, since they contain no information. Optimize them the same
way we currently optimize io.state and store.store.

runtime/mercury_type_info.h:
	Add a new type_ctor_rep for dummy types.

runtime/mercury_tabling.h:
	Add a representation for "tabled" dummy types, which don't actually
	have a level in the trie, so that the runtime system can handle that
	fact.

runtime/mercury_ml_expand_body.h:
	When deconstructing a value of a dummy type, ignore the actual value
	(since it will contain garbage) and instead return the only possible
	value of the type.

runtime/mercury_construct.c:
runtime/mercury_deconstruct.c:
runtime/mercury_deep_copy_body.c:
runtime/mercury_tabling.c:
runtime/mercury_unify_compare_body.h:
library/rtti_implementation.m:
	Handle the type_ctor_rep of dummy types.

runtime/mercury_builtin_types.c:
	Provide a place to record profiling information about unifications and
	comparisons for dummy types.

runtime/mercury_mcpp.h:
java/runtime/TypeCtorRep.java:
library/private_builtin.m:
	Add a new type_ctor_rep for dummy types, and fix some previous
	discrepancies in type_ctor_reps.

mdbcomp/prim_data.m:
	Move a bunch of predicates for manipulating special_pred_ids here from
	the browser and compiler directories.

	Rename the function symbols of the special_pred_id type to avoid the
	need to parenthesize the old `initialise' function symbol.

	Convert to four-space indentation.

mdbcomp/rtti_access.m:
	Don't hardcode the names of special preds: use the predicates in
	prim_data.m.

	Convert to four-space indentation.

browser/declarative_execution.m:
	Delete some predicates whose functionality is now in
	mdbcomp/prim_data.m.

compiler/hlds_data.m:
	Replace the part of du type that says whether a type an enum, which
	used to be a bool, with something that also says whether the type is a
	dummy type.

	Convert to four-space indentation.

compiler/make_tags.m:
	Compute the value for the new field of du type definitions.

compiler/hlds_out.m:
	Write out the new field of du type definitions.

compiler/rtti.m:
	Modify the data structures we use to create type_ctor_infos to allow
	for dummy types.

	Convert to four-space indentation.

compiler/type_ctor_info.m:
	Modify the code that generates type_ctor_infos to handle dummy types.

compiler/type_util.m:
	Provide predicates for recognizing dummy types.

	Convert to four-space indentation.

compiler/unify_proc.m:
	Generate the unify and compare predicates of dummy types using a new
	code scheme that avoids referencing arguments that contain garbage.

	When generating code for unifying or comparing other types, ignore
	any arguments of function symbols that are dummy types.

	Don't use DCG style access predicates.

compiler/higher_order.m:
	Specialize the unification and comparison of values of dummy types.

	Break up an excessively large predicate, and factor out common code
	from the conditions of a chain of if-then-elses.

compiler/llds.m:
	For each input and output of a foreign_proc, include a field saying
	whether the value is of a dummy type.

compiler/pragma_c_gen.m:
	Fill in the new fields in foreign_proc arguments.

compiler/hlds_goal.m:
	Rename some predicates for constructing unifications to avoid
	unnecessary ad-hoc overloading. Clarify their documentation.

	Rename a predicate to make clear the restriction on its use,
	and document the restriction.

	Add a predicate for creating simple tests.

	Add a utility predicate for setting the context of a goal directly.

compiler/modules.m:
	Include dummy types interface files, even if they are private to the
	module. This is necessary because with the MLDS backend, the generated
	code inside the module and outside the module must agree whether a
	function returning a value of the type returns a real value or a void
	value, and this requires them to agree on whether the type is dummy
	or not.

	The impact on interface files is minimal, since very few types are
	dummy types, and changing a type from a dummy type to a non-dummy type
	or vice versa is an ever rarer change.

compiler/hlds_pred.m:
	Provide a representation in the compiler of the trie step for dummy
	types.

compiler/layout_out.m:
	Print the trie step for dummy types.

compiler/table_gen.m:
	Don't table values of dummy types, and record the fact that we don't
	by including a dummy trie step in the list of trie steps.

compiler/add_pragma.m:
compiler/add_special_pred.m:
compiler/add_type.m:
compiler/aditi_builtin_ops.m:
compiler/bytecode.m:
compiler/bytecode_gen.m:
compiler/code_gen.m:
compiler/code_info.m:
compiler/continuation_info.m:
compiler/cse_detection.m:
compiler/det_report.m:
compiler/exception_analysis.m:
compiler/inst_match.m:
compiler/livemap.m:
compiler/llds_out.m:
compiler/llds_out.m:
compiler/middle_rec.m:
compiler/ml_call_gen.m:
compiler/ml_closure_gen.m:
compiler/ml_code_gen.m:
compiler/ml_code_util.m:
compiler/ml_type_gen.m:
compiler/ml_unify_gen.m:
compiler/mlds_to_c.m:
compiler/mlds_to_gcc.m:
compiler/mlds_to_il.m:
compiler/mlds_to_il.m:
compiler/modecheck_unify.m:
compiler/modes.m:
compiler/opt_util.m:
compiler/post_term_analysis.m:
compiler/post_typecheck.m:
compiler/qual_info.m:
compiler/rl.m:
compiler/rl_exprn.m:
compiler/rl_key.m:
compiler/rtti_out.m:
compiler/simplify.m:
compiler/size_prof.m:
compiler/term_constr_initial.m:
compiler/term_constr_util.m:
compiler/term_norm.m:
compiler/termination.m:
compiler/trace.m:
compiler/typecheck.m:
compiler/unify_gen.m:
	Conform to the changes above.

compiler/export.m:
compiler/exprn_aux.m:
compiler/foreign.m:
compiler/polymorphism.m:
compiler/proc_label.m:
compiler/rtti_to_mlds.m:
compiler/special_pred.m:
compiler/stack_alloc.m:
compiler/stack_layout.m:
compiler/state_var.m:
compiler/switch_util.m:
compiler/trace_params.m:
	Conform to the changes above.

	Convert to four-space indentation.

compiler/mlds_to_java.m:
compiler/var_locn.m:
	Conform to the changes above, which requires threading the module_info
	through the module.

	Convert to four-space indentation.

compiler/mercury_compile.m:
	Pass the module_info to mlds_to_java.m.

compiler/ml_util.m:
compiler/polymorphism.m:
compiler/type_ctor_info.m:
compiler/type_util.m:
	Delete some previously missed references to the temporary types used
	to bootstrap the change to the type_info type's arity.

compiler/polymorphism.m:
	Turn back on an optimization that avoids passing parameters (such as
	type_infos) to foreign_procs if they are not actually referred to.

compiler/prog_data.m:
	Convert to four-space indentation.

library/svvarset.m:
	Add a missing predicate.

trace/mercury_trace.c:
	Delete the unused function that used to check for dummy types.

tests/debugger/field_names.{m,inp,exp}:
	Add to this test case a test of the handling of dummy types. Check that
	their values can be printed out during normal execution, and that the
	debugger doesn't consider them live nondummy variables, just as it
	doesn't consider I/O states live nondummy variables.
2005-10-05 06:34:27 +00:00

1008 lines
41 KiB
C++
Raw Blame History

/*
** vim: ts=4 sw=4 expandtab
*/
/*
** Copyright (C) 1997-2005 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.
*/
/*
** 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);
/*
** 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:
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_RESERVED_ADDR:
case MR_TYPECTOR_REP_RESERVED_ADDR_USEREQ:
{
int j;
MR_ReservedAddrTypeLayout ra_layout;
ra_layout =
MR_type_ctor_layout(type_ctor_info).MR_layout_reserved_addr;
/*
** First check if this value is one of
** the numeric reserved addresses.
*/
if ((MR_Unsigned) data <
(MR_Unsigned) ra_layout->MR_ra_num_res_numeric_addrs)
{
return data;
}
/*
** Next check if this value is one of the
** the symbolic reserved addresses.
*/
for (j = 0; j < ra_layout->MR_ra_num_res_symbolic_addrs; j++) {
if (data == (MR_Word) ra_layout->MR_ra_res_symbolic_addrs[j]) {
new_data = data;
/* "break" here would just exit the "for" loop */
return new_data;
}
}
/*
** Otherwise, it is not one of the reserved addresses,
** so handle it like a normal DU type.
*/
du_type_layout = ra_layout->MR_ra_other_functors;
goto du_type;
}
case MR_TYPECTOR_REP_DU:
case MR_TYPECTOR_REP_DU_USEREQ:
du_type_layout = MR_type_ctor_layout(type_ctor_info).MR_layout_du;
/* fallthru */
/*
** This label handles both the DU case and the second half of the
** RESERVED_ADDR case. `du_type_layout' must be set before
** this code is entered.
*/
du_type:
{
MR_Word *data_value;
const MR_DuPtagLayout *ptag_layout;
int ptag;
ptag = MR_tag(data);
ptag_layout = &du_type_layout[ptag];
switch (ptag_layout->MR_sectag_locn) {
case MR_SECTAG_LOCAL:
return data; /* just a copy of the actual item */
/* case MR_SECTAG_REMOTE: */
/* case MR_SECTAG_NONE: */
/*
** 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 thest 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 requres two copies of the MR_get_first_slot() code,
** which is why we define that as a macro too.
*/
#define MR_get_first_slot(have_sectag) \
do { \
/* this `if' will get evaluated at compile time */ \
if (!have_sectag) { \
cur_slot = 0; \
} else { \
MR_field(0, new_data, 0) = sectag; \
cur_slot = 1; \
} \
} while(0)
#define MR_handle_sectag_remote_or_none(have_sectag) \
do { \
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_DuExistInfo *exist_info; \
int sectag; \
int cell_size; \
int cur_slot; \
int arity; \
int i; \
\
/* this `if' will get evaluated at compile time */ \
if (!have_sectag) { \
sectag = 0; \
} else { \
sectag = data_value[0]; \
} \
\
functor_desc = ptag_layout->MR_sectag_alternatives \
[sectag]; \
arity = functor_desc->MR_du_functor_orig_arity; \
exist_info = functor_desc->MR_du_functor_exist_info; \
\
/* this `if' will get evaluated at compile time */ \
if (!have_sectag) { \
cell_size = arity; \
} 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_copy_size_slot(0, new_data, ptag, data); \
MR_get_first_slot(have_sectag); \
} 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; \
\
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++) { \
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++; \
} \
} \
\
for (i = 0; i < arity; i++) { \
if (MR_arg_type_may_contain_var(functor_desc, i)) { \
MR_Word *parent_data = (MR_Word *) new_data; \
if (have_sectag) { \
/* skip past the secondary tag */ \
parent_data++; \
} \
MR_field(0, new_data, cur_slot) = \
copy_arg(parent_data, data_value[cur_slot], \
functor_desc, \
MR_TYPEINFO_GET_FIXED_ARITY_ARG_VECTOR( \
type_info), \
functor_desc->MR_du_functor_arg_types[i], \
lower_limit, upper_limit); \
} else { \
MR_field(0, new_data, cur_slot) = \
copy(data_value[cur_slot], \
MR_pseudo_type_info_is_ground( \
functor_desc->MR_du_functor_arg_types[i]), \
lower_limit, upper_limit); \
} \
cur_slot++; \
} \
\
new_data = (MR_Word) MR_mkword(ptag, new_data); \
leave_forwarding_pointer(data_value, 0, new_data); \
} \
} while(0)
case MR_SECTAG_REMOTE:
/* see comments above */
MR_handle_sectag_remote_or_none(MR_TRUE);
return new_data;
case MR_SECTAG_NONE:
/* see comments above */
MR_handle_sectag_remote_or_none(MR_FALSE);
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:
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:
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_CHAR:
return 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:
{
/*
** 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);
{
MR_String new_string;
MR_make_aligned_string_copy_saved_hp(new_string,
(MR_String) data);
new_data = (MR_Word) new_string;
leave_forwarding_pointer(data, 0, new_data);
}
}
return new_data;
case MR_TYPECTOR_REP_FUNC:
case MR_TYPECTOR_REP_PRED:
{
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,
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.
*/
{
MR_Unsigned args, 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;
old_closure = (MR_Closure *) data_value;
closure_layout = old_closure->MR_closure_layout;
args = old_closure->MR_closure_num_hidden_args;
/* create new closure */
MR_offset_incr_saved_hp(new_closure_word, 0, args + 3);
new_closure = (MR_Closure *) new_closure_word;
/* copy the fixed fields */
new_closure->MR_closure_layout = closure_layout;
new_closure->MR_closure_num_hidden_args = args;
new_closure->MR_closure_code = old_closure->MR_closure_code;
/*
** 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 */
for (i = 0; i < args; i++) {
MR_PseudoTypeInfo arg_pseudo_type_info;
arg_pseudo_type_info =
closure_layout->MR_closure_arg_pseudo_type_info[i];
new_closure->MR_closure_hidden_args_0[i] =
copy_arg(NULL,
old_closure->MR_closure_hidden_args_0[i], NULL,
type_info_arg_vector, arg_pseudo_type_info,
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;
int arity, 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);
{
MR_Word *new_data_ptr;
MR_TypeInfo *arg_typeinfo_vector;
arity = MR_TYPEINFO_GET_VAR_ARITY_ARITY(type_info);
if (arity == 0) {
new_data = (MR_Word) NULL;
} else {
/* allocate space for the new tuple */
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 =
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;
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);
{
MR_ArrayType *new_array;
MR_ArrayType *old_array;
MR_Integer array_size;
old_array = (MR_ArrayType *) data_value;
array_size = old_array->size;
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++) {
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_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;
int i;
assert(MR_tag(data) == 0);
ref = (MR_Word *) MR_body(data, MR_mktag(0));
RETURN_IF_OUT_OF_RANGE(data, ref, 0, MR_Word);
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),
(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_UNKNOWN:
MR_fatal_error("Unknown layout type in deep copy");
}
MR_fatal_error(MR_STRINGIFY(copy) ": unexpected fallthough");
}
/*
** 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)
{
/*
** 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);
{
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;
int arity;
int i;
int forwarding_pointer_size;
/*
** 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);
MR_offset_incr_saved_hp(new_type_info_arena_word,
forwarding_pointer_size,
MR_var_arity_type_info_size(arity) + forwarding_pointer_size);
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);
MR_offset_incr_saved_hp(new_type_info_arena_word,
forwarding_pointer_size,
MR_fixed_arity_type_info_size(arity) + forwarding_pointer_size
);
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)
{
/*
** 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);
{
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;
int arity;
int i;
int forwarding_pointer_size;
/*
** 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);
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);
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);
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
);
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 *) typeclass_info_param;
RETURN_IF_OUT_OF_RANGE(typeclass_info_param, typeclass_info,
TYPECLASSINFO_FORWARDING_PTR_OFFSET, MR_Word);
{
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 i;
int forwarding_pointer_size;
/*
** 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);
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;
}
}
Reference in New Issue View Git Blame Copy Permalink