path: root/erts/emulator/beam/copy.c

/*
 * %CopyrightBegin%
 *
 * Copyright Ericsson AB 1996-2012. All Rights Reserved.
 *
 * Licensed under the Apache License, Version 2.0 (the "License");
 * you may not use this file except in compliance with the License.
 * You may obtain a copy of the License at
 *
 *     http://www.apache.org/licenses/LICENSE-2.0
 *
 * Unless required by applicable law or agreed to in writing, software
 * distributed under the License is distributed on an "AS IS" BASIS,
 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 * See the License for the specific language governing permissions and
 * limitations under the License.
 *
 * %CopyrightEnd%
 */

#ifdef HAVE_CONFIG_H
#  include "config.h"
#endif

#define ERL_WANT_GC_INTERNALS__

#include "sys.h"
#include "erl_vm.h"
#include "global.h"
#include "erl_process.h"
#include "erl_gc.h"
#include "big.h"
#include "erl_map.h"
#include "erl_binary.h"
#include "erl_bits.h"
#include "dtrace-wrapper.h"

static void move_one_frag(Eterm** hpp, ErlHeapFragment*, ErlOffHeap*, int);

/*
 *  Copy object "obj" to process p.
 */
Eterm copy_object_x(Eterm obj, Process* to, Uint extra) {
    if (!is_immed(obj)) {
        Uint size = size_object(obj);
        Eterm* hp = HAllocX(to, size, extra);
        Eterm res;

#ifdef USE_VM_PROBES
        if (DTRACE_ENABLED(copy_object)) {
            DTRACE_CHARBUF(proc_name, 64);

            erts_snprintf(proc_name, sizeof(DTRACE_CHARBUF_NAME(proc_name)),
                    "%T", to->common.id);
            DTRACE2(copy_object, proc_name, size);
        }
#endif
        res = copy_struct(obj, size, &hp, &to->off_heap);
#ifdef DEBUG
        if (eq(obj, res) == 0) {
            erl_exit(ERTS_ABORT_EXIT, "copy not equal to source\n");
        }
#endif
        return res;
    }
    return obj;
}

/*
 * Return the "flat" size of the object.
 */

Uint size_object(Eterm obj)
{
    Uint sum = 0;
    Eterm* ptr;
    int arity;
#ifdef SHCOPY_DEBUG
    Eterm mypid;
#endif

    DECLARE_ESTACK(s);

#ifdef SHCOPY_DEBUG
    mypid = erts_get_current_pid();
    VERBOSE_DEBUG("[pid=%T] size_object %p\n", mypid, obj);
#endif

    for (;;) {
	switch (primary_tag(obj)) {
	case TAG_PRIMARY_LIST:
	    sum += 2;
	    ptr = list_val(obj);
	    obj = *ptr++;
	    if (!IS_CONST(obj)) {
		ESTACK_PUSH(s, obj);
	    }	    
	    obj = *ptr;
	    break;
	case TAG_PRIMARY_BOXED:
	    {
		Eterm hdr = *boxed_val(obj);
		ASSERT(is_header(hdr));
		switch (hdr & _TAG_HEADER_MASK) {
		case ARITYVAL_SUBTAG:
		    ptr = tuple_val(obj);
		    arity = header_arity(hdr);
		    sum += arity + 1;
		    if (arity == 0) { /* Empty tuple -- unusual. */
			goto pop_next;
		    }
		    while (arity-- > 1) {
			obj = *++ptr;
			if (!IS_CONST(obj)) {
			    ESTACK_PUSH(s, obj);
			}
		    }
		    obj = *++ptr;
		    break;
		case FUN_SUBTAG:
		    {
			Eterm* bptr = fun_val(obj);
			ErlFunThing* funp = (ErlFunThing *) bptr;
			unsigned eterms = 1 /* creator */ + funp->num_free;
			unsigned sz = thing_arityval(hdr);
			sum += 1 /* header */ + sz + eterms;
			bptr += 1 /* header */ + sz;
			while (eterms-- > 1) {
			  obj = *bptr++;
			  if (!IS_CONST(obj)) {
			    ESTACK_PUSH(s, obj);
			  }
			}
			obj = *bptr;
			break;
		    }
		case MAP_SUBTAG:
		    switch (MAP_HEADER_TYPE(hdr)) {
			case MAP_HEADER_TAG_FLATMAP_HEAD :
                            {
                                Uint n;
                                flatmap_t *mp;
                                mp  = (flatmap_t*)flatmap_val(obj);
                                ptr = (Eterm *)mp;
                                n   = flatmap_get_size(mp) + 1;
                                sum += n + 2;
                                ptr += 2; /* hdr + size words */
                                while (n--) {
                                    obj = *ptr++;
                                    if (!IS_CONST(obj)) {
                                        ESTACK_PUSH(s, obj);
                                    }
                                }
                                goto pop_next;
                            }
			case MAP_HEADER_TAG_HAMT_HEAD_BITMAP :
			case MAP_HEADER_TAG_HAMT_HEAD_ARRAY :
			case MAP_HEADER_TAG_HAMT_NODE_BITMAP :
			    {
				Eterm *head;
				Uint sz;
				head  = hashmap_val(obj);
				sz    = hashmap_bitcount(MAP_HEADER_VAL(hdr));
				sum  += 1 + sz + header_arity(hdr);
				head += 1 + header_arity(hdr);

				if (sz == 0) {
				    goto pop_next;
				}
				while(sz-- > 1) {
				    obj = head[sz];
				    if (!IS_CONST(obj)) {
					ESTACK_PUSH(s, obj);
				    }
				}
				obj = head[0];
			    }
			    break;
			default:
			    erl_exit(ERTS_ABORT_EXIT, "size_object: bad hashmap type %d\n", MAP_HEADER_TYPE(hdr));
		    }
		    break;
		case SUB_BINARY_SUBTAG:
		    {
			Eterm real_bin;
			ERTS_DECLARE_DUMMY(Uint offset); /* Not used. */
			Uint bitsize;
			Uint bitoffs;
			Uint extra_bytes;
			Eterm hdr;
			ERTS_GET_REAL_BIN(obj, real_bin, offset, bitoffs, bitsize);
			if ((bitsize + bitoffs) > 8) {
			    sum += ERL_SUB_BIN_SIZE;
			    extra_bytes = 2;
			} else if ((bitsize + bitoffs) > 0) {
			    sum += ERL_SUB_BIN_SIZE;
			    extra_bytes = 1;
			} else {
			    extra_bytes = 0;
			}
			hdr = *binary_val(real_bin);
			if (thing_subtag(hdr) == REFC_BINARY_SUBTAG) {
			    sum += PROC_BIN_SIZE;
			} else {
			    sum += heap_bin_size(binary_size(obj)+extra_bytes);
			}
			goto pop_next;
		    }
		    break;
                case BIN_MATCHSTATE_SUBTAG:
		    erl_exit(ERTS_ABORT_EXIT,
			     "size_object: matchstate term not allowed");
		default:
		    sum += thing_arityval(hdr) + 1;
		    goto pop_next;
		}
	    }
	    break;
	case TAG_PRIMARY_IMMED1:
	pop_next:
	    if (ESTACK_ISEMPTY(s)) {
		DESTROY_ESTACK(s);
		VERBOSE_DEBUG("[pid=%T] size was: %u\n", mypid, sum);
		return sum;
	    }
	    obj = ESTACK_POP(s);
	    break;
	default:
	    erl_exit(ERTS_ABORT_EXIT, "size_object: bad tag for %#x\n", obj);
	}
    }
}

/*
 *  Machinery for sharing preserving information
 *  Using a WSTACK but not very transparently; consider refactoring
 */

#define DECLARE_BITSTORE(s)						\
    DECLARE_WSTACK(s);							\
    int WSTK_CONCAT(s,_bitoffs) = 0;					\
    int WSTK_CONCAT(s,_offset) = 0;					\
    UWord WSTK_CONCAT(s,_buffer) = 0

#define DESTROY_BITSTORE(s) DESTROY_WSTACK(s)
#define BITSTORE_PUT(s,i)						\
do {									\
    WSTK_CONCAT(s,_buffer) |= i << WSTK_CONCAT(s,_bitoffs);		\
    WSTK_CONCAT(s,_bitoffs) += 2;					\
    if (WSTK_CONCAT(s,_bitoffs) >= 8*sizeof(UWord)) {			\
	WSTACK_PUSH(s, WSTK_CONCAT(s,_buffer));				\
	WSTK_CONCAT(s,_bitoffs) = 0;					\
	WSTK_CONCAT(s,_buffer) = 0;					\
    }									\
} while(0)
#define BITSTORE_CLOSE(s)						\
do {									\
    if (WSTK_CONCAT(s,_bitoffs) > 0) {					\
	WSTACK_PUSH(s, WSTK_CONCAT(s,_buffer));				\
	WSTK_CONCAT(s,_bitoffs) = 0;					\
    }									\
} while(0)

#define BITSTORE_GET(s)	({						\
    UWord result;							\
    if (WSTK_CONCAT(s,_bitoffs) <= 0) {					\
	WSTK_CONCAT(s,_buffer) = s.wstart[WSTK_CONCAT(s,_offset)];	\
	WSTK_CONCAT(s,_offset)++;					\
	WSTK_CONCAT(s,_bitoffs) = 8*sizeof(UWord);			\
    }									\
    WSTK_CONCAT(s,_bitoffs) -= 2;					\
    result = WSTK_CONCAT(s,_buffer) & 3;				\
    WSTK_CONCAT(s,_buffer) >>= 2;					\
    result;								\
})

#define BOXED_VISITED_MASK	 ((Eterm) 3)
#define BOXED_VISITED		 ((Eterm) 1)
#define BOXED_SHARED_UNPROCESSED ((Eterm) 2)
#define BOXED_SHARED_PROCESSED	 ((Eterm) 3)


/*
 *  Is an object in the local heap of a process?
 */

#define INHEAP_SIMPLE(p, ptr) (					\
    (OLD_HEAP(p) && OLD_HEAP(p) <= ptr && ptr < OLD_HEND(p)) ||	\
    (HEAP_START(p) <= ptr && ptr < HEAP_END(p))			\
  )
#define INHEAP(p, ptr) (					\
    INHEAP_SIMPLE(p, ptr) ||					\
    (force_local ? (force_local = 0, 1) : 0)			\
  )
#define COUNT_OFF_HEAP 0


/*
 *  Return the real size of an object and find sharing information
 *  This currently returns the same as erts_debug:size/1.
 *  It is argued whether the size of subterms in constant pools
 *  should be counted or not.
 */
#if HALFWORD_HEAP
Uint size_shared_rel(Eterm obj, Eterm* base)
#else
Uint size_shared(Eterm obj)
#endif
{
    Eterm saved_obj = obj;
    Uint sum = 0;
    Eterm* ptr;
    Process* myself;

    DECLARE_EQUEUE(s);
    DECLARE_BITSTORE(b);

    myself = erts_get_current_process();
    if (myself == NULL)
	return size_object(obj);

    for (;;) {
	VERBOSE_DEBUG("[size] visiting: %x ", obj);
	switch (primary_tag(obj)) {
	case TAG_PRIMARY_LIST: {
	    Eterm head, tail;
	    VERBOSE_DEBUG("L");
	    ptr = list_val_rel(obj, base);
	    /* we're not counting anything that's outside our heap */
	    if (!COUNT_OFF_HEAP && !INHEAP_SIMPLE(myself, ptr)) {
		goto pop_next;
	    }
	    head = CAR(ptr);
	    tail = CDR(ptr);
	    /* if it's visited, don't count it */
	    if (primary_tag(tail) == TAG_PRIMARY_HEADER ||
		primary_tag(head) == TAG_PRIMARY_HEADER) {
		VERBOSE_DEBUG("!");
		goto pop_next;
	    }
	    /* else make it visited now */
	    switch (primary_tag(tail)) {
	    case TAG_PRIMARY_LIST:
		VERBOSE_DEBUG("/L");
		ptr[1] = (tail - TAG_PRIMARY_LIST) | TAG_PRIMARY_HEADER;
		break;
	    case TAG_PRIMARY_IMMED1:
		VERBOSE_DEBUG("/I");
		CAR(ptr) = (head - primary_tag(head)) | TAG_PRIMARY_HEADER;
		CDR(ptr) = (tail - TAG_PRIMARY_IMMED1) | primary_tag(head);
		break;
	    case TAG_PRIMARY_BOXED:
		VERBOSE_DEBUG("/B saved %d", primary_tag(head));
		BITSTORE_PUT(b, primary_tag(head));
		CAR(ptr) = (head - primary_tag(head)) | TAG_PRIMARY_HEADER;
		CDR(ptr) = (tail - TAG_PRIMARY_BOXED) | TAG_PRIMARY_HEADER;
		break;
	    }
	    /* and count it */
	    sum += 2;
	    if (!IS_CONST(head)) {
		EQUEUE_PUT(s, head);
	    }
	    obj = tail;
	    break;
	}
	case TAG_PRIMARY_BOXED: {
	    Eterm hdr;
	    VERBOSE_DEBUG("B");
	    ptr = boxed_val_rel(obj, base);
	    /* we're not counting anything that's outside our heap */
	    if (!COUNT_OFF_HEAP && !INHEAP_SIMPLE(myself, ptr)) {
		goto pop_next;
	    }
	    hdr = *ptr;
	    /* if it's visited, don't count it */
	    if (primary_tag(hdr) != TAG_PRIMARY_HEADER) {
		VERBOSE_DEBUG("!");
		goto pop_next;
	    }
	    /* else make it visited now */
	    *ptr = (hdr - primary_tag(hdr)) + BOXED_VISITED;
	    /* and count it */
	    ASSERT(is_header(hdr));
	    switch (hdr & _TAG_HEADER_MASK) {
	    case ARITYVAL_SUBTAG: {
		int arity = header_arity(hdr);
		VERBOSE_DEBUG("/T");
		sum += arity + 1;
		if (arity == 0) { /* Empty tuple -- unusual. */
		    VERBOSE_DEBUG("e");
		    goto pop_next;
		}
		while (arity-- > 0) {
		    obj = *++ptr;
		    if (!IS_CONST(obj)) {
			EQUEUE_PUT(s, obj);
		    }
		}
		goto pop_next;
	    }
	    case FUN_SUBTAG: {
		ErlFunThing* funp = (ErlFunThing *) ptr;
		unsigned eterms = 1 /* creator */ + funp->num_free;
		unsigned sz = thing_arityval(hdr);
		VERBOSE_DEBUG("/F");
		sum += 1 /* header */ + sz + eterms;
		ptr += 1 /* header */ + sz;
		while (eterms-- > 0) {
		    obj = *ptr++;
		    if (!IS_CONST(obj)) {
			EQUEUE_PUT(s, obj);
		    }
		}
		goto pop_next;
	    }
	    case SUB_BINARY_SUBTAG: {
		ErlSubBin* sb = (ErlSubBin *) ptr;
		Uint extra_bytes;
		Eterm hdr;
		ASSERT((sb->thing_word & ~BOXED_VISITED_MASK) == HEADER_SUB_BIN);
		if (sb->bitsize + sb->bitoffs > 8) {
		    sum += ERL_SUB_BIN_SIZE;
		    extra_bytes = 2;
		} else if (sb->bitsize + sb->bitoffs > 0) {
		    sum += ERL_SUB_BIN_SIZE;
		    extra_bytes = 1;
		} else {
		    extra_bytes = 0;
		}
		ptr = binary_val_rel(sb->orig, base);
		hdr = (*ptr) & ~BOXED_VISITED_MASK;
		if (thing_subtag(hdr) == REFC_BINARY_SUBTAG) {
		    sum += PROC_BIN_SIZE;
		} else {
		    ASSERT(thing_subtag(hdr) == HEAP_BINARY_SUBTAG);
		    sum += heap_bin_size(binary_size_rel(obj, base) + extra_bytes);
		}
		goto pop_next;
	    }
	    case BIN_MATCHSTATE_SUBTAG:
		erl_exit(ERTS_ABORT_EXIT,
			 "size_shared: matchstate term not allowed");
	    default:
		VERBOSE_DEBUG("/D");
		sum += thing_arityval(hdr) + 1;
		goto pop_next;
	    }
	    break;
	}
	case TAG_PRIMARY_IMMED1:
	    VERBOSE_DEBUG("I");
	pop_next:
	    if (EQUEUE_ISEMPTY(s)) {
		goto cleanup;
	    }
	    obj = EQUEUE_GET(s);
	    break;
	default:
	    erl_exit(ERTS_ABORT_EXIT, "size_shared: bad tag for %#x\n", obj);
	}
	VERBOSE_DEBUG("\n");
    }

cleanup:
    VERBOSE_DEBUG("\n");
    obj = saved_obj;
    BITSTORE_CLOSE(b);
    for (;;) {
	VERBOSE_DEBUG("[size] revisiting: %x ", obj);
	switch (primary_tag(obj)) {
	case TAG_PRIMARY_LIST: {
	    Eterm head, tail;
	    VERBOSE_DEBUG("L");
	    ptr = list_val_rel(obj, base);
	    if (!COUNT_OFF_HEAP && !INHEAP_SIMPLE(myself, ptr)) {
		goto cleanup_next;
	    }
	    head = CAR(ptr);
	    tail = CDR(ptr);
	    /* if not already clean, clean it up */
	    if (primary_tag(tail) == TAG_PRIMARY_HEADER) {
		if (primary_tag(head) == TAG_PRIMARY_HEADER) {
		    Eterm saved = BITSTORE_GET(b);
		    VERBOSE_DEBUG("/B restoring %d", saved);
		    CAR(ptr) = head = (head - TAG_PRIMARY_HEADER) | saved;
		    CDR(ptr) = tail = (tail - TAG_PRIMARY_HEADER) | TAG_PRIMARY_BOXED;
		} else {
		    VERBOSE_DEBUG("/L");
		    CDR(ptr) = tail = (tail - TAG_PRIMARY_HEADER) | TAG_PRIMARY_LIST;
		}
	    } else if (primary_tag(head) == TAG_PRIMARY_HEADER) {
		VERBOSE_DEBUG("/I");
		CAR(ptr) = head = (head - TAG_PRIMARY_HEADER) | primary_tag(tail);
		CDR(ptr) = tail = (tail - primary_tag(tail)) | TAG_PRIMARY_IMMED1;
	    } else {
		VERBOSE_DEBUG("!");
		goto cleanup_next;
	    }
	    /* and its children too */
	    if (!IS_CONST(head)) {
		EQUEUE_PUT_UNCHECKED(s, head);
	    }
	    obj = tail;
	    break;
	}
	case TAG_PRIMARY_BOXED: {
	    Eterm hdr;
	    VERBOSE_DEBUG("B");
	    ptr = boxed_val_rel(obj, base);
	    if (!COUNT_OFF_HEAP && !INHEAP_SIMPLE(myself, ptr)) {
		goto cleanup_next;
	    }
	    hdr = *ptr;
	    /* if not already clean, clean it up */
	    if (primary_tag(hdr) == TAG_PRIMARY_HEADER) {
		goto cleanup_next;
	    }
	    else {
		ASSERT(primary_tag(hdr) == BOXED_VISITED);
		*ptr = hdr = (hdr - BOXED_VISITED) + TAG_PRIMARY_HEADER;
	    }
	    /* and its children too */
	    switch (hdr & _TAG_HEADER_MASK) {
	    case ARITYVAL_SUBTAG: {
		int arity = header_arity(hdr);
		if (arity == 0) { /* Empty tuple -- unusual. */
		    goto cleanup_next;
		}
		while (arity-- > 0) {
		    obj = *++ptr;
		    if (!IS_CONST(obj)) {
			EQUEUE_PUT_UNCHECKED(s, obj);
		    }
		}
		goto cleanup_next;
	    }
	    case FUN_SUBTAG: {
		ErlFunThing* funp = (ErlFunThing *) ptr;
		unsigned eterms = 1 /* creator */ + funp->num_free;
		unsigned sz = thing_arityval(hdr);
		ptr += 1 /* header */ + sz;
		while (eterms-- > 0) {
		    obj = *ptr++;
		    if (!IS_CONST(obj)) {
			EQUEUE_PUT_UNCHECKED(s, obj);
		    }
		}
		goto cleanup_next;
	    }
	    default:
		goto cleanup_next;
	    }
	    break;
	}
	case TAG_PRIMARY_IMMED1:
	cleanup_next:
	    if (EQUEUE_ISEMPTY(s)) {
		goto all_clean;
	    }
	    obj = EQUEUE_GET(s);
	    break;
	default:
	    erl_exit(ERTS_ABORT_EXIT, "size_shared: bad tag for %#x\n", obj);
	}
	VERBOSE_DEBUG("\n");
    }

 all_clean:
    VERBOSE_DEBUG("\n");
    /* Return the result */
    DESTROY_EQUEUE(s);
    DESTROY_BITSTORE(b);
    return sum;
}


/*
 *  Copy a structure to a heap.
 */
Eterm copy_struct(Eterm obj, Uint sz, Eterm** hpp, ErlOffHeap* off_heap)
{
    char* hstart;
    Uint hsize;
    Eterm* htop;
    Eterm* hbot;
    Eterm* hp;
    Eterm* objp;
    Eterm* tp;
    Eterm  res;
    Eterm  elem;
    Eterm* tailp;
    Eterm* argp;
    Eterm* const_tuple;
    Eterm hdr;
    int i;
#ifdef DEBUG
    Eterm org_obj = obj;
    Uint org_sz = sz;
#endif
#ifdef SHCOPY_DEBUG
    Eterm mypid;
#endif

    if (IS_CONST(obj))
	return obj;

#ifdef SHCOPY_DEBUG
    mypid = erts_get_current_pid();
    VERBOSE_DEBUG("[pid=%T] copy_struct %p\n", mypid, obj);
#endif

    DTRACE1(copy_struct, (int32_t)sz);

    hp = htop = *hpp;
    hbot   = htop + sz;
    hstart = (char *)htop;
    hsize = (char*) hbot - hstart;
    const_tuple = 0;

    /* Copy the object onto the heap */
    switch (primary_tag(obj)) {
    case TAG_PRIMARY_LIST:
	argp = &res;
	objp = list_val(obj);
	goto L_copy_list;
    case TAG_PRIMARY_BOXED: argp = &res; goto L_copy_boxed;
    default:
	erl_exit(ERTS_ABORT_EXIT,
		 "%s, line %d: Internal error in copy_struct: 0x%08x\n",
		 __FILE__, __LINE__,obj);
    }

 L_copy:
    while (hp != htop) {
	obj = *hp;

	switch (primary_tag(obj)) {
	case TAG_PRIMARY_IMMED1:
	    hp++;
	    break;
	case TAG_PRIMARY_LIST:
	    objp = list_val(obj);
	    if (ErtsInArea(objp,hstart,hsize)) {
		hp++;
		break;
	    }
	    argp = hp++;
	    /* Fall through */

	L_copy_list:
	    tailp = argp;
	    for (;;) {
		tp = tailp;
		elem = CAR(objp);
		if (IS_CONST(elem)) {
		    hbot -= 2;
		    CAR(hbot) = elem;
		    tailp = &CDR(hbot);
		}
		else {
		    CAR(htop) = elem;
		    tailp = &CDR(htop);
		    htop += 2;
		}
		*tp = make_list(tailp - 1);
		obj = CDR(objp);
		if (!is_list(obj)) {
		    break;
		}
		objp = list_val(obj);
	    }
	    switch (primary_tag(obj)) {
	    case TAG_PRIMARY_IMMED1: *tailp = obj; goto L_copy;
	    case TAG_PRIMARY_BOXED: argp = tailp; goto L_copy_boxed;
	    default:
		erl_exit(ERTS_ABORT_EXIT,
			 "%s, line %d: Internal error in copy_struct: 0x%08x\n",
			 __FILE__, __LINE__,obj);
	    }
	    
	case TAG_PRIMARY_BOXED:
	    if (ErtsInArea(boxed_val(obj),hstart,hsize)) {
		hp++;
		break;
	    }
	    argp = hp++;

	L_copy_boxed:
	    objp = boxed_val(obj);
	    hdr = *objp;
	    switch (hdr & _TAG_HEADER_MASK) {
	    case ARITYVAL_SUBTAG:
		{
		    int const_flag = 1; /* assume constant tuple */
		    i = arityval(hdr);
		    *argp = make_tuple(htop);
		    tp = htop;	/* tp is pointer to new arity value */
		    *htop++ = *objp++; /* copy arity value */
		    while (i--) {
			elem = *objp++;
			if (!IS_CONST(elem)) {
			    const_flag = 0;
			}
			*htop++ = elem;
		    }
		    if (const_flag) {
			const_tuple = tp; /* this is the latest const_tuple */
		    }
		}
		break;
	    case REFC_BINARY_SUBTAG:
		{
		    ProcBin* pb;

		    pb = (ProcBin *) objp;
		    if (pb->flags) {
			erts_emasculate_writable_binary(pb);
		    }
		    i = thing_arityval(*objp) + 1;
		    hbot -= i;
		    tp = hbot;
		    while (i--)  {
			*tp++ = *objp++;
		    }
		    *argp = make_binary(hbot);
		    pb = (ProcBin*) hbot;
		    erts_refc_inc(&pb->val->refc, 2);
		    pb->next = off_heap->first;
		    pb->flags = 0;
		    off_heap->first = (struct erl_off_heap_header*) pb;
		    OH_OVERHEAD(off_heap, pb->size / sizeof(Eterm));
		}
		break;
	    case SUB_BINARY_SUBTAG:
		{
		    ErlSubBin* sb = (ErlSubBin *) objp;
		    Eterm real_bin = sb->orig;
		    Uint bit_offset = sb->bitoffs;
		    Uint bit_size = sb -> bitsize;
		    Uint offset = sb->offs;
		    size_t size = sb->size;
		    Uint extra_bytes;
		    Uint real_size;
		    if ((bit_size + bit_offset) > 8) {
			extra_bytes = 2;
		    } else if ((bit_size + bit_offset) > 0) {
			extra_bytes = 1;
		    } else {
			extra_bytes = 0;
		    } 
		    real_size = size+extra_bytes;
		    objp = binary_val(real_bin);
		    if (thing_subtag(*objp) == HEAP_BINARY_SUBTAG) {
			ErlHeapBin* from = (ErlHeapBin *) objp;
			ErlHeapBin* to;
			i = heap_bin_size(real_size);
			hbot -= i;
			to = (ErlHeapBin *) hbot;
			to->thing_word = header_heap_bin(real_size);
			to->size = real_size;
			sys_memcpy(to->data, ((byte *)from->data)+offset, real_size);
		    } else {
			ProcBin* from = (ProcBin *) objp;
			ProcBin* to;
			
			ASSERT(thing_subtag(*objp) == REFC_BINARY_SUBTAG);
			if (from->flags) {
			    erts_emasculate_writable_binary(from);
			}
			hbot -= PROC_BIN_SIZE;
			to = (ProcBin *) hbot;
			to->thing_word = HEADER_PROC_BIN;
			to->size = real_size;
			to->val = from->val;
			erts_refc_inc(&to->val->refc, 2);
			to->bytes = from->bytes + offset;
			to->next = off_heap->first;
			to->flags = 0;
			off_heap->first = (struct erl_off_heap_header*) to;
			OH_OVERHEAD(off_heap, to->size / sizeof(Eterm));
		    }
		    *argp = make_binary(hbot);
		    if (extra_bytes != 0) {
			ErlSubBin* res;
			hbot -= ERL_SUB_BIN_SIZE;
			res = (ErlSubBin *) hbot;
			res->thing_word = HEADER_SUB_BIN;
			res->size = size;
			res->bitsize = bit_size;
			res->bitoffs = bit_offset;
			res->offs = 0;
			res->is_writable = 0;
			res->orig = *argp;
			*argp = make_binary(hbot);
		    }
		    break;
		}
		break;
	    case FUN_SUBTAG:
		{
		    ErlFunThing* funp = (ErlFunThing *) objp;

		    i =  thing_arityval(hdr) + 2 + funp->num_free;
		    tp = htop;
		    while (i--)  {
			*htop++ = *objp++;
		    }
		    funp = (ErlFunThing *) tp;
		    funp->next = off_heap->first;
		    off_heap->first = (struct erl_off_heap_header*) funp;
		    erts_refc_inc(&funp->fe->refc, 2);
		    *argp = make_fun(tp);
		}
		break;
	    case EXTERNAL_PID_SUBTAG:
	    case EXTERNAL_PORT_SUBTAG:
	    case EXTERNAL_REF_SUBTAG:
		{
		  ExternalThing *etp = (ExternalThing *) htop;

		  i  = thing_arityval(hdr) + 1;
		  tp = htop;

		  while (i--)  {
		    *htop++ = *objp++;
		  }

		  etp->next = off_heap->first;
		  off_heap->first = (struct erl_off_heap_header*)etp;
		  erts_refc_inc(&etp->node->refc, 2);

		  *argp = make_external(tp);
		}
		break;
	    case MAP_SUBTAG:
		tp = htop;
		switch (MAP_HEADER_TYPE(hdr)) {
		    case MAP_HEADER_TAG_FLATMAP_HEAD :
                        i = flatmap_get_size(objp) + 3;
                        *argp = make_flatmap(htop);
                        while (i--) {
                            *htop++ = *objp++;
                        }
			break;
		    case MAP_HEADER_TAG_HAMT_HEAD_BITMAP :
		    case MAP_HEADER_TAG_HAMT_HEAD_ARRAY :
			*htop++ = *objp++;
		    case MAP_HEADER_TAG_HAMT_NODE_BITMAP :
			i = 1 + hashmap_bitcount(MAP_HEADER_VAL(hdr));
			while (i--)  { *htop++ = *objp++; }
			*argp = make_hashmap(tp);
			break;
		    default:
			erl_exit(ERTS_ABORT_EXIT, "copy_struct: bad hashmap type %d\n", MAP_HEADER_TYPE(hdr));
		}
		break;
	    case BIN_MATCHSTATE_SUBTAG:
		erl_exit(ERTS_ABORT_EXIT,
			 "copy_struct: matchstate term not allowed");
	    default:
		i = thing_arityval(hdr)+1;
		hbot -= i;
		tp = hbot;
		*argp = make_boxed(hbot);
		while (i--) {
		    *tp++ = *objp++;
		}
	    }
	    break;
	case TAG_PRIMARY_HEADER:
	    if (header_is_thing(obj) || hp == const_tuple) {
		hp += header_arity(obj) + 1;
	    } else {
		hp++;
	    }
	    break;
	}
    }

#ifdef DEBUG
    if (htop != hbot)
	erl_exit(ERTS_ABORT_EXIT,
		 "Internal error in copy_struct() when copying %T:"
		 " htop=%p != hbot=%p (sz=%beu)\n",
		 org_obj, htop, hbot, org_sz); 
#else
    if (htop > hbot) {
	erl_exit(ERTS_ABORT_EXIT,
		 "Internal error in copy_struct(): htop, hbot overrun\n");
    }
#endif
    *hpp = (Eterm *) (hstart+hsize);
    VERBOSE_DEBUG("[pid=%T] result is at %p\n", mypid, res);
    return res;
}


/*
 *  Machinery for the table used by the sharing preserving copier
 *  Using an ESTACK but not very transparently; consider refactoring
 */

#define DECLARE_SHTABLE(s)					\
    DECLARE_ESTACK(s);						\
    Uint ESTK_CONCAT(s,_offset) = 0
#define DESTROY_SHTABLE(s) DESTROY_ESTACK(s)
#define SHTABLE_INCR 4
#define SHTABLE_NEXT(s)	ESTK_CONCAT(s,_offset)
#define SHTABLE_PUSH(s,x,y,b)					\
do {								\
    if (s.sp > s.end - SHTABLE_INCR) {				\
        erl_grow_estack(&s, ESTK_DEF_STACK(s));			\
    }								\
    *s.sp++ = (x);						\
    *s.sp++ = (y);						\
    *s.sp++ = (Eterm) NULL;					\
    *s.sp++ = (Eterm) (b);	/* bad in HALF_WORD */		\
    ESTK_CONCAT(s,_offset) += SHTABLE_INCR;			\
} while(0)
#define SHTABLE_X(s,e) (s.start[e])
#define SHTABLE_Y(s,e) (s.start[(e)+1])
#define SHTABLE_FWD(s,e) ((Eterm *) (s.start[(e)+2]))
#define SHTABLE_FWD_UPD(s,e,p) (s.start[(e)+2] = (Eterm) (p))
#define SHTABLE_REV(s,e) ((Eterm *) (s.start[(e)+3]))

#define LIST_SHARED_UNPROCESSED ((Eterm) 0)
#define LIST_SHARED_PROCESSED	((Eterm) 1)

#define HEAP_ELEM_TO_BE_FILLED	_unchecked_make_list(NULL)


/*
 *  Specialized macros for using/reusing the persistent state
 */

#define DECLARE_EQUEUE_INIT_INFO(q, info)		\
    UWord* EQUE_DEF_QUEUE(q) = info->queue_default;	\
    ErtsEQueue q = {					\
        EQUE_DEF_QUEUE(q), /* start */			\
        EQUE_DEF_QUEUE(q), /* front */			\
        EQUE_DEF_QUEUE(q), /* back */			\
        1,                 /* possibly_empty */		\
        EQUE_DEF_QUEUE(q) + DEF_EQUEUE_SIZE, /* end */	\
        ERTS_ALC_T_ESTACK  /* alloc_type */		\
    }

#define DECLARE_EQUEUE_FROM_INFO(q, info)		\
    /* no EQUE_DEF_QUEUE(q), read-only */		\
    ErtsEQueue q = {					\
        info->queue_start,      /* start */		\
        info->queue_start,      /* front */		\
        info->queue_start,      /* back */		\
        1,                      /* possibly_empty */	\
        info->queue_end,        /* end */		\
        info->queue_alloc_type  /* alloc_type */	\
    }

#define DECLARE_BITSTORE_INIT_INFO(s, info)		\
    UWord* WSTK_DEF_STACK(s) = info->bitstore_default;	\
    ErtsWStack s = {					\
        WSTK_DEF_STACK(s),  /* wstart */		\
        WSTK_DEF_STACK(s),  /* wsp */			\
        WSTK_DEF_STACK(s) + DEF_WSTACK_SIZE, /* wend */	\
        ERTS_ALC_T_ESTACK /* alloc_type */		\
    };							\
    int WSTK_CONCAT(s,_bitoffs) = 0;			\
    /* no WSTK_CONCAT(s,_offset), write-only */		\
    UWord WSTK_CONCAT(s,_buffer) = 0

#define DECLARE_BITSTORE_FROM_INFO(s, info)		\
    /* no WSTK_DEF_STACK(s), read-only */		\
    ErtsWStack s = {					\
        info->bitstore_start,  /* wstart */		\
        NULL,                  /* wsp, read-only */	\
        NULL,                  /* wend, read-only */	\
        info->bitstore_alloc_type /* alloc_type */	\
    };							\
    int WSTK_CONCAT(s,_bitoffs) = 0;			\
    int WSTK_CONCAT(s,_offset) = 0;			\
    UWord WSTK_CONCAT(s,_buffer) = 0

#define DECLARE_SHTABLE_INIT_INFO(s, info)		\
    Eterm* ESTK_DEF_STACK(s) = info->shtable_default;	\
    ErtsEStack s = {					\
        ESTK_DEF_STACK(s),  /* start */			\
        ESTK_DEF_STACK(s),  /* sp */			\
        ESTK_DEF_STACK(s) + DEF_ESTACK_SIZE, /* end */	\
        ERTS_ALC_T_ESTACK /* alloc_type */		\
    };							\
    Uint ESTK_CONCAT(s,_offset) = 0

#define DECLARE_SHTABLE_FROM_INFO(s, info)		\
    /* no ESTK_DEF_STACK(s), read-only */		\
    ErtsEStack s = {					\
        info->shtable_start,     /* start */		\
        NULL,                    /* sp, read-only */	\
        NULL,                    /* end, read-only */	\
        info->shtable_alloc_type /* alloc_type */	\
    };							\
    /* no ESTK_CONCAT(s,_offset), read-only */

/*
 *  Copy object "obj" preserving sharing.
 *  First half: count size and calculate sharing.
 *  NOTE: We do not support HALF_WORD (yet?).
 */
Uint copy_shared_calculate(Eterm obj, shcopy_info *info, unsigned flags)
{
    Uint sum;
    Uint e;
    unsigned sz;
    Eterm* ptr;
    Process* myself;
    int force_local = flags & ERTS_SHCOPY_FLG_TMP_BUF;

    DECLARE_EQUEUE_INIT_INFO(s, info);
    DECLARE_BITSTORE_INIT_INFO(b, info);
    DECLARE_SHTABLE_INIT_INFO(t, info);

    /* step #0:
       -------------------------------------------------------
       get rid of the easy cases first:
       - copying constants
       - if not a proper process, do flat copy
    */

    if (IS_CONST(obj))
	return 0;

    myself = erts_get_current_process();
    if (myself == NULL || (flags & ERTS_SHCOPY_FLG_NONE))
	return size_object(obj);

    VERBOSE_DEBUG("[pid=%T] copy_shared_calculate %p\n", myself->common.id, obj);
    VERBOSE_DEBUG("[pid=%T] message is %T\n", myself->common.id, obj);

    /* step #1:
       -------------------------------------------------------
       traverse the term and calculate the size;
       when traversing, transform as you do in size_shared
       but when you find shared objects:

       a. add entry in the table, indexed by i
       b. mark them:
	  b1. boxed terms, set header to (i | 11)
	      store (old header, NONV, NULL, backptr) in the entry
	  b2. cons cells, set CDR to NONV, set CAR to i
	      store (old CAR, old CDR, NULL, backptr) in the entry
    */

    sum = 0;

    for (;;) {
	VERBOSE_DEBUG("[copy] visiting: %x ", obj);
	switch (primary_tag(obj)) {
	case TAG_PRIMARY_LIST: {
	    Eterm head, tail;
	    VERBOSE_DEBUG("L");
	    ptr = list_val_rel(obj, base);
	    /* off heap list pointers are copied verbatim */
	    if (!INHEAP(myself, ptr)) {
		VERBOSE_DEBUG("[pid=%T] bypassed copying %p is %T\n", myself->common.id, ptr, obj);
		if (myself->mbuf != NULL)
		    VERBOSE_DEBUG("[pid=%T] BUT !!! there are message buffers!\n", myself->common.id);
		VERBOSE_DEBUG("#");
		goto pop_next;
	    }
	    head = CAR(ptr);
	    tail = CDR(ptr);
	    /* if it's visited, don't count it;
	       if not already shared, make it shared and store it in the table */
	    if (primary_tag(tail) == TAG_PRIMARY_HEADER ||
		primary_tag(head) == TAG_PRIMARY_HEADER) {
		VERBOSE_DEBUG("!");
		if (tail != THE_NON_VALUE) {
		    e = SHTABLE_NEXT(t);
		    VERBOSE_DEBUG("[pid=%T] tabling L %p\n", myself->common.id, ptr);
		    SHTABLE_PUSH(t, head, tail, ptr);
		    CAR(ptr) = (e << _TAG_PRIMARY_SIZE) | LIST_SHARED_UNPROCESSED;
		    CDR(ptr) = THE_NON_VALUE;
		}
		goto pop_next;
	    }
	    /* else make it visited now */
	    switch (primary_tag(tail)) {
	    case TAG_PRIMARY_LIST:
		VERBOSE_DEBUG("/L");
		VERBOSE_DEBUG("[pid=%T] mangling L/L %p\n", myself->common.id, ptr);
		CDR(ptr) = (tail - TAG_PRIMARY_LIST) | TAG_PRIMARY_HEADER;
		break;
	    case TAG_PRIMARY_IMMED1:
		VERBOSE_DEBUG("/I");
		VERBOSE_DEBUG("[pid=%T] mangling L/I %p\n", myself->common.id, ptr);
		CAR(ptr) = (head - primary_tag(head)) | TAG_PRIMARY_HEADER;
		CDR(ptr) = (tail - TAG_PRIMARY_IMMED1) | primary_tag(head);
		break;
	    case TAG_PRIMARY_BOXED:
		VERBOSE_DEBUG("/B saved %d", primary_tag(head));
		BITSTORE_PUT(b, primary_tag(head));
		VERBOSE_DEBUG("[pid=%T] mangling L/B %p\n", myself->common.id, ptr);
		CAR(ptr) = (head - primary_tag(head)) | TAG_PRIMARY_HEADER;
		CDR(ptr) = (tail - TAG_PRIMARY_BOXED) | TAG_PRIMARY_HEADER;
		break;
	    }
	    /* and count it */
	    sum += 2;
	    if (!IS_CONST(head)) {
		EQUEUE_PUT(s, head);
	    }
	    obj = tail;
	    break;
	}
	case TAG_PRIMARY_BOXED: {
	    Eterm hdr;
	    VERBOSE_DEBUG("B");
	    ptr = boxed_val_rel(obj, base);
	    /* off heap pointers to boxes are copied verbatim */
	    if (!INHEAP(myself, ptr)) {
		VERBOSE_DEBUG("[pid=%T] bypassed copying %p is %T\n", myself->common.id, ptr, obj);
		VERBOSE_DEBUG("#");
		goto pop_next;
	    }
	    hdr = *ptr;
	    /* if it's visited, don't count it;
	       if not already shared, make it shared and store it in the table */
	    if (primary_tag(hdr) != TAG_PRIMARY_HEADER) {
		VERBOSE_DEBUG("!");
		if (primary_tag(hdr) == BOXED_VISITED) {
		    e = SHTABLE_NEXT(t);
		    VERBOSE_DEBUG("[pid=%T] tabling B %p\n", myself->common.id, ptr);
		    SHTABLE_PUSH(t, hdr, THE_NON_VALUE, ptr);
		    *ptr = (e << _TAG_PRIMARY_SIZE) | BOXED_SHARED_UNPROCESSED;
		}
		goto pop_next;
	    }
	    /* else make it visited now */
	    VERBOSE_DEBUG("[pid=%T] mangling B %p\n", myself->common.id, ptr);
	    *ptr = (hdr - primary_tag(hdr)) + BOXED_VISITED;
	    /* and count it */
	    ASSERT(is_header(hdr));
	    switch (hdr & _TAG_HEADER_MASK) {
	    case ARITYVAL_SUBTAG: {
		int arity = header_arity(hdr);
		VERBOSE_DEBUG("/T");
		sum += arity + 1;
		if (arity == 0) { /* Empty tuple -- unusual. */
		    VERBOSE_DEBUG("e");
		    goto pop_next;
		}
		while (arity-- > 0) {
		    obj = *++ptr;
		    if (!IS_CONST(obj)) {
			EQUEUE_PUT(s, obj);
		    }
		}
		goto pop_next;
	    }
	    case FUN_SUBTAG: {
		ErlFunThing* funp = (ErlFunThing *) ptr;
		unsigned eterms = 1 /* creator */ + funp->num_free;
		sz = thing_arityval(hdr);
		VERBOSE_DEBUG("/F");
		sum += 1 /* header */ + sz + eterms;
		ptr += 1 /* header */ + sz;
		while (eterms-- > 0) {
		    obj = *ptr++;
		    if (!IS_CONST(obj)) {
			EQUEUE_PUT(s, obj);
		    }
		}
		goto pop_next;
	    }
	    case SUB_BINARY_SUBTAG: {
		ErlSubBin* sb = (ErlSubBin *) ptr;
		Eterm real_bin = sb->orig;
		Uint bit_offset = sb->bitoffs;
		Uint bit_size = sb->bitsize;
		size_t size = sb->size;
		Uint extra_bytes;
		Eterm hdr;
		if (bit_size + bit_offset > 8) {
		    sum += ERL_SUB_BIN_SIZE;
		    extra_bytes = 2;
		} else if (bit_size + bit_offset > 0) {
		    sum += ERL_SUB_BIN_SIZE;
		    extra_bytes = 1;
		} else {
		    extra_bytes = 0;
		}
		ASSERT(is_boxed(rterm2wterm(real_bin, base)) &&
		       (((*boxed_val(rterm2wterm(real_bin, base))) &
			 (_TAG_HEADER_MASK - _BINARY_XXX_MASK - BOXED_VISITED_MASK))
			== _TAG_HEADER_REFC_BIN));
		hdr = *_unchecked_binary_val(rterm2wterm(real_bin, base)) & ~BOXED_VISITED_MASK;
		if (thing_subtag(hdr) == HEAP_BINARY_SUBTAG) {
		    sum += heap_bin_size(size+extra_bytes);
		} else {
		    ASSERT(thing_subtag(hdr) == REFC_BINARY_SUBTAG);
		    sum += PROC_BIN_SIZE;
		}
		goto pop_next;
	    }
	    case BIN_MATCHSTATE_SUBTAG:
		erl_exit(ERTS_ABORT_EXIT,
			 "size_shared: matchstate term not allowed");
	    default:
		VERBOSE_DEBUG("/D");
		sum += thing_arityval(hdr) + 1;
		goto pop_next;
	    }
	    break;
	}
	case TAG_PRIMARY_IMMED1:
	    VERBOSE_DEBUG("I");
	pop_next:
	    if (EQUEUE_ISEMPTY(s)) {
		VERBOSE_DEBUG("\n");
		// add sentinel to the table
		SHTABLE_PUSH(t, THE_NON_VALUE, THE_NON_VALUE, NULL);
		// store persistent info
		BITSTORE_CLOSE(b);
		info->queue_start = s.start;
		info->queue_end = s.end;
                info->queue_alloc_type = s.alloc_type;
		info->bitstore_start = b.wstart;
                info->bitstore_alloc_type = b.alloc_type;
		info->shtable_start = t.start;
                info->shtable_alloc_type = t.alloc_type;
		// single point of return: the size of the object
		VERBOSE_DEBUG("[pid=%T] size was: %u\n", myself->common.id, sum);
		return sum;
	    }
	    obj = EQUEUE_GET(s);
	    break;
	default:
	    erl_exit(ERTS_ABORT_EXIT, "[pid=%T] size_shared: bad tag for %#x\n", obj);
	}
	VERBOSE_DEBUG("\n");
    }
}


/*
 *  Copy object "obj" preserving sharing.
 *  Second half: copy and restore the object.
 *  NOTE: We do not support HALF_WORD (yet?).
 */
Uint copy_shared_perform(Eterm obj, Uint size, shcopy_info *info, Eterm** hpp, ErlOffHeap* off_heap, unsigned flags)
{
    Uint e;
    unsigned sz;
    Eterm* ptr;
    Eterm* hp;
    Eterm* hscan;
    Eterm result;
    Eterm* resp;
    unsigned remaining;
    Process* myself;
    int force_local = flags & ERTS_SHCOPY_FLG_TMP_BUF;
#if defined(DEBUG) || defined(SHCOPY_DEBUG)
    Eterm saved_obj = obj;
#endif

    DECLARE_EQUEUE_FROM_INFO(s, info);
    DECLARE_BITSTORE_FROM_INFO(b, info);
    DECLARE_SHTABLE_FROM_INFO(t, info);

    /* step #0:
       -------------------------------------------------------
       get rid of the easy cases first:
       - copying constants
       - if not a proper process, do flat copy
    */

    if (IS_CONST(obj))
	return obj;

    myself = erts_get_current_process();
    if (myself == NULL || (flags & ERTS_SHCOPY_FLG_NONE))
	return copy_struct(obj, size, hpp, off_heap);

    VERBOSE_DEBUG("[pid=%T] copy_shared_perform %p\n", myself->common.id, obj);

    /* step #2: was performed before this function was called
       -------------------------------------------------------
       allocate new space
    */

    hscan = hp = *hpp;

    /* step #3:
       -------------------------------------------------------
       traverse the term a second time and when traversing:
       a. if the object is marked as shared
	  a1. if the entry contains a forwarding ptr, use that
	  a2. otherwise, copy it to the new space and store the
	      forwarding ptr to the entry
      b. otherwise, reverse-transform as you do in size_shared
	 and copy to the new space
    */

    resp = &result;
    remaining = 0;
    for (;;) {
	VERBOSE_DEBUG("[copy] revisiting: %x ", obj);
	switch (primary_tag(obj)) {
	case TAG_PRIMARY_LIST: {
	    Eterm head, tail;
	    VERBOSE_DEBUG("L");
	    ptr = list_val_rel(obj, base);
	    /* off heap list pointers are copied verbatim */
	    if (!INHEAP(myself, ptr)) {
		VERBOSE_DEBUG("#");
		*resp = obj;
		goto cleanup_next;
	    }
	    head = CAR(ptr);
	    tail = CDR(ptr);
	    /* if it is shared */
	    if (tail == THE_NON_VALUE) {
		e = head >> _TAG_PRIMARY_SIZE;
		/* if it has been processed, just use the forwarding pointer */
		if (primary_tag(head) == LIST_SHARED_PROCESSED) {
		    VERBOSE_DEBUG("!");
		    *resp = make_list(SHTABLE_FWD(t, e));
		    goto cleanup_next;
		}
		/* else, let's process it now,
		   copy it and keep the forwarding pointer */
		else {
		    VERBOSE_DEBUG("$");
		    CAR(ptr) = (head - primary_tag(head)) + LIST_SHARED_PROCESSED;
		    head = SHTABLE_X(t, e);
		    tail = SHTABLE_Y(t, e);
		    ptr = &(SHTABLE_X(t, e));
		    VERBOSE_DEBUG("[pid=%T] tabled L %p is %p\n", myself->common.id, ptr, SHTABLE_REV(t, e));
		    SHTABLE_FWD_UPD(t, e, hp);
		}
	    }
	    /* if not already clean, clean it up and copy it */
	    if (primary_tag(tail) == TAG_PRIMARY_HEADER) {
		if (primary_tag(head) == TAG_PRIMARY_HEADER) {
		    Eterm saved = BITSTORE_GET(b);
		    VERBOSE_DEBUG("/B restoring %d", saved);
		    VERBOSE_DEBUG("[pid=%T] unmangling L/B %p\n", myself->common.id, ptr);
		    CAR(ptr) = head = (head - TAG_PRIMARY_HEADER) + saved;
		    CDR(ptr) = tail = (tail - TAG_PRIMARY_HEADER) + TAG_PRIMARY_BOXED;
		} else {
		    VERBOSE_DEBUG("/L");
		    VERBOSE_DEBUG("[pid=%T] unmangling L/L %p\n", myself->common.id, ptr);
		    CDR(ptr) = tail = (tail - TAG_PRIMARY_HEADER) + TAG_PRIMARY_LIST;
		}
	    } else if (primary_tag(head) == TAG_PRIMARY_HEADER) {
		VERBOSE_DEBUG("/I");
		VERBOSE_DEBUG("[pid=%T] unmangling L/I %p\n", myself->common.id, ptr);
		CAR(ptr) = head = (head - TAG_PRIMARY_HEADER) | primary_tag(tail);
		CDR(ptr) = tail = (tail - primary_tag(tail)) | TAG_PRIMARY_IMMED1;
	    } else {
		ASSERT(0 && "cannot come here");
		goto cleanup_next;
	    }
	    /* and its children too */
	    if (IS_CONST(head)) {
		CAR(hp) = head;
	    } else {
		EQUEUE_PUT_UNCHECKED(s, head);
		CAR(hp) = HEAP_ELEM_TO_BE_FILLED;
	    }
	    *resp = make_list(hp);
	    resp = &(CDR(hp));
	    hp += 2;
	    obj = tail;
	    break;
	}
	case TAG_PRIMARY_BOXED: {
	    Eterm hdr;
	    VERBOSE_DEBUG("B");
	    ptr = boxed_val_rel(obj, base);
	    /* off heap pointers to boxes are copied verbatim */
	    if (!INHEAP(myself, ptr)) {
		VERBOSE_DEBUG("#");
		*resp = obj;
		goto cleanup_next;
	    }
	    hdr = *ptr;
	    /* clean it up, unless it's already clean or shared and processed */
	    switch (primary_tag(hdr)) {
	    case TAG_PRIMARY_HEADER:
		ASSERT(0 && "cannot come here");
	    /* if it is shared and has been processed,
	       just use the forwarding pointer */
	    case BOXED_SHARED_PROCESSED:
		VERBOSE_DEBUG("!");
		e = hdr >> _TAG_PRIMARY_SIZE;
		*resp = make_boxed(SHTABLE_FWD(t, e));
		goto cleanup_next;
	    /* if it is shared but has not been processed yet, let's process
	       it now: copy it and keep the forwarding pointer */
	    case BOXED_SHARED_UNPROCESSED:
		e = hdr >> _TAG_PRIMARY_SIZE;
		VERBOSE_DEBUG("$");
		*ptr = (hdr - primary_tag(hdr)) + BOXED_SHARED_PROCESSED;
		hdr = SHTABLE_X(t, e);
		ASSERT(primary_tag(hdr) == BOXED_VISITED);
		VERBOSE_DEBUG("[pid=%T] tabled B %p is %p\n", myself->common.id, ptr, SHTABLE_REV(t, e));
		VERBOSE_DEBUG("[pid=%T] unmangling B %p\n", myself->common.id, ptr);
		SHTABLE_X(t, e) = hdr = (hdr - BOXED_VISITED) + TAG_PRIMARY_HEADER;
		SHTABLE_FWD_UPD(t, e, hp);
		break;
	    case BOXED_VISITED:
		VERBOSE_DEBUG("[pid=%T] unmangling B %p\n", myself->common.id, ptr);
		*ptr = hdr = (hdr - BOXED_VISITED) + TAG_PRIMARY_HEADER;
		break;
	    }
	    /* and its children too */
	    switch (hdr & _TAG_HEADER_MASK) {
	    case ARITYVAL_SUBTAG: {
		int arity = header_arity(hdr);
		*resp = make_boxed(hp);
		*hp++ = hdr;
		while (arity-- > 0) {
		    obj = *++ptr;
		    if (IS_CONST(obj)) {
			*hp++ = obj;
		    } else {
			EQUEUE_PUT_UNCHECKED(s, obj);
			*hp++ = HEAP_ELEM_TO_BE_FILLED;
		    }
		}
		goto cleanup_next;
	    }
	    case FUN_SUBTAG: {
		ErlFunThing* funp = (ErlFunThing *) ptr;
		unsigned eterms = 1 /* creator */ + funp->num_free;
		sz = thing_arityval(hdr);
		funp = (ErlFunThing *) hp;
		*resp = make_fun(hp);
		*hp++ = hdr;
		ptr++;
		while (sz-- > 0) {
		    *hp++ = *ptr++;
		}
		while (eterms-- > 0) {
		    obj = *ptr++;
		    if (IS_CONST(obj)) {
			*hp++ = obj;
		    } else {
			EQUEUE_PUT_UNCHECKED(s, obj);
			*hp++ = HEAP_ELEM_TO_BE_FILLED;
		    }
		}
		funp->next = off_heap->first;
		off_heap->first = (struct erl_off_heap_header*) funp;
		erts_refc_inc(&funp->fe->refc, 2);
		goto cleanup_next;
	    }
	    case REFC_BINARY_SUBTAG: {
		ProcBin* pb = (ProcBin *) ptr;
		sz = thing_arityval(hdr);
		if (pb->flags) {
		    erts_emasculate_writable_binary(pb);
		}
		pb = (ProcBin *) hp;
		*resp = make_binary(hp);
		*hp++ = hdr;
		ptr++;
		while (sz-- > 0) {
		    *hp++ = *ptr++;
		}
		erts_refc_inc(&pb->val->refc, 2);
		pb->next = off_heap->first;
		pb->flags = 0;
		off_heap->first = (struct erl_off_heap_header*) pb;
		OH_OVERHEAD(off_heap, pb->size / sizeof(Eterm));
		goto cleanup_next;
	    }
	    case SUB_BINARY_SUBTAG: {
		ErlSubBin* sb = (ErlSubBin *) ptr;
		Eterm real_bin = sb->orig;
		Uint bit_offset = sb->bitoffs;
		Uint bit_size = sb->bitsize;
		Uint offset = sb->offs;
		size_t size = sb->size;
		Uint extra_bytes;
		Uint real_size;
		if ((bit_size + bit_offset) > 8) {
		    extra_bytes = 2;
		} else if ((bit_size + bit_offset) > 0) {
		    extra_bytes = 1;
		} else {
		    extra_bytes = 0;
		}
		real_size = size+extra_bytes;
		ASSERT(is_boxed(rterm2wterm(real_bin, base)) &&
		       (((*boxed_val(rterm2wterm(real_bin, base))) &
			 (_TAG_HEADER_MASK - _BINARY_XXX_MASK - BOXED_VISITED_MASK))
			== _TAG_HEADER_REFC_BIN));
		ptr = _unchecked_binary_val(rterm2wterm(real_bin, base));
		*resp = make_binary(hp);
		if (extra_bytes != 0) {
		    ErlSubBin* res = (ErlSubBin *) hp;
		    hp += ERL_SUB_BIN_SIZE;
		    res->thing_word = HEADER_SUB_BIN;
		    res->size = size;
		    res->bitsize = bit_size;
		    res->bitoffs = bit_offset;
		    res->offs = 0;
		    res->is_writable = 0;
		    res->orig = make_binary(hp);
		}
		if (thing_subtag(*ptr & ~BOXED_VISITED_MASK) == HEAP_BINARY_SUBTAG) {
		    ErlHeapBin* from = (ErlHeapBin *) ptr;
		    ErlHeapBin* to = (ErlHeapBin *) hp;
		    hp += heap_bin_size(real_size);
		    to->thing_word = header_heap_bin(real_size);
		    to->size = real_size;
		    sys_memcpy(to->data, ((byte *)from->data)+offset, real_size);
		} else {
		    ProcBin* from = (ProcBin *) ptr;
		    ProcBin* to = (ProcBin *) hp;
		    ASSERT(thing_subtag(*ptr & ~BOXED_VISITED_MASK) == REFC_BINARY_SUBTAG);
		    if (from->flags) {
			erts_emasculate_writable_binary(from);
		    }
		    hp += PROC_BIN_SIZE;
		    to->thing_word = HEADER_PROC_BIN;
		    to->size = real_size;
		    to->val = from->val;
		    erts_refc_inc(&to->val->refc, 2);
		    to->bytes = from->bytes + offset;
		    to->next = off_heap->first;
		    to->flags = 0;
		    off_heap->first = (struct erl_off_heap_header*) to;
		    OH_OVERHEAD(off_heap, to->size / sizeof(Eterm));
		}
		goto cleanup_next;
	    }
	    case EXTERNAL_PID_SUBTAG:
	    case EXTERNAL_PORT_SUBTAG:
	    case EXTERNAL_REF_SUBTAG: {
		ExternalThing *etp = (ExternalThing *) hp;
		sz = thing_arityval(hdr);
		*resp = make_external(hp);
		*hp++ = hdr;
		ptr++;
		while (sz-- > 0) {
		    *hp++ = *ptr++;
		}
		etp->next = off_heap->first;
		off_heap->first = (struct erl_off_heap_header*) etp;
		erts_refc_inc(&etp->node->refc, 2);
		goto cleanup_next;
	    }
	    default:
		sz = thing_arityval(hdr);
		*resp = make_boxed(hp);
		*hp++ = hdr;
		ptr++;
		while (sz-- > 0) {
		    *hp++ = *ptr++;
		}
		goto cleanup_next;
	    }
	    break;
	}
	case TAG_PRIMARY_IMMED1:
	    *resp = obj;
	cleanup_next:
	    if (EQUEUE_ISEMPTY(s)) {
		goto all_clean;
	    }
	    obj = EQUEUE_GET(s);
	    for (;;) {
		ASSERT(hscan < hp);
		if (remaining == 0) {
		    if (*hscan == HEAP_ELEM_TO_BE_FILLED) {
			resp = hscan;
			hscan += 2;
			break; /* scanning loop */
		    } else if (primary_tag(*hscan) == TAG_PRIMARY_HEADER) {
			switch (*hscan & _TAG_HEADER_MASK) {
			case ARITYVAL_SUBTAG:
			    remaining = header_arity(*hscan);
			    hscan++;
			    break;
			case FUN_SUBTAG: {
			    ErlFunThing* funp = (ErlFunThing *) hscan;
			    hscan += 1 + thing_arityval(*hscan);
			    remaining = 1 + funp->num_free;
			    break;
			}
			case SUB_BINARY_SUBTAG:
			    ASSERT(((ErlSubBin *) hscan)->bitoffs +
				   ((ErlSubBin *) hscan)->bitsize > 0);
			    hscan += ERL_SUB_BIN_SIZE;
			    break;
			default:
			    hscan += 1 + thing_arityval(*hscan);
			    break;
			}
		    } else {
			hscan++;
		    }
		} else if (*hscan == HEAP_ELEM_TO_BE_FILLED) {
		    resp = hscan++;
		    remaining--;
		    break; /* scanning loop */
		} else {
		    hscan++;
		    remaining--;
		}
	    }
	    ASSERT(resp < hp);
	    break;
	default:
	    erl_exit(ERTS_ABORT_EXIT, "size_shared: bad tag for %#x\n", obj);
	}
	VERBOSE_DEBUG("\n");
    }

    /* step #4:
       -------------------------------------------------------
       traverse the table and reverse-transform all stored entries
    */

all_clean:
    VERBOSE_DEBUG("\n");
    for (e = 0; ; e += SHTABLE_INCR) {
	ptr = SHTABLE_REV(t, e);
	if (ptr == NULL)
	    break;
	VERBOSE_DEBUG("[copy] restoring shared: %x\n", ptr);
	/* entry was a list */
	if (SHTABLE_Y(t, e) != THE_NON_VALUE) {
	    VERBOSE_DEBUG("[pid=%T] untabling L %p\n", myself->common.id, ptr);
	    CAR(ptr) = SHTABLE_X(t, e);
	    CDR(ptr) = SHTABLE_Y(t, e);
	}
	/* entry was boxed */
	else {
	    VERBOSE_DEBUG("[pid=%T] untabling B %p\n", myself->common.id, ptr);
	    *ptr = SHTABLE_X(t, e);
	    ASSERT(primary_tag(*ptr) == TAG_PRIMARY_HEADER);
	}
    }

#ifdef DEBUG
    if (eq(saved_obj, result) == 0) {
	erts_fprintf(stderr, "original = %T\n", saved_obj);
	erts_fprintf(stderr, "copy = %T\n", result);
	erl_exit(ERTS_ABORT_EXIT, "copy (shared) not equal to source\n");
    }
#endif

    VERBOSE_DEBUG("[pid=%T] original was %T\n", myself->common.id, saved_obj);
    VERBOSE_DEBUG("[pid=%T] copy is %T\n", myself->common.id, result);
    VERBOSE_DEBUG("[pid=%T] result is at %p\n", myself->common.id, result);

    ASSERT(hp == *hpp + size);
    *hpp = hp;
    return result;
}


/*
 * Copy a term that is guaranteed to be contained in a single
 * heap block. The heap block is copied word by word, and any
 * pointers are offsetted to point correctly in the new location.
 *
 * Typically used to copy a term from an ets table.
 *
 * NOTE: Assumes that term is a tuple (ptr is an untagged tuple ptr).
 */
Eterm copy_shallow(Eterm* ptr, Uint sz, Eterm** hpp, ErlOffHeap* off_heap)
{
    Eterm* tp = ptr;
    Eterm* hp = *hpp;
    const Eterm res = make_tuple(hp);
    const Sint offs = (hp - tp) * sizeof(Eterm);

    while (sz--) {
	Eterm val = *tp++;

	switch (primary_tag(val)) {
	case TAG_PRIMARY_IMMED1:
	    *hp++ = val;
	    break;
	case TAG_PRIMARY_LIST:
	case TAG_PRIMARY_BOXED:
	    *hp++ = byte_offset_ptr(val, offs);
	    break;
	case TAG_PRIMARY_HEADER:
	    *hp++ = val;
	    switch (val & _HEADER_SUBTAG_MASK) {
	    case ARITYVAL_SUBTAG:
		break;
	    case REFC_BINARY_SUBTAG:
		{
		    ProcBin* pb = (ProcBin *) (tp-1);
		    erts_refc_inc(&pb->val->refc, 2);
		    OH_OVERHEAD(off_heap, pb->size / sizeof(Eterm));
		}
		goto off_heap_common;

	    case FUN_SUBTAG:
		{
		    ErlFunThing* funp = (ErlFunThing *) (tp-1);
		    erts_refc_inc(&funp->fe->refc, 2);
		}
		goto off_heap_common;
	    case EXTERNAL_PID_SUBTAG:
	    case EXTERNAL_PORT_SUBTAG:
	    case EXTERNAL_REF_SUBTAG:
		{
		    ExternalThing* etp = (ExternalThing *) (tp-1);
		    erts_refc_inc(&etp->node->refc, 2);
		}
	    off_heap_common:
		{
		    struct erl_off_heap_header* ohh = (struct erl_off_heap_header*)(hp-1);
		    int tari = thing_arityval(val);
		    
		    sz -= tari;
		    while (tari--) {
			*hp++ = *tp++;
		    }
		    ohh->next = off_heap->first;
		    off_heap->first = ohh;
		}
		break;
	    default:
		{
		    int tari = header_arity(val);
    
		    sz -= tari;
		    while (tari--) {
			*hp++ = *tp++;
		    }
		}
		break;
	    }
	    break;
	}
    }
    *hpp = hp;
    return res;
}

/* Move all terms in heap fragments into heap. The terms must be guaranteed to 
 * be contained within the fragments. The source terms are destructed with
 * move markers.
 * Typically used to copy a multi-fragmented message (from NIF).
 */
void erts_move_multi_frags(Eterm** hpp, ErlOffHeap* off_heap, ErlHeapFragment* first,
			   Eterm* refs, unsigned nrefs, int literals)
{
    ErlHeapFragment* bp;
    Eterm* hp_start = *hpp;
    Eterm* hp_end;
    Eterm* hp;
    unsigned i;
    Eterm literal_tag;

#ifdef TAG_LITERAL_PTR
    literal_tag = (Eterm) literals ? TAG_LITERAL_PTR : 0;
#else
    literal_tag = (Eterm) 0;
#endif

    for (bp=first; bp!=NULL; bp=bp->next) {
	move_one_frag(hpp, bp, off_heap, literals);
    }
    hp_end = *hpp;
    for (hp=hp_start; hp<hp_end; ++hp) {
	Eterm* ptr;
	Eterm val;
	Eterm gval = *hp;
	switch (primary_tag(gval)) {
	case TAG_PRIMARY_BOXED:
	    ptr = boxed_val(gval);
	    val = *ptr;
	    if (IS_MOVED_BOXED(val)) {
		ASSERT(is_boxed(val));
#ifdef TAG_LITERAL_PTR
		val |= literal_tag;
#endif
		*hp = val;
	    }
	    break;
	case TAG_PRIMARY_LIST:
	    ptr = list_val(gval);
	    val = *ptr;
	    if (IS_MOVED_CONS(val)) {
		val = ptr[1];
#ifdef TAG_LITERAL_PTR
		val |= literal_tag;
#endif
		*hp = val;
	    }
	    break;
	case TAG_PRIMARY_HEADER:
	    if (header_is_thing(gval)) {
		hp += thing_arityval(gval);
	    }
	    break;
	}
    }
    for (i=0; i<nrefs; ++i) {
	refs[i] = follow_moved(refs[i], literal_tag);
    }
}

static void
move_one_frag(Eterm** hpp, ErlHeapFragment* frag, ErlOffHeap* off_heap, int literals)
{
    Eterm* ptr = frag->mem;
    Eterm* end = ptr + frag->used_size;
    Eterm dummy_ref;
    Eterm* hp = *hpp;

    while (ptr != end) {
	Eterm val;
	ASSERT(ptr < end);
	val = *ptr;
	ASSERT(val != ERTS_HOLE_MARKER);
	if (is_header(val)) {
	    struct erl_off_heap_header* hdr = (struct erl_off_heap_header*)hp;
	    ASSERT(ptr + header_arity(val) < end);
	    MOVE_BOXED(ptr, val, hp, &dummy_ref);	    
	    switch (val & _HEADER_SUBTAG_MASK) {
	    case REFC_BINARY_SUBTAG:
	    case FUN_SUBTAG:
	    case EXTERNAL_PID_SUBTAG:
	    case EXTERNAL_PORT_SUBTAG:
	    case EXTERNAL_REF_SUBTAG:
		hdr->next = off_heap->first;
		off_heap->first = hdr;
		break;
	    }
	}
	else { /* must be a cons cell */
	    ASSERT(ptr+1 < end);
	    MOVE_CONS(ptr, val, hp, &dummy_ref);
	    ptr += 2;
	}
    }
    *hpp = hp;
    OH_OVERHEAD(off_heap, frag->off_heap.overhead);
    frag->off_heap.first = NULL;
}