/* Copyright 1992, 1995, 1997 J"orn Rennecke */

#include <sys/mman.h>
#ifdef linux
#include <linux/mman.h>
#define MAP_ANON MAP_ANONYMOUS
#ifndef MAP_FILE
#define MAP_FILE 0
#endif
#endif

#include "common.h"
#include "alloc.h"
#include "object.h"
#include "uid.h"
#include "schedule.h"

int out_of_memory;
union svalue reserved_user_area, reserved_master_area, reserved_system_area;
int malloc_privilege;
size_t pagesize;
uint8 *smallpnt, *smallend;

union svalue ref_inc(union svalue sv) {
    switch((freeable_type)SV_TYPE(sv)) {
      case T_STRING:
      case T_LSTRING:
	/* make_string_global() decrements ref to sv and inc. ref to return val. */
	return make_string_global(sv);
      case T_ISTRING:
	SV_REF(sv)--;
	sv = SV_ISTRING(sv);
	if (!SV_REFINC(sv))
	    break;
      case T_GSTRING:
	SV_REF(sv) = 0x100 - SV_REF_CYCLELEN;
	if (!++SV_STRREF(sv))
	    SV_STRREF(sv)--;
	break;
      case T_ILSTRING:
	SV_REF(sv)--;
	sv = SV_ISTRING(sv);
	if (!SV_REFINC(sv))
	    break;
      case T_GLSTRING:
	SV_REF(sv) = 0x100 - SV_REF_CYCLELEN;
	SV_LSTRREF(sv)++;
	break;
      default:
	fatal("bogus ref_inc\n");
	return SV_NULL;
      case T_MAPPING:
      {
	union svalue sv2;

	SV_REF(sv) = 0x100 - SV_REF_CYCLELEN;
	if (MAP_HAS_X(&SV_MAPPING(sv))) {
	    MAP_REF(&SV_MAPPING(sv))++;
	    break;
	}
	sv2 = ALLOC_TTS(T_INTERNAL, IT_X_MAP, 2,
		sizeof(char *)+ sizeof(struct map_x));
	if (!sv2.i)
	    return sv2;
	SV_MAPPING(sv).x.x = (struct map_x *)&sv2.p[-1];
	break;
      }
      case T_ARRAY:
      {
	svalue xsv;
	struct array_x *x;

	SV_REF(sv) = 0x100 - SV_REF_CYCLELEN;
	xsv = ALLOC(T_INTERNAL, IT_X_ARRAY, sizeof *x);
	if (!xsv.p) {
	    SV_REF(sv)--;
	    sv = TO_SVALUE(&nil_array); /* garbage in garbage out */
	    if (!SV_REFINC(sv))
		break;
	} else {
	    p_int len;

	    x = (struct array_x *)(void *)&xsv.p[3];
#if 0	/* gcc 2.7.0 bug cases extra register to be pushed */
	    x->len = SV_ARRAY(sv).len;
	    x->uid = SV_ARRAY(sv).x.uid;
#else
	    len = SV_ARRAY(sv).len;
	    x->uid = SV_ARRAY(sv).x.uid;
	    x->len = len;
#endif
	    SV_LARRAY_REF(sv) = 1;
	    SV_ARRAY(sv).x.x = x;
	    break;
	}
      }
      case T_LARRAY:
	SV_REF(sv) = 0x100 - SV_REF_CYCLELEN;
	SV_LARRAY_REF(sv)++;
	break;
      case T_CBR_CHAR_LVALUE:
      {
	union svalue sv2;
	SV_REF(sv)--;
	sv2 = *SV_LVALUE(sv).lvalue;
	if (sv2.p != SV_LVALUE(sv).parent.p || !SV_IS_2REF_STRING(sv2)) {
	    sv = SV_NULL;
	    break;
	}
	sv.i = *SV_LVALUE(sv).index2.p << 1;
	break;
      }
      case T_FLOAT:
      {
	union svalue sv2;

	SV_REF(sv)--;
	sv2 = ALLOC_FLOAT;
	if (sv2.p) { /* nomem -> garbage in garbage out */
	    SV_FLOAT(sv2) = SV_FLOAT(sv);
	}
	break;
      }
    }
    return sv;
}

typedef int balance_t;		/* make this the fastest signed integer type */
typedef unsigned ubalance_t;	/* and this the matching unsigned type */

struct free_block {
    p_uint size;
    struct free_block *parent, *left, *right;
    balance_t balance;
};

static void free_large_block (uint8 *sv, p_uint size);
void remove_from_free_tree(struct free_block *p);
void add_to_free_tree(struct free_block *r, p_uint size);
static union svalue alloc_large_block(p_int type, p_uint size);
static union svalue alloc_small_block(p_int type, p_uint size);

#define SMALL_BLOCK_MAX 9
#define SMALL_BLOCK_CMAX (SMALL_BLOCK_MAX * sizeof(char *))
#define ALLOC_OVERHEAD (sizeof(char *))
#define SV_NEXTFREE(sv) (*(void **)(void *)&(sv)[-1])
#define SV_FREEBLOCK(sv) (*(struct free_block *)(void *)&(sv)[sizeof(p_int)-1])
#define SV_PREVFREE(sv) (((struct free_block **)(sv-1))[-1])
#define SIZE_P_INDEX(base, size) \
	(*(void **)(void *)((char *)base + size - ALLOC_OVERHEAD))
#define SIZE_I_INDEX(base, size) \
	(*(p_int *)(void *)((char *)base + size - ALLOC_OVERHEAD))

static uint8 *sftable[SMALL_BLOCK_MAX],
	*sfmtable[SMALL_BLOCK_MAX], *sfstable[SMALL_BLOCK_MAX];

INLINE void free_block(uint8 *sv, mp_int size) {
    if (size <= SMALL_BLOCK_CMAX) {
	SIZE_I_INDEX(adtstat+ALLOC_FREE1, size)++;
	SV_NEXTFREE(sv) = SIZE_P_INDEX(sftable, size);
	SIZE_P_INDEX(sftable, size) = sv;
	return;
    } else {
	free_large_block(sv, size);
    }
}

void init_alloc() {
    char *heap, *small;

    pagesize = getpagesize();
    heap =
      mmap((caddr_t)0, MAX_ALLOCED,
	PROT_READ|PROT_WRITE, MAP_ANON|MAP_PRIVATE, -1, 0);
    if (heap == (caddr_t)-1) switch(errno) {
      default:
        perror("mmap");
        fatal("mmap failed\n");
    }
    ((p_int *)&heap[MAX_ALLOCED])[-1] = C2PI(T_INTERNAL, IT_HEAPEND, 0, 0);
    add_to_free_tree(
      (struct free_block *)(heap+sizeof(p_int)),
      MAX_ALLOCED - sizeof(p_int)
    );
    small =
      mmap((caddr_t)0, MAX_SMALL_ALLOCED,
        PROT_READ|PROT_WRITE, MAP_ANON|MAP_PRIVATE, -1, 0);
    if (small == (caddr_t)-1) switch(errno) {
      default:
        perror("mmap");
        fatal("mmap failed\n");
    }
    smallpnt = small;
    smallend = small + MAX_SMALL_ALLOCED;
}

void free_gen(void * p) {
    free_block(
      (uint8 *)p - sizeof(char *) + 1,
      SV_GENLEN((union svalue)((uint8 *)p - sizeof(char *) + 1))
    );
}

struct searchstr {
    struct searchstr *next;
    char block[4];
};

static RISC_INLINE void _free_array(union svalue sv, p_int offset, p_int size)
{
    union svalue *svp, *end, sv2;

    svp = (union svalue *)(sv.p + offset);
    end = svp + size;
    if (svp < end) {
	do {
	    sv2 = *svp++;
	    FREE_SVALUE(sv2);
	} while (svp < end);
    }
    free_block(sv.p, (uint8 *)end - sv.p + 1);
}

struct searchlstr {
    struct searchlstr *next;
    uint32 len;
    char block[4];
};

void _free_svalue(union svalue sv) {
    p_int size;

    switch((freeable_type)SV_TYPE(sv)) {
      case T_OBJECT:
	/* This can only happen if the total ref has exceeded the minor ref
	 * before.
	 */
	SV_REF(sv) = SV_REF_CYCLELEN;
	O_REF(&SV_OBJECT(sv))--;
	return;
      case T_DESTRUCTED:
	if (O_HAS_X(&SV_OBJECT(sv))) {
	    SV_REF(sv) = SV_REF_CYCLELEN;
	    if (--O_REF(&SV_OBJECT(sv)))
		return;
	}
	_free_object(sv);
	return;
      case T_LONG:
	size = sizeof (char *) + sizeof SV_LONG(sv);
	break;
      case T_FLOAT:
	size = sizeof (char *) + sizeof SV_FLOAT(sv);
	break;
      case T_VARARGS:
	free_varargs(sv);
	return;
      default:
	fatal("bogus free_svalue\n");
	return;
      case T_CLOSURE:
      {
        union svalue ob = SV_CLOSURE(sv).g.ob;

	switch(SV_CLOSURE(sv).g.closure_type) {
	  case CLOSURE_ALIEN_LFUN:
	  case CLOSURE_BOGUS_ALIEN:
            FREE_ALLOCED_SVALUE(ob);
	    ob = SV_CLOSURE(sv).alien.alien;
	    FREE_ALLOCED_SVALUE(ob);
	    size = sizeof SV_CLOSURE(sv).alien;
	    break;
	  case CLOSURE_LFUN:
	  case CLOSURE_IDENTIFIER:
	  case CLOSURE_BOGUS_LFUN:
	    FREE_ALLOCED_SVALUE(ob);
	    size = sizeof SV_CLOSURE(sv).lfun;
	    break;
	  case CLOSURE_BOUND_LAMBDA:
	  {
	    struct lambda_closure *l2;

	    l2 = SV_CLOSURE(sv).bound.lambda;
	    if (--l2->ref) {
		/*  (g)cc should merge this code with the lfun closure code */
		FREE_ALLOCED_SVALUE(ob);
		size = sizeof SV_CLOSURE(sv).bound;
		break;
	    }
	    free_block(sv.p, sizeof SV_CLOSURE(sv).bound);
	    sv = TO_SVALUE(l2);
	  }
	  case CLOSURE_LAMBDA:
	  case CLOSURE_BOGUS_LAMBDA:
	    FREE_ALLOCED_SVALUE(ob);
	  case CLOSURE_UNBOUND_LAMBDA:
	    _free_lambda_closure(sv);
	    return;
	  /* case CLOSURE_BOGUS */
	  default:
	    FREE_ALLOCED_SVALUE(ob);
	    size = sizeof SV_CLOSURE(sv).efun;
	    break;
	}
	break;
      }
      case T_MAPPING:
	SV_REF(sv) = SV_REF_CYCLELEN;
	if (MAP_HAS_X(&SV_MAPPING(sv)) && --MAP_REF(&SV_MAPPING(sv)))
	    return;
	_free_mapping(sv);
	return;
      case T_LARRAY:
      {
	struct array_x *x;
	struct uid *uid;

	SV_REF(sv) = SV_REF_CYCLELEN;
	if (--SV_LARRAY_REF(sv))
	    return;
	x = SV_ARRAY(sv).x.x;
#if 0 /* gcc 2.7.0 problem: allocates %esi */
	free_block((uint8 *)x - sizeof (char *) + 1,
	  sizeof(struct array_x));
	size = x->len;
	uid = x->uid;
#else
	x = (struct array_x *)((uint8 *)x - sizeof (char *) + 1);
	free_block((uint8 *)x, sizeof(struct array_x));
	size = ((struct array_x *)((uint8 *)x - sizeof (char *) + 1))->len;
	uid = ((struct array_x *)((uint8 *)x - sizeof (char *) + 1))->uid;
#endif
	goto got_size;
      case T_ARRAY:
        size = SV_ARRAY(sv).len;
	uid = SV_ARRAY(sv).x.uid;
      got_size:
	uid->num_array--;
	uid->total_array -= size;
	_free_array(sv, offsetof(struct array, member) - 1, size);
	return;
      }
      case T_GLSTRING:
      {
	struct searchlstr **search, *curr, *prev;

	SV_REF(sv) = SV_REF_CYCLELEN;
	if (--SV_LSTRREF(sv))
	    return;
	adtstat[SHS_LFREE]++;
	search = &SV_LSTRNXT(sv);
#if defined(i386) /* save a register push */
	sv.p = (uint8 *)search;
#define search ((struct searchlstr **)sv.p)
#endif
	curr = *search;
	do {
            prev = curr;
            curr = curr->next;
	} while(&curr->next != search);
	prev->next = curr->next;
#ifdef search
	sv.p = (uint8 *)search - sizeof(char *) + 1;
#undef search
#endif
	goto free_lstring;
#if 0
	free_large_block(sv.p, -sizeof(char *) & sizeof(char *)*2 - 1 +
	  sizeof(SV_LSTRNXT(sv)) + sizeof(SV_LSTRLEN(sv)) + SV_LSTRLEN(sv));
	return;
#endif
      }
      case T_ILSTRING:
      {
	union svalue sv2 = SV_ILSTRING(sv);
	FREE_ALLOCED_SVALUE(sv2);
      }
      case T_LSTRING:
      free_lstring:
	free_large_block(sv.p, -sizeof(char *) & sizeof(char *)*2 - 1 +
	  sizeof(SV_ILSTRING(sv)) + sizeof(SV_LSTRLEN(sv)) + SV_LSTRLEN(sv));
	return;
      case T_GSTRING:
      {
	struct searchstr **search, *curr, *prev;

	SV_REF(sv) = SV_REF_CYCLELEN;
	if (--SV_STRREF(sv) < 254 || ++SV_STRREF(sv))
	   return;
	adtstat[SHS_FREE]++;
	search = &SV_STRNXT(sv);
#if defined(i386) /* save a register push */
	sv.p = (uint8 *)search;
#define search ((struct searchstr **)sv.p)
#endif
	curr = *search;
	do {
            prev = curr;
            curr = curr->next;
	} while(&curr->next != search);
	prev->next = curr->next;
#ifdef search
	sv.p = (uint8 *)search - sizeof(char *) + 1;
#endif
	size = -sizeof(char *) & sizeof(char *)*2 - 1 +
	  sizeof(SV_STRNXT(sv)) + SV_STRLEN(sv);
	break;
      }
      case T_ISTRING:
      {
	union svalue sv2 = SV_ISTRING(sv);
	FREE_ALLOCED_SVALUE(sv2);
      }
      case T_STRING:
	size = -sizeof(char *) & sizeof(char *)*2 - 1 +
	  sizeof(SV_ISTRING(sv)) + SV_STRLEN(sv);
	break;
    }
    free_block(sv.p, size);
}

static void free_large_block (uint8 *sv, p_uint size) {
    uint8 type;
    struct free_block *fb;

    adtstat[ALLOC_LFREE]++;
    adtstat[ALLOC_LFREE_TOTAL] += size;
    type = sv[size-1] & T_MASK;
    if (SVTYPE_IS_FREE(type)) {
	if (type & 1) {
	    struct free_block *nxt;

	    fb = &SV_FREEBLOCK(sv);
	    nxt = (struct free_block *)((char *)fb + size);
	    size += nxt->size;
	    remove_from_free_tree(nxt);
	    goto got_fb;
	} else {
	    size += sv[size];
	}
    }
    fb = &SV_FREEBLOCK(sv);
  got_fb:
    if (((uint8 *)fb)[-sizeof(char *)] & AL_PREV_FREE) {
	p_int prev_size;

	if ( !(prev_size = ((uint8 *)fb)[1-2*sizeof(char *)]) ) {
	    prev_size = ((p_int *)fb)[-3];
	    size += prev_size;
	    fb = (struct free_block *)((char *)fb - prev_size);
	    remove_from_free_tree(fb);
	} else {
	    size += prev_size;
	    fb = (struct free_block *)((char *)fb - prev_size);
	}
    }
    ((uint8 *)fb)[size-sizeof(char *)] |= AL_PREV_FREE;
    add_to_free_tree(fb, size);
}

union svalue alloc(p_int type, p_uint len) {
    if (len <= SMALL_BLOCK_CMAX) {
	union svalue sv;

	SIZE_I_INDEX(adtstat+ALLOC_ALLOC1, len)++;
	sv = SIZE_P_INDEX(sftable, len);
	if (sv.i) {
	    SIZE_P_INDEX(sftable, len) = SV_NEXTFREE(sv.p);
	    *(p_int *)&sv.p[-1] = type;
	    return sv;
	}
	return alloc_small_block(type, len);
    } else {
	return alloc_large_block(type, len);
    }
}

void *alloc_gen(mp_int len) {
    union svalue r;

    len += sizeof(char *);
    r = ALLOC_TTS(T_INTERNAL, IT_GENERIC, len, len);
    if (r.i)
	r.p += 3;
    return r.p;
};

static union svalue alloc_small_block(p_int type, p_uint len) {
    /* len <= SMALL_BLOCK_CMAX */

    union svalue sv;
    uint8 *newend;

    sv.p = smallpnt;
    newend = sv.p + pagesize;
    if (newend > smallend) {
	newend = smallend;
    }
    newend -= len;
    if (sv.p <= newend) {
	sv.p++;
	newend++;
	do {
	    SV_NEXTFREE(sv.p) = SIZE_P_INDEX(sftable, len);
	    SIZE_P_INDEX(sftable, len) = sv.p;
	    sv.p += len;
	} while (sv.p <= newend);
	smallpnt = sv.p - 1;
	return alloc(type, len);
    }
    if (malloc_privilege >= ALLOC_MASTER) {
	sv = SIZE_P_INDEX(sfmtable, len);
	if (sv.i) {
	    SIZE_P_INDEX(sfmtable, len) = SV_NEXTFREE(sv.p);
	    *(p_int *)&sv.p[-1] = type;
	    return sv;
	}
    }
    if (malloc_privilege >= ALLOC_SYSTEM) {
	sv = SIZE_P_INDEX(sfstable, len);
	if (sv.i) {
	    SIZE_P_INDEX(sfmtable, len) = SV_NEXTFREE(sv.p);
	    *(p_int *)&sv.p[-1] = type;
	    return sv;
	}
    }
    SIZE_I_INDEX(adtstat+ALLOC_ALLOC1, len)--;
    return SV_NULL;
}

/* prepare two nodes for the free tree that will never be removed,
   so that we can always assume that the tree is and remains non-empty. */
/* some compilers don't understand forward declarations of static vars. */
extern struct free_block dummy2;
static struct free_block dummy =
  { /*size*/0, /*parent*/&dummy2, /*left*/0, /*right*/0, /*balance*/0 };
struct free_block dummy2 =
  { /*size*/0, /*parent*/0, /*left*/&dummy, /*right*/0, /*balance*/-1 };

static struct free_block *free_tree = &dummy2;

void remove_from_free_tree(struct free_block *p) {
    struct free_block *q, *r, *s, *t;

    if (p->left) {
        if (q = p->right) {
	    /* two childs */
	    s = q;
	    for ( ; r = q, q = r->left; );
	    if (r == s) {
		r->left = s = p->left;
		s->parent = r;
		if (r->parent = s = p->parent) {
		    if (p == s->left) {
			s->left  = r;
		    } else {
			s->right = r;
		    }
		} else {
		    free_tree = r;
		}
		r->balance = p->balance;
		p = r;
		goto balance_right;
	    } else {
		t = r->parent;
		if (t->left = s = r->right) {
		    s->parent  = t;
		}
		r->balance = p->balance;
		r->left  = s = p->left;
		s->parent = r;
		r->right = s = p->right;
		s->parent = r;
		if (r->parent = s = p->parent) {
		    if (p == s->left) {
			s->left  = r;
		    } else {
			s->right = r;
		    }
		} else {
		    free_tree = r;
		}
		p = t;
		goto balance_left;
	    }
        } else /* no right child, but left child */ {
            /* We set up the free list in a way so that there will remain at
               least two nodes, and the avl property ensures that the left
               child is a leaf ==> there is a parent */
	    s = p;
	    p = s->parent;
            r = s->left;
            r->parent = p;
	    if (s == p->left) {
	        p->left  = r;
	        goto balance_left;
	    } else {
	        p->right = r;
	        goto balance_right;
	    }
        }
    } else /* no left child */ {
        /* We set up the free list in a way so that there is a node left
           of all used nodes, so there is a parent */
	s = p;
	p = s->parent;
        if(q = r = s->right) {
            r->parent = p;
        }
	if (s == p->left) {
	    p->left  = r;
	    goto balance_left;
	} else {
	    p->right = r;
	    goto balance_right;
	}
    }
balance_q:
    r = p;
    p = q;
    if (r == p->right) {
        balance_t b;
balance_right:
        b = p->balance;
        if (b > 0) {
            p->balance = 0;
            if (q = p->parent) goto balance_q;
            return;
        } else if (b < 0) {
	    r = p->left;
	    b = r->balance;
	    if (b <= 0) {
		/* R-Rotation */
		if (p->left = s = r->right) {
		    s->parent = p;
		}
		r->right = p;
		s = p->parent;
		p->parent = r;
		b += 1;
		r->balance = b;
		b = -b;
		if (r->parent = s) {
		    if (p->balance = b) {
		        if (p == s->left) {
			    s->left  = r;
			    return;
		        } else {
			    s->right = r;
			    return;
		        }
		    }
		    if (p == s->left) {
			/* left from parent */
			goto balance_left_s;
		    } else {
			/* right from parent */
			p = s;
			p->right = r;
			goto balance_right;
		    }
		}
		p->balance = b;
		free_tree = r;
		return;
	    } else /* r->balance == +1 */ {
	        /* LR-Rotation */
	        balance_t b2;

	        t = r->right;
	        b = t->balance;
	        if (p->left  = s = t->right) {
	            s->parent = p;
	        }
	        if (r->right = s = t->left ) {
	            s->parent = r;
	        }
	        t->left  = r;
	        t->right = p;
	        r->parent = t;
	        s = p->parent;
	        p->parent = t;
#ifdef NO_BARREL_SHIFT
		b = -b;
		b2 = b >> 1;
		r->balance = b2;
		b -= b2;
		p->balance = b;
#else
	        b2 = (ubalance_t)b >> (8 * sizeof(b2) - 1);
	        p->balance = b2;
	        b2 = -b2 -b;
	        r->balance = b2;
#endif
	        t->balance = 0;
	        if (t->parent = s) {
	            if (p == s->left) {
	                p = s;
	                s->left  = t;
                        goto balance_left;
	            } else {
	                p = s;
                        s->right = t;
                        goto balance_right;
	            }
	        }
	        free_tree = t;
	        return;
	    }
        } else /* p->balance == 0 */ {
            p->balance = -1;
            return;
        }
    } else /* r == p->left */ {
        balance_t b;

	goto balance_left;
balance_left_s:
	p = s;
	s->left  = r;
balance_left:
        b = p->balance;
        if (b < 0) {
            p->balance = 0;
            if (q = p->parent) goto balance_q;
            return;
        } else if (b > 0) {
	    r = p->right;
	    b = r->balance;
	    if (b >= 0) {
		/* L-Rotation */
		if (p->right = s = r->left) {
		    s->parent = p;
		}
		r->left = p;
		s = p->parent;
		p->parent = r;
		b -= 1;
		r->balance = b;
		b = -b;
		if (r->parent = s) {
		    if (p->balance = b) {
		        if (p == s->left) {
			    s->left  = r;
			    return;
		        } else {
			    s->right = r;
			    return;
		        }
		    }
		    if (p == s->left) {
			/* left from parent */
			goto balance_left_s;
		    } else {
			/* right from parent */
			p = s;
			p->right = r;
			goto balance_right;
		    }
		}
		p->balance = b;
		free_tree = r;
		return;
	    } else /* r->balance == -1 */ {
	        /* RL-Rotation */
	        balance_t b2;

	        t = r->left;
	        b = t->balance;
	        if (p->right = s = t->left ) {
	            s->parent = p;
	        }
	        if (r->left  = s = t->right) {
	            s->parent = r;
	        }
	        t->right = r;
	        t->left  = p;
	        r->parent = t;
	        s = p->parent;
	        p->parent = t;
#ifdef NO_BARREL_SHIFT
		b = -b;
		b2 = b >> 1;
		p->balance = b2;
		b -= b2;
		r->balance = b;
#else
	        b2 = (ubalance_t)b >> (8 * sizeof(b2) - 1);
	        r->balance = b2;
	        b2 = -b2 -b;
	        p->balance = b2;
#endif
	        t->balance = 0;
	        if (t->parent = s) {
	            if (p == s->left) {
	                p = s;
	                s->left  = t;
                        goto balance_left;
	            } else {
                        s->right = t;
	                p = s;
                        goto balance_right;
	            }
	        }
	        free_tree = t;
	        return;
	    }
        } else /* p->balance == 0 */ {
            p->balance++;
            return;
        }
    }
}

void add_to_free_tree(struct free_block *r, p_uint size) {
    struct free_block *p, *q;
    /* When there is a distinction between data and address registers and/or
       accesses, gcc will choose data type for q, so an assignment to q will
       faciliate branching
     */

    ((uint8 *)r)[-sizeof(char *)] = T_LARGEFREE;
    *(p_int*)&((uint8 *)r)[size - 3*sizeof(char *)] = size;
    ((uint8 *)r)[size - 2*sizeof(char *)+1] = 0;
    q = (struct free_block *)size; /* this assignment is a hint for register
    				      choice */
    q = free_tree;
    for ( ; ; /*p = q*/) {
        p = (struct free_block *)q;
        if (size < p->size) {
            if (q = p->left) {
                continue;
            }
            /* add left */
            p->left = r;
            break;
        } else /* >= */ {
            if (q = p->right) {
                continue;
            }
            /* add right */
            p->right = r;
            break;
        }
    }
    r->size    = size;
    r->parent  = p;
    r->left    = 0;
    r->right   = 0;
    r->balance = 0;
    do {
        struct free_block *s;

        if (r == p->left) {
            balance_t b;

            if ( !(b = p->balance) ) {
		/* growth propagation from left side */
		p->balance = -1;
            } else if (b < 0) {
                if (r->balance < 0) {
                    /* R-Rotation */
                    if (p->left = s = r->right) {
                        s->parent = p;
                    }
                    r->right = p;
                    p->balance = 0;
                    r->balance = 0;
                    s = p->parent;
                    p->parent = r;
                    if (r->parent = s) {
			if ( s->left == p) {
			    s->left  = r;
			} else {
			    s->right = r;
			}
                    } else {
                        free_tree = r;
                    }
                } else /* r->balance == +1 */ {
                    /* LR-Rotation */
		    balance_t b2;
                    struct free_block *t = r->right;

                    if (p->left  = s = t->right) {
                        s->parent = p;
                    }
                    /* relocated right subtree */
                    t->right = p;
                    if (r->right = s = t->left ) {
                        s->parent = r;
                    }
                    /* relocated left subtree */
                    t->left  = r;
		    b = t->balance;
#ifdef NO_BARREL_SHIFT
		    b = -b;
		    b2 = b >> 1;
		    r->balance = b2;
		    b -= b2;
		    p->balance = b;
#else
		    b2 = (ubalance_t)b >> (8 * sizeof(b2) - 1);
		    p->balance = b2;
		    b2 = -b2 -b;
		    r->balance = b2;
#endif
                    t->balance = 0;
                    s = p->parent;
                    p->parent = t;
                    r->parent = t;
                    if (t->parent = s) {
			if ( s->left == p) {
			    s->left  = t;
			} else {
			    s->right = t;
			}
                    } else {
                        free_tree = t;
                    }
                }
                break;
            } else /* p->balance == +1 */ {
                p->balance = 0;
                /* growth of left side balanced the node */
                break;
            }
        } else /* r == p->right */ {
            balance_t b;

            if ( !(b = p->balance) ) {
		/* growth propagation from right side */
		p->balance++;
            } else if (b > 0) {
                if (r->balance > 0) {
                    /* L-Rotation */
                    if (p->right = s = r->left) {
                        s->parent = p;
                    }
                    r->left  = p;
                    p->balance = 0;
                    r->balance = 0;
                    s = p->parent;
                    p->parent = r;
                    if (r->parent = s) {
			if ( s->left == p) {
			    s->left  = r;
			} else {
			    s->right = r;
			}
                    } else {
                        free_tree = r;
                    }
                } else /* r->balance == -1 */ {
                    /* RL-Rotation */
		    balance_t b2;
                    struct free_block *t = r->left;

                    if (p->right = s = t->left ) {
                        s->parent = p;
                    }
                    /* relocated left subtree */
                    t->left  = p;
                    if (r->left  = s = t->right) {
                        s->parent = r;
                    }
                    /* relocated right subtree */
                    t->right = r;
		    b = t->balance;
#ifdef NO_BARREL_SHIFT
		    b = -b;
		    b2 = b >> 1;
		    p->balance = b2;
		    b -= b2;
		    r->balance = b;
#else
		    b2 = (ubalance_t)b >> (8 * sizeof(b2) - 1);
		    r->balance = b2;
		    b2 = -b2 -b;
		    p->balance = b2;
#endif
                    t->balance = 0;
                    s = p->parent;
                    p->parent = t;
                    r->parent = t;
                    if (t->parent = s) {
			if ( s->left == p) {
			    s->left  = t;
			} else {
			    s->right = t;
			}
                    } else {
                        free_tree = t;
                    }
                }
                break;
            } else /* p->balance == -1 */ {
                p->balance = 0;
                /* growth of right side balanced the node */
                break;
            }
        }
        r = p;
        p = p->parent;
    } while (q = p);
}

static union svalue alloc_large_block(p_int type, p_uint size)
{
    struct free_block *fit, *q;

retry:
    for (fit = 0, q = free_tree; ; ) {
	struct free_block *p;
	p_uint tempsize;

	p = q;
	tempsize = p->size;
	if (size < tempsize) {
	    fit = p; /* remember this fit */
	    if (q = p->left) {
		continue;
	    }
	    /* We don't need that much, but that's the best fit we have */
	    break;
	} else if (size > tempsize) {
	    if (q = p->right) {
		continue;
	    }
	    break;
	} else /* size == tempsize */ {
	    fit = p;
	    break;
	}
    } /* end for */
    if (fit) {
	p_uint excess_size;

	remove_from_free_tree(fit);
	if ((excess_size = fit->size - size)) {
	    if (excess_size > SMALL_BLOCK_CMAX) {
		add_to_free_tree(
		  (struct free_block *)((uint8 *)fit+size),
		  excess_size
		);
	    } else {
		((uint8 *)fit)[size-sizeof(char *)] = T_SMALLFREE;
		((uint8 *)fit)[size-sizeof(char *)+1] = excess_size;
	    }
	} else {
	    ((uint8 *)fit)[size-sizeof(char *)] &= ~AL_PREV_FREE;
	}
	((p_int *)fit)[-1] = type | ( ((p_int *)fit)[-1] & AL_PREV_FREE );
	return (union svalue)(p_int) ( (uint8 *)fit - sizeof(char *) + 1 );
    } else {
	static char mess1[] =
	  "Temporary out of MEMORY. Freeing user reserve.\n";
	static char mess2[] =
	  "Temporary out of MEMORY. Freeing master reserve.\n";
	static char mess3[] =
	  "Temporary out of MEMORY. Freeing system reserve.\n";
	static char mess4[] =
	  "Totally out of MEMORY.\n";
#define FREE_RESERVED_AREA(area) free_large_block(area.p,((p_int *)(area.p-1))[1])

	SET_JOB(garbage_collection);
	if (reserved_user_area.p) {
	    FREE_RESERVED_AREA(reserved_user_area);
	    reserved_user_area.p = 0;
	    write(2, mess1, sizeof(mess1)-1);
	    goto retry;
	}
	if (malloc_privilege >= ALLOC_MASTER && reserved_master_area.p) {
	    FREE_RESERVED_AREA(reserved_master_area);
	    reserved_master_area.p = 0;
	    write(2, mess2, sizeof(mess2)-1);
	    goto retry;
	}
	if (malloc_privilege >= ALLOC_SYSTEM) {
	    if (reserved_system_area.p) {
		FREE_RESERVED_AREA(reserved_system_area);
		reserved_system_area.p = 0;
		write(2, mess3, sizeof(mess3)-1);
		goto retry;
	    }
	    write(2, mess4, sizeof(mess4)-1);
	    fatal("Out of memory\n");
	}
	adtstat[ALLOC_LALLOC]--;
	adtstat[ALLOC_LALLOC_TOTAL] -= size;
	out_of_memory = 1;
	if (!inter_errno)
	    inter_errno = IE_NOMEM;
	return SV_NULL;
    }
}

void *x_alloc(mp_int size) {
    union svalue block;

    block = ALLOC(T_INTERNAL, IT_X_ALLOCED, size += sizeof(char *));
    if (block.i) {
	*(p_int *)(block.p + sizeof(char *) - 1) = size;
	block.p += 2*sizeof(char *) - 1;
    }
    return (void *)block.p;
}

void x_free(void *p) {
    free_block((char *)p - 2 * sizeof(char *) + 1, ((p_int *)p)[-1]);
}

void *re_x_alloc(void *old, mp_int size) {
    void *new;
    mp_int old_size;

    new = x_alloc(size);
    old_size = ((p_int *)old)[-1] - sizeof(char *);
    if (old_size > size)
	old_size = size;
    amemcpy(new, old, old_size);
    x_free(old);
    return new;
}