/************************************************************************ * * * C Prolog space.c * * ======== ------- * * * * By Fernando Pereira, July 1982. * * EdCAAD, Dept. of Architecture, University of Edinburgh. * * * * Based on the Prolog system written in IMP by Luis Damas for ICL 2900 * * computers, with some contributions by Lawrence Byrd. Stricter types * * and several extensions by Richard O'Keefe, also BACKWARDS support. * * * * Copyright (C) 1982 Fernando Pereira, Luis Damas and Lawrence Byrd. * * Copyright (C) 1984 F.Pereira, L.Damas, L.Byrd and R.A.O'Keefe. * * This module is based on published work by Weinberg? Weisberg? * * * ************************************************************************/ #include "pl.h" #ifdef ERRCHECK static int ReleaseCheck = 1; static int clock = 0; #endif ERRCHECK #define CHAINS 16 #define BUCKET_SIZE 1024 typedef struct Block { struct Block *NextBlock; int BlockSize; } Block, *BlockP; #define MIN_SIZE sizeof(Block)/sizeof(PTR) #define NullB ((BlockP)0) /* Heap and HeapHeader are public just so that save() and restore() in main.c can save and reload the heap. main.c actually thinks that Heap is a character array. That mild delusion is essential to Perq running. Savability is why Heap is a record, too. heap0 used to be duplicated in a 'bottom' field in the Heap record. For a space file which is independent of C-Prolog it should be put back. */ struct { BlockP free[CHAINS+1]; PTR top; Sint used; } Heap; Sint HeapHeader = sizeof Heap; #define FreeChain Heap.free #define Top Heap.top #define Bottom heap0 #define FreeMisc Heap.free[CHAINS] void InitHeap() /* Initialize space tables. Do it only once. */ { register int i = CHAINS+1; while (--i >= 0) FreeChain[i] = NullB; Top = heap0; Heap.used = 0; } #ifdef ERRCHECK #define NOOVERLAP 0 #define SAME 1 #define OVERLAP 2 static int overlap(a, b) register PTR a, b; /* Check for overlap of space in error checking version */ { register BlockP n; int i; for (i = CHAINS+1; --i >= 0;) for (n = FreeChain[i]; n != NullB; n = n->NextBlock) if (b >= (PTR)n && a-n->BlockSize < (PTR)n) return a == (PTR)n ? SAME : OVERLAP; return NOOVERLAP; } #define err(ms) { fprintf(stderr,"%s: %s\n",function,ms); abort(); } #endif ERRCHECK void release(Base, size) PTR Base; register int size; { register BlockP base = (BlockP)Base; register BlockP *list; #ifdef ERRCHECK printf("%lx\t%d\t%ld\trelease\n", base, ++clock, size); fflush(stdout); if (ReleaseCheck) { char *function = "release"; if (size < MIN_SIZE) err("size < MIN_SIZE\n") if (Base < Bottom || Base+size > Top) err("out of bounds") if (Unsigned(Base) & 3) err("misaligned") switch (overlap(Base, Base+size-1)) { case OVERLAP: err("space overlap") case SAME: err("space freed twice"); case NOOVERLAP: break; } } #endif ERRCHECK list = size < CHAINS+MIN_SIZE ? &FreeChain[size-MIN_SIZE] : &FreeMisc; base->NextBlock = *list, base->BlockSize = size, *list = base; Heap.used -= size; } static void CollectGarbage() /* The garbage collection driver */ /* NB: it is really just a free-list compactor; it does not reclaim */ /* space on the stacks. Heap space is reference counted. */ { typedef struct GCPair { BlockP FirstBlock, LastBlock; } GCPair, *GCPairP; GCPairP Garbage = (GCPairP)(vrz == NullP ? auxstk0 : vrz); int Buckets = (Top-Bottom)/BUCKET_SIZE; int i; register BlockP c, q; if ((Top-Bottom)%BUCKET_SIZE != 0) Buckets++; #ifdef ERRCHECK printf(stdout, "CollectGarbage %lx[%d]%lx\n", Bottom,Buckets,Top); fflush(stdout); #endif ERRCHECK if (Garbage+Buckets > (GCPairP)auxmax) return; for (i = 0; i < Buckets; i++) Garbage[i].FirstBlock = Garbage[i].LastBlock = NullB; /* Sort all free lists onto Garbage by address */ { register BlockP *p; register GCPairP s; for (i = CHAINS; i >= 0; i--) { while (c = FreeChain[i]) { FreeChain[i] = c->NextBlock; s = &Garbage[((PTR)(c)-Bottom)/BUCKET_SIZE]; p = &(s->FirstBlock); while ((q = *p) != NullB && q < c) p = &(q->NextBlock); if (!q) s->LastBlock = c; c->NextBlock = q; *p = c; Heap.used += c->BlockSize; } } } /* Merge adjacent pieces of space on the sorted list Garbage */ { register GCPairP Garb = Garbage; for (i = Buckets; i >= 0; i--) { if (Garb[i].FirstBlock == NullB) { Garb[i] = Garb[i+1]; Garb[i+1].FirstBlock = Garb[i+1].LastBlock = NullB; } else if (Garb[i+1].FirstBlock != NullB) { Garb[i].LastBlock->NextBlock = Garb[i+1].FirstBlock; Garb[i+1].FirstBlock = Garb[i+1].LastBlock = NullB; } } for (q = Garb[0].FirstBlock; q != NullB; ) { if ((BlockP)((PTR)(q)+(q->BlockSize)) != q->NextBlock) { q = q->NextBlock; } else { c = q->NextBlock; q->BlockSize += c->BlockSize, q->NextBlock = c->NextBlock; } } } /* Release all items on the merged, sorted list Garbage */ { #ifdef ERRCHECK int t = ReleaseCheck; ReleaseCheck = FALSE; /* may need to remove this for tough bugs */ #endif ERRCHECK q = Garbage[0].FirstBlock; while (q != NullB) { c = q->NextBlock; if (c == NullB && (PTR)(q)+(q->BlockSize) == Top) { Top = (PTR)(q); Heap.used -= q->BlockSize; } release((PTR)q, q->BlockSize); q = c; } #ifdef ERRCHECK ReleaseCheck = t; #endif ERRCHECK } } /* Note: C-Prolog never asks getsp for more than about 200 words. That is why the argument is 'int' rather than 'Sint'. If you use this function on a system where int=short and you want to allocate more than 32k *words* at a time, change 'int'->'Sint'. Change too the argument of release, and the BlockSize field. */ PTR getsp(size) register int size; { int gc = 2; register PTR result; register BlockP b, *l; if (size < MIN_SIZE) { fprintf(stderr,"! Internal error: heap request too small"); Stop(TRUE); } while (gc > 0) { if (size < CHAINS+MIN_SIZE) { /* First try getting an exact fit from the right list */ b = FreeChain[size-MIN_SIZE]; if (b != NullB) { FreeChain[size-MIN_SIZE] = b->NextBlock, result = (PTR)b; goto found; } /* Next try getting space from the top of the heap */ result = Top; if (result+size <= hpmax) { Top += size; goto found; } /* Take the first fit from the Misc list */ for (l = &FreeMisc; b = *l; l = &(b->NextBlock)) { if (b->BlockSize == size) { *l = b->NextBlock, result = (PTR)b; goto found; } else if (b->BlockSize >= size+MIN_SIZE) { *l = b->NextBlock, Heap.used += b->BlockSize-size; release((PTR)b+size, b->BlockSize-size); result = (PTR)b; goto found; } } } else { /* Take the first fit from the Misc list */ for (l = &FreeMisc; b = *l; l = &(b->NextBlock)) { if (b->BlockSize == size) { *l = b->NextBlock, result = (PTR)b; goto found; } else if (b->BlockSize >= size+MIN_SIZE) { *l = b->NextBlock, Heap.used += b->BlockSize-size; release((PTR)b+size, b->BlockSize-size); result = (PTR)b; goto found; } } /* Next try getting space from the top of the heap */ result = Top; if (result+size <= hpmax) { Top += size; goto found; } } CollectGarbage(); gc--; } NoSpace(HeapId); found: #ifdef ERRCHECK printf("%lx\t%d\t%ld\tgetsp\n", result, ++clock, size); fflush(stdout); if (Unsigned(result) & 3) { fprintf(stderr, "getsp misalignment\n"); abort(); } #endif ERRCHECK /* ClearMem(result, size) used to go here, but whenever C-Prolog */ /* calls getsp() it immediately fills in every field, so no need */ Heap.used += size; return result; } void RelocHeap(delta) register Sint delta; /* Relocates the free space chains. */ /* The actual free space has already been moved. */ /* heap0 (== Bottom) has been updated already. */ /* delta is an integer offset, not a word offset */ { register int i; register BlockP *p; for (i = CHAINS+1; --i >= 0;) { p = &FreeChain[i]; while (*p != NullB) { *p = (BlockP)((Sint)*p + delta); p = &((*p)->NextBlock); } } Top = (PTR)((Sint)Top + delta); } Sint HeapUsed() { return Heap.used; } PTR HeapTop() { return Heap.top; } #ifdef 0 This package is based on a CMU thesis, and contains nothing that really deserves a copyright notice. The rest of this file contains code that C-Prolog either never used or used to use but uses no longer. The text is left here in case you find it useful. For almost all applications it is superior to malloc(). /* These simulate the C library heap allocation functions using our own heap -- not used at the moment, but should perhaps be used so that the I/O routines will not interfere with us? Of course we can ensure *that* using setbuf(.). */ char *malloc(size) Uint size; { Uint n = Words(size)+1; register PTR p = getsp(n); if (p == NullP) return NullS; *(Sint*)p = n; return (char *)(p+1); } char *calloc(nelem, elsize) Uint nelem, elsize; { return malloc(nelem*elsize); } free(ptr) PTR ptr; { release(ptr, ptr[-1]); } #ifdef vax #ifdef unix # define ASM 1 /* Use the assembly code inserts in Vax/Unix */ #endif unix #endif vax /* This next routine used to declare char *loc. I have changed it to PTR *loc so that it will be about 4 times as fast on non VAX/UNIX systems. There should be no change in speed on VAX/UNIX systems, as the multiplication by 4 has to be done somewhere. */ ClearMem(loc, num) PTR *loc; Sint num; { #ifdef ASM asm(" ashl $2,8(ap),r0 "); asm(" movc5 $0,*4(ap),$0,r0,*4(ap) "); #else ASM register PTR *l = loc; register Sint n = num; while (--n >= 0) *l++ = NullP; #endif ASM } CopyMem(from, to, num) char *from, *to; Sint num; { #ifdef ASM asm(" movc3 12(ap),*4(ap),*8(ap) "); #else !ASM register char *f = from, *t = to; register Sint n = num; if (f < t) { f += n; t += n; while (--n >= 0) *--t = *--f; } else { while (--n >= 0) *t++ = *f++; } #endif ASM } char *realloc(ptr, size) register PTR ptr; Uint size; { register Uint new = Words(size), old = ptr[-1]-1; if (new < old) { release(ptr+new, old-new); ptr[-1] -= old-new; } else if (new > old) { register PTR p = getsp(new+1); p[0] = new+1; CopyMem(ptr, p+1, sizeof(PTR)*old); release(ptr-1, old+1); return (char *)(p+1); } return (char *)ptr; } #endif 0