New type_layout traversal code
Oliver Hutchison
ohutch at cs.mu.oz.au
Thu Feb 20 11:44:54 AEDT 1997
Tyson,
I have finished the type_layout traversal macro and recoded unify
and deep_copy to work with it, so I thought you should have a look. I
haven't been able to test the code yet (need to rebuild compiler) but It
would be good if you would have a look and tell me if it is what you had
in mind. Note that this code is not at a stage where I would commit it. I
will have to very throughly document how to use the macro.
Thanks
Oliver
type_layout.h
_________________________________
#ifndef TYPE_LAYOUT_H
#define TYPE_LAYOUT_H
Word * make_type_info(Word *, Word *, bool *);
/* This macro will do most of the work traversing a type layout
** it expects that the variables :
** Word data_word;
** Word data_value;
** Word data_tag;
** Word entry_value;
** and Word * type_info;
** have been defined some where in its scope. It also assumes that
** data_word and type_info have been initialised.
*/
#define TRAVERSE_TYPE_LAYOUT() \
{ \
Word *base_type_info, *base_type_layout; \
Word base_type_layout_entry; \
int entry_tag; \
\
base_type_info = (Word *) type_info[0]; \
if(base_type_info == 0) { \
base_type_info = type_info; \
} \
base_type_layout = (Word *) base_type_info[ \
OFFSET_FOR_BASE_TYPE_LAYOUT]; \
\
data_tag = tag(data_word); \
data_value = body(data_word, data_tag); \
\
base_type_layout_entry = base_type_layout[data_tag]; \
\
entry_tag = tag(base_type_layout_entry); \
entry_value = body(base_type_layout_entry, entry_tag); \
\
switch(entry_tag) { \
case TYPELAYOUT_CONST_TAG: \
if (entry_value > TYPELAYOUT_MAX_VARINT) { \
if (((Word *) entry_value)[0]) { \
goto process_enum; \
} else { \
goto process_const; \
} \
} else { \
entry_value = unmkbody(entry_value); \
switch ((int) entry_value) { \
case TYPELAYOUT_UNASSIGNED_VALUE: \
fatal_error( \
"Attempt to use an UNASSIGNED tag."); \
break; \
case TYPELAYOUT_UNUSED_VALUE: \
fatal_error( \
"Attempt to use an UNUSED tag."); \
break; \
case TYPELAYOUT_STRING_VALUE: \
goto process_string; \
break; \
case TYPELAYOUT_FLOAT_VALUE: \
goto process_float; \
break; \
case TYPELAYOUT_INT_VALUE: \
goto process_int; \
break; \
case TYPELAYOUT_CHARACTER_VALUE: \
goto process_char; \
break; \
case TYPELAYOUT_UNIV_VALUE: \
goto process_univ; \
break; \
case TYPELAYOUT_PREDICATE_VALUE: \
goto process_pred; \
break; \
default: \
fatal_error("Invalid tag value"); \
break; \
} \
} \
break; \
case TYPELAYOUT_SIMPLE_TAG: \
goto process_simple; \
break; \
case TYPELAYOUT_COMPLICATED_TAG: \
goto process_complicated; \
break; \
case TYPELAYOUT_EQUIV_TAG: \
if (entry_value < TYPELAYOUT_MAX_VARINT) { \
goto process_equiv; \
} else if (((Word *) entry_value)[0]) { \
goto process_no_tag; \
} else { \
++entry_value; \
goto process_equiv; \
} \
break; \
default: \
fatal_error("Found unused tag value"); \
} \
}
/*
** Code like what follows is a good example of how to use the
** TRAVERSE_TYPE_LAYOUT macro
**
**
void test(Word data_word, Word *type_info)
{
Word data_value;
Word entry_value;
TRAVERSE_TYPE_LAYOUT();
process_enum :
{
String functor = (String) ((Word *) entry_value)[data_word +
TYPELAYOUT_ENUM_FUNCTOR_OFFSET];
Word num_fuctors = ((Word *) entry_value)
[TYPELAYOUT_ENUM_NUM_FUNCTORS_OFFSET];
Word enum_value = data_word;
return;
}
process_const :
{
data_value = unmkbody(data_value);
String functor = (String) ((Word *) entry_value)[data_value +
TYPELAYOUT_CONST_FUNCTOR_OFFSET];
Word num_fuctors = ((Word *) entry_value)
[TYPELAYOUT_CONST_NUM_FUNCTORS_OFFSET];
Word const_value = data_value;
return;
}
process_string :
{
String string_value = (String) data_word;
return;
}
process_float :
{
Float float_value = (Float) word_to_float(data_word);
return;
}
process_int :
{
Integer int_value = (Integer) data_word;
return;
}
process_char :
{
Char char_value = (Char) data_word;
return;
}
process_univ :
{
Word * new_type_info = (Word *) ((Word *) data_value)[
UNIV_OFFSET_FOR_TYPEINFO];
Word new_data_word = ((Word *) data_value)[
UNIV_OFFSET_FOR_DATA];
test(new_data_word, new_type_info);
return;
}
process_pred :
{
int i;
Word curried_args = ((Word *)data_value)[0];
for (i = 0; i < curried_args; i++) {
Word arg_data_word = ((Word *)data_value)[i + 2];
Word * arg_type_info = (Word *)type_info[i +
TYPEINFO_OFFSET_FOR_PRED_ARGS];
}
return;
}
process_simple :
{
int i;
Word functor_args = ((Word *)entry_value)[
TYPELAYOUT_SIMPLE_ARITY_OFFSET];
String functor = (String)((Word *)entry_value)[functor_args +
TYPELAYOUT_SIMPLE_FUNCTOR_OFFSET];
for (i = 0; i < functor_args; i++) {
Word * new_type_info = create_type_info(type_info,
(Word *)((Word *)entry_value)[i +
TYPELAYOUT_SIMPLE_ARGS_OFFSET]);
Word new_data_word = ((Word *)data_value)[i];
test(new_data_word, new_type_info);
}
return;
}
process_complicated :
{
Word num_secondary_tags = ((Word *) entry_value)
[TYPELAYOUT_COMPLIC_NUM_TAGS_OFFSET];
Word secondary_tag = ((Word *) data_value)[0];
Word new_entry_value = ((Word *) entry_value)[secondary_tag +
TYPELAYOUT_COMPLIC_ENTRY_OFFSET];
Word new_entry_tag = tag(entry_value);
Word new_entry_body = body(new_entry_value, new_entry_tag);
Word new_data_value = (Word) ((Word *) data_value)[1];
data_value = new_data_value;
entry_value = new_entry_body;
goto process_simple;
}
process_equiv :
{
Word * new_type_info = create_type_info(type_info,
(Word *) entry_value);
test(data_word, new_type_info);
return;
}
process_no_tag :
{
String functor = (String)((Word *) entry_value)[
TYPELAYOUT_NO_TAG_FUNCTOR_OFFSET];
Word * new_type_info = create_type_info(type_info,
(Word *) ((Word *) entry_value)[
TYPELAYOUT_NO_TAG_TYPE_INFO_OFFSET]);
test(data_word, new_type_info);
return;
}
}
**
**
*/
#endif
----------------------
type_layout.c
______________________
#include "imp.h"
#include "type_layout.h"
/*
** Given a type_info (term_type_info) which contains a
** base_type_info pointer and possibly other type_infos
** giving the values of the type parameters of this type,
** and a pseudo-type_info (arg_pseudo_type_info), which contains a
** base_type_info pointer and possibly other type_infos
** giving EITHER
** - the values of the type parameters of this type,
** or - an indication of the type parameter of the
** term_type_info that should be substituted here
**
** This returns a fully instantiated type_info, a version of the
** arg_pseudo_type_info with all the type variables filled in.
** If there are no type variables to fill in, we return the
** arg_pseudo_type_info, unchanged. Otherwise, we allocate
** memory using malloc(). If memory is allocated, the boolean
** argument (passed by reference) is set to TRUE, otherwise it is
** set to FALSE. It is the caller's responsibility to check whether
** the call to make_type_info allocated memory, and if so, free
** it.
**
** This code could be tighter. In general, we want to
** handle our own allocations rather than using malloc().
** Also, we might be able to do only one traversal.
**
** NOTE: If you are changing this code, you might also need
** to change the code in create_type_info in library/std_util.m,
** which does much the same thing, only allocating on the
** heap instead of using malloc.
*/
Word *
make_type_info(Word *term_type_info, Word *arg_pseudo_type_info,
bool *allocated)
{
int arity, i;
Word base_type_info;
Word *type_info;
*allocated = FALSE;
/* The arg_pseudo_type_info might be a polymorphic variable */
if ((Word) arg_pseudo_type_info < TYPELAYOUT_MAX_VARINT) {
return (Word *) term_type_info[(Word) arg_pseudo_type_info];
}
base_type_info = arg_pseudo_type_info[0];
/* no arguments - optimise common case */
if (base_type_info == 0) {
return arg_pseudo_type_info;
} else {
arity = ((Word *) base_type_info)[0];
}
for (i = arity; i > 0; i--) {
if (arg_pseudo_type_info[i] < TYPELAYOUT_MAX_VARINT) {
break;
}
}
/*
** See if any of the arguments were polymorphic.
** If so, substitute.
*/
if (i > 0) {
type_info = checked_malloc(arity * sizeof(Word));
*allocated = TRUE;
for (i = 0; i <= arity; i++) {
if (arg_pseudo_type_info[i] < TYPELAYOUT_MAX_VARINT) {
type_info[i] = term_type_info[arg_pseudo_type_info[i]];
if (type_info[i] < TYPELAYOUT_MAX_VARINT) {
fatal_error("Error! Can't instantiate type variable.");
}
} else {
type_info[i] = arg_pseudo_type_info[i];
}
}
return type_info;
} else {
return arg_pseudo_type_info;
}
} /* end make_type_info() */
------------------------
deep_copy.c
________________________
/*
** Copyright (C) 1997 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.
*/
/*
** This module defines the deep_copy() function.
*/
#include "imp.h"
#include "deep_copy.h"
#include "type_layout.h"
#define in_range(X) (((Word *)(X)) >= lower_limit && \
((Word *)(X)) <= upper_limit)
Word
deep_copy(Word data_word, Word *type_info, Word *lower_limit, Word *upper_limit)
{
Word data_value;
Word data_tag;
Word entry_value;
Word new_data;
TRAVERSE_TYPE_LAYOUT();
process_enum :
return data_word;
process_const :
return data_word;
process_string :
if (in_range(data_value)) {
incr_saved_hp_atomic(new_data,
(strlen((String) data_value) + sizeof(Word))
/ sizeof(Word));
strcpy((String) new_data, (String) data_value);
} else {
new_data = data_word;
}
return new_data;
process_float :
/* XXX : this wont work for boxed floats! */
return data_word;
process_int :
return data_word;
process_char :
return data_word;
process_univ :
/* if the univ is stored in range, copy it */
if (in_range(data_value)) {
Word *new_data_ptr;
/* allocate space for a univ */
incr_saved_hp(new_data, 2);
new_data_ptr = (Word *) new_data;
new_data_ptr[UNIV_OFFSET_FOR_TYPEINFO] =
((Word *) data_value)[UNIV_OFFSET_FOR_TYPEINFO];
new_data_ptr[UNIV_OFFSET_FOR_DATA] = deep_copy(
((Word *) data_value)[UNIV_OFFSET_FOR_DATA],
(Word *)((Word *) data_value)[UNIV_OFFSET_FOR_TYPEINFO],
lower_limit, upper_limit);
} else {
new_data = data_word;
}
return new_data;
process_pred :
{
/* predicate closures store the number of curried
** arguments as their first argument, the
** Code * as their second, and then the
** arguments
**
** Their type-infos have a pointer to
** base_type_info for pred/0, arity, and then
** argument typeinfos.
*/
int i, args;
Word *new_closure;
/* get number of curried arguments */
args = ((Word *) data_value)[0];
/* create new closure */
incr_saved_hp(LVALUE_CAST(Word, new_closure), args + 2);
/* copy number of arguments */
new_closure[0] = args;
/* copy pointer to code for closure */
new_closure[1] = ((Word *) data_value)[1];
/* copy arguments */
for (i = 0; i < args; i++) {
new_closure[i + 2] = deep_copy(((Word *)data_value)[
i + 2],
(Word *)
type_info[i + TYPEINFO_OFFSET_FOR_PRED_ARGS],
lower_limit, upper_limit);
}
new_data = (Word) new_closure;
return new_data;
}
process_simple :
/* If the argument vector is in range, copy the
** arguments.
**/
if (in_range(data_value)) {
int i;
Word arity = ((Word *)entry_value)[
TYPELAYOUT_SIMPLE_ARITY_OFFSET];
Word * type_info_vector = ((Word *) entry_value) +
TYPELAYOUT_SIMPLE_ARGS_OFFSET;
/* allocate space for new args. */
incr_saved_hp(new_data, arity);
/* copy arguments */
for (i = 0; i < arity; i++) {
bool allocated;
Word * new_type_info = make_type_info(type_info,
(Word *) type_info_vector[i], &allocated);
field(0, new_data, i) =
deep_copy(((Word *) data_value)[i],
new_type_info, lower_limit,
upper_limit);
if (allocated) {
free(new_type_info);
}
}
/* tag this pointer */
new_data = (Word) mkword(data_tag, new_data);
} else {
new_data = data_word;
}
return new_data;
process_complicated :
if (in_range(data_value)) {
Word secondary_tag = ((Word *) data_value)[0];
Word new_entry_value = ((Word *) entry_value)[secondary_tag +
TYPELAYOUT_COMPLIC_ENTRY_OFFSET];
Word new_entry_tag = tag(entry_value);
Word new_entry_body = body(new_entry_value, new_entry_tag);
Word new_data_value = (Word) ((Word *) data_value)[1];
data_value = new_data_value;
entry_value = new_entry_body;
goto process_simple;
} else {
return data_word;
}
process_equiv :
{
bool allocated;
Word * new_type_info = make_type_info(type_info,
(Word *) entry_value,
&allocated);
new_data = deep_copy(data_word, new_type_info,
lower_limit, upper_limit);
if (allocated) {
free(new_type_info);
}
return new_data;
}
process_no_tag :
{
bool allocated;
Word * new_type_info = make_type_info(type_info,
(Word *) ((Word *) entry_value)[
TYPELAYOUT_NO_TAG_TYPE_INFO_OFFSET],
&allocated);
new_data = deep_copy(data_word, new_type_info,
lower_limit, upper_limit);
if (allocated) {
free(new_type_info);
}
return new_data;
}
}
-----------------------
unify.c
______________________
/*
** Copyright (C) 1997 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.
*/
/*
** This module defines the unify function.
*/
#include "imp.h"
#include "unify.h"
#include "type_layout.h"
bool unify(Word data_word, Word dataB_word, Word *type_info)
{
Word data_value;
Word entry_value;
Word dataB_tag = tag(dataB_word);
Word dataB_value = body(dataB_word, dataB_tag);
TRAVERSE_TYPE_LAYOUT();
/* Any code here will not get executed !!! */
process_enum :
return data_word == dataB_word;
process_const :
data_value = unmkbody(data_value);
dataB_value = unmkbody(dataB_value);
return data_value == dataB_value;
process_string :
{
String s1 = (String)data_word;
String s2 = (String)dataB_word;
return string_equal(s1, s2);
}
process_float :
{
Float f1 = (Float) word_to_float(data_word);
Float f2 = (Float) word_to_float(dataB_word);
return f1 == f2;
}
process_int :
{
Integer i1 = (Integer) data_word;
Integer i2 = (Integer) dataB_word;
return i1 == i2;
}
process_char :
{
Char c1 = (Char) data_word;
Char c2 = (Char) dataB_word;
return c1 == c2;
}
process_univ :
{
Word * new_type_info = (Word *) ((Word *) data_value)[
UNIV_OFFSET_FOR_TYPEINFO];
Word * new_Btype_info = (Word *) ((Word *) dataB_value)[
UNIV_OFFSET_FOR_TYPEINFO];
if (new_type_info != new_Btype_info) {
return FALSE;
} else {
Word new_dataA_word = ((Word *) data_value)[
UNIV_OFFSET_FOR_DATA];
Word new_dataB_word = ((Word *) dataB_value)[
UNIV_OFFSET_FOR_DATA];
return unify(new_dataA_word, new_dataB_word,
new_type_info);
}
}
process_pred :
fatal_error("Unification of higher order functions in unify");
process_simple :
{
int i;
Word functor_args = ((Word *)entry_value)[
TYPELAYOUT_SIMPLE_ARITY_OFFSET];
for (i = 0; i < functor_args; i++) {
bool allocated;
Word * new_type_info = make_type_info(type_info,
(Word *)((Word *)entry_value)[i +
TYPELAYOUT_SIMPLE_ARGS_OFFSET],
&allocated);
Word new_dataA_word = ((Word *)data_value)[i];
Word new_dataB_word = ((Word *)dataB_value)[i];
bool res = unify(new_dataA_word, new_dataB_word,
new_type_info);
if (allocated) {
free(new_type_info);
}
if (! res ) {
return FALSE;
}
}
return TRUE;
}
process_complicated :
{
Word secondaryA_tag = ((Word *) data_value)[0];
Word secondaryB_tag = ((Word *) dataB_value)[0];
if (secondaryA_tag == secondaryB_tag) {
Word new_entry_value = ((Word *) entry_value)[
secondaryA_tag +
TYPELAYOUT_COMPLIC_ENTRY_OFFSET];
Word new_entry_tag = tag(entry_value);
Word new_entry_body = body(new_entry_value,
new_entry_tag);
Word new_data_value = (Word) ((Word *) data_value)[1];
data_value = new_data_value;
entry_value = new_entry_body;
goto process_simple;
} else {
return FALSE;
}
}
process_equiv :
{
bool allocated;
Word * new_type_info = make_type_info(type_info,
(Word *) entry_value,
&allocated);
bool res = unify(data_word, dataB_word, new_type_info);
if (allocated) {
free(new_type_info);
}
return res;
}
process_no_tag :
{
bool allocated;
Word * new_type_info = make_type_info(type_info,
(Word *) ((Word *) entry_value)[
TYPELAYOUT_NO_TAG_TYPE_INFO_OFFSET],
&allocated);
bool res = unify(data_word, dataB_word, new_type_info);
if (allocated) {
free(new_type_info);
}
return res;
}
}
More information about the developers
mailing list