/*$Header: /a/rathlin/disk/src/master/edml/EDML4/fam.src/UPTODATE/RCS/store.c,v 5.1 91/09/05 18:24:47 edml Exp Locker: rjg $*/
/*$Log: store.c,v $
 * Revision 5.1  91/09/05  18:24:47  edml
 * Version 4.2 of EdML
 * This version does not yet work on machines with large pointers
 * (e.g. DECmips / SGI) - conficts between ASSIGNED/ZERO/MARKBIT macros
 * 
 * Revision 5.2  91/09/02  06:55:49  ajg
 * *** empty log message ***
 * 
 * 
 * Revision 4.2  90/02/05  12:00:49  rjg
 * Exception traceback, reraise bytecode, UPRecN objects for arrays
 * 
 * Revision 4.1.1.1  90/01/29  12:36:10  rjg
 * See compiler version 1.7.1.1
 * Changes for exception tracing
 * Changed OpNewRaise to recognise the new ?\ (characterised by a NULL
 * exception pattern frame) and to chain back down Ctl Stack printing
 * closure names (stored as first literal field for all functions)
 * OpReRaise same but doesn't set Ctl Stk starting point.
 * Also removed old OpRaise and OpHandle #defines and modified
 * store.c accordingly
 * 
 * Revision 4.0  89/09/20  13:33:24  rjg
 * incorporated RCS
 * */
/* last changed by: */
/* RJG 07-Feb-89 : extended CheckEq to allow eq testing of BigVars */
/* RJG 03-Feb-89 : extended ClassifyObject for BigVar */
#include <stdio.h>
#include "globdefs.h"
#include "structs.h"
#include "globvars.h"
#include "bcodes.h"
#include "debug.h"
/* AJG-NC */
#include "ncglobs.h"
/* MK-GC */
#include <fcntl.h>

extern FatalError();

#ifdef DEBUGinterp
   extern TraceBack();
#else
   TraceBack() { }
#endif

int GCMsgsRequired,GCCount,HeapAllocd[NUM_TYPES];
LWord *OldA,*EndOfX,*BegOfX,*HalfWay,*OldEnd;

#ifdef DYNAMICPTRS
int ptroff, ptrsign;
#endif

static char *ptrbase;

CreateInitialHeapSpace()
{
    if ((ptrbase = (char *)valloc(HeapSize)) == NULL)
        FatalError("Initial heapspace allocation failed\n");
    BegOfASpace = (LWord *)ptrbase;
    MidOfASpace = BegOfASpace + TagSize;
#ifdef DYNAMICPTRS
    ptrsign = ((int)MidOfASpace) & 0x80000000;
    if (ptrsign == 0) ptroff = 1; else ptroff = 0;
#endif
    EndOfASpace = ByteAdd_(BegOfASpace, HeapSize);
    if (Immed_(BegOfASpace))
        FatalError("Unexpected return from alloc.  Wrongly configured?");
    GCCount = 0;
}

/*
  SetUpResAndFree divides unused portion of second generation into the
  `Reserve' and `Free' half spaces.
*/

SetUpResAndFree()
{
    LWord temp;
    LWord len = (LWord)EndOfASpace - (LWord)MidOfASpace;
    len = len/2;
    if (len & 2) len += 2;
/*
 * The code here USED to say "(BegOfASpace + EndOfASpace)/2" with everything
 * cast to LWord to do the arithmetic.  Now think about the effect of this
 * when pointers are negative! The addition overflows and one ends up with
 * a bad half-way pointer!
 */
    HalfWay = (LWord *)((LWord)MidOfASpace + len - 4);
    BegOfX=MidOfASpace;
    EndOfX=MidOfASpace-2;
    MidOfASpace=HalfWay + TagSize;
}

/* AJGDEL (this was the space swaping blurb) */

ResetConstants()
{
    EmptyString    = CurrentState -> EmptyString;
    ProfRef        = CurrentState -> ProfRef; /* access to 'common' funs */
    StartupClosure = CurrentState -> StartupClosure;
    FunIdClos      = CurrentState -> FunIdClosure;
    FunCompText    = CurrentState -> FunCompText;
    XConText       = CurrentState -> XConText;
}


/* RJG 03-Feb-89
 * added BigVar
 */
#define RETURN_(LEN,NPTRS,START) \
  { len = LEN; nptrs = NPTRS; start = START; break;}
#define ClassifyObject_(Obj, len, nptrs, start) \
  switch (Tag_(Obj)) \
  { case TagState:  RETURN_(SizeOfAMState_, PtrsInAMState_ , Obj) \
    case TagProcess:RETURN_(SizeOfAMProcess_, PtrsInAMProcess_, Obj) \
    case TagRec1: \
    case TagUpRec1: RETURN_(SizeOfAMRec1_, PtrsInAMRec1_, Obj) \
    case TagRec2: \
    case TagUpRec2: RETURN_(SizeOfAMRec2_, PtrsInAMRec2_, Obj) \
    case TagRecN: \
    case TagUpRecN: RETURN_(SizeOfAMRecN_(Obj), PtrsInAMRecN_(Obj), Obj) \
    case TagString: \
    case TagReal:   RETURN_(SizeOfAMString_(Obj), PtrsInAMString_, Obj) \
    case TagPlot: \
    case TagVariant:RETURN_(SizeOfAMVariant_, PtrsInAMVariant_, Obj) \
    case TagBigVar: RETURN_(SizeOfAMBigVar_, PtrsInAMBigVar_, Obj) \
    case TagText:   RETURN_(SizeOfAMText_(Obj), PtrsInAMText_, Obj) \
    case TagStack:  RETURN_(SizeOfAMStack_(Obj), \
                            PtrsInAMStack_(Obj,SizeOfAMStack_(Obj)), \
                            ByteAdd_(Obj, *Obj)) \
    default:  InvalidTag(Obj,0); RETURN_(0,0,0)\
  }

static InvalidTag(Obj,Len)
LWord *Obj, Len;
{ LWord *Start;
  printf("Invalid tag word encountered (0x%x) at 0x%x\n",
         PreLWord_(Obj),(LWord)Obj);
  for (Start = Obj-Len-1; Start <= Obj+3; Start++)
    printf("%08x: %08x\n", Start, *Start);
  TraceBack();
  exit(1);
}

wsexchange(addr)
Byte *addr;
{  LWord tmp; tmp = addr[0]; addr[0] = addr[1]; addr[1] = tmp; }

lsexchange(addr)
Byte *addr;
{  LWord tmp; tmp = addr[0]; addr[0] = addr[3]; addr[3] = tmp;
   tmp = addr[1]; addr[1] = addr[2]; addr[2] = tmp; }

ConvertText(txt, OrigByteSexOK)
Text *txt; int OrigByteSexOK;
{
   Byte *pc; int i, len, ci, cl;
   lsexchange((Byte *)&(txt -> literals));
/* AJGDEL 
#ifdef NOSHORTS
   i = txt -> ArgSpaceReq; wsexchange(&i); txt -> ArgSpaceReq = i;
   i = txt -> CtlSpaceReq; wsexchange(&i); txt -> CtlSpaceReq = i;
#else
   wsexchange((Byte *)&(txt -> ArgSpaceReq));
   wsexchange((Byte *)&(txt -> CtlSpaceReq));
#endif
 AJGENDDEL */
   pc = bytecode_(txt);   len = bytecodelength_(txt) - (sizeof(LWord));

   for (i = 0; i < len;)
      switch (pc[i++]) {
      default: break;

      case OpBind: case OpReturn: case OpTailApply_n1: case OpSqueezeB:
      case OpByteNum: case OpGetLocalB: case OpGetFreeB: case OpGetLiteralB:
      case OpJumpB: case OpTrueJumpB: case OpFalseJumpB: case OpDestTailApply:
           i++; break;

      case OpTailApplyB: case OpSlideB: i += 2; break;

      case OpGetLocalW: case OpGetFreeW: case OpGetLiteralW: case OpVariant:
      case OpQuaIs: case OpQuaAs: case OpJumpW: case OpTrueJumpW:
      case OpFalseJumpW: case OpClosure: case OpDumClosure: case OpPop:
      case OpSqueezeW: case OpDestInt: case OpDestNil: case OpDestQCons:
      case OpTuple: case OpQuaDot: case OpDestTuple_n0: case OpUnTrap:
      case OpTailApply_n0: /* [AJG] */ case OpDestString:
      case OpDestBigVar:
           wsexchange(&(pc[i])); i += 2; break;

      case OpDestVariant: case OpRecClosure: case OpSlideW:
      case OpTailApplyW: case OpDestTuple:
           wsexchange(&(pc[i])); wsexchange(&(pc[i+2])); i += 4; break;

      case OpInt:
           lsexchange((Byte *)&(pc[i])); i += 4; break;

      case OpCase: case OpNewHandle: /*rjg 26-Jun*/
           if (!OrigByteSexOK) wsexchange(&(pc[i]));
           /* This next bit needs tidying up ! */
#ifdef oddsex
           cl = (pc[i]<<8) | pc[i+1];
#else
           cl = (pc[i+1]<<8) | pc[i];
#endif
           if (OrigByteSexOK) wsexchange(&(pc[i]));
           i += 2;
           for (ci = 0; ci<cl; ci++) {
               wsexchange(&(pc[i])); i += 2;}
           break;
      }
}

ChangeHeapSex(OrigByteSexOK)
int OrigByteSexOK;
{
   register    LWord *HeapPtr, *start, *finish;
   LWord       len, nptrs;

   for (HeapPtr=BegOfASpace+TagSize;HeapPtr<MidOfASpace; HeapPtr+=len) {
      if (!OrigByteSexOK) lsexchange((Byte *)&(HeapPtr[-1]));
      ClassifyObject_(HeapPtr, len, nptrs, start);
      if (Tag_(HeapPtr) == TagText)
         ConvertText((Text *)HeapPtr, OrigByteSexOK);
      else {
         if (Tag_(HeapPtr) == TagStack) {
            lsexchange((Byte *)&(((Stack *)HeapPtr) -> StkPos));
            lsexchange((Byte *)&(((Stack *)HeapPtr) -> TrapPos));
            if (!OrigByteSexOK)
              ClassifyObject_(HeapPtr, len, nptrs, start);
          }
         else if (Tag_(HeapPtr) == TagProcess) nptrs += 3;
         for(finish = start+nptrs; start<finish; start++) lsexchange((Byte *)start);
         }
      if (OrigByteSexOK) lsexchange((Byte *)&(HeapPtr[-1]));
      };
}


/* 
 * AJG: Change texts to NC4ESML format, allowing applications in NC/SRC 
 */

void Reconfigure(OldOrigin)
LWord *OldOrigin;
{   int ByteSexOK = 1;
    char inbuf[80], arg[80], fname[80]; LWord loc, val;
    printf("]\nHeap reconfiguration phase\n");
    printf("Heap loaded at %x, with %x as the old origin.\n",
           (LWord)BegOfASpace, (LWord)OldOrigin);
    printf("MidOfASpace = 0x%x (size %d)\n", MidOfASpace,
           PtrDiff_(MidOfASpace, BegOfASpace));
    inbuf[0] = 0;
    do {
       if (sscanf(inbuf, "%1s", arg) == 0) arg[0] = '?';
       switch (arg[0]) {
       case 'c': if (ByteSexOK) return;
                 else printf("Byte sex wrong !\n"); break;
       case 'x': exit(0);
       case 'r': Relocate(BegOfASpace, OldOrigin, 0/* !!! */, 0); break;
       case 'b': ChangeHeapSex(ByteSexOK); ByteSexOK = !ByteSexOK; break;
       case 'g': InitCollect(); break;
       case 'w': if (sscanf(inbuf, "%1s %s ", arg, fname) == 2)
                    ExportState(fname, !ByteSexOK, NIL);
                 else printf("Syntax error\n");
                 break;
       case 's': if (sscanf(inbuf, "%1s %x %x", arg, &loc, &val) == 3)
                    *((LWord *)loc) = val;
                 else printf("Syntax error\n");
                 break;
       case 'e': if (sscanf(inbuf, "%1s %x ", arg, &loc) == 2)
                    printf("%x: %x\n", (LWord)loc, *((LWord *)loc));
                 else printf("Syntax error\n");
                 break;
       case 'f': { int i,n,count; LWord *p,a[10];
                   n = sscanf(inbuf, "%1s %x %x %x %x %x %x %x %x %x %x %x ",
                              arg, a,a+1,a+2,a+3,a+4,a+5,a+6,a+7,a+8,a+9)-1;
                   count = 0;
                   if (n >= 1)
                   { for (p=BegOfASpace; p<=MidOfASpace-n; p++) /* beware */
                     { for (i=0; i<n; i++) if (p[i]!=a[i]) goto tough;
                       if ((++count)>20) { printf("(more)\n"); break; }
                       printf("%x\n", p);
                tough: ;
                     }
                   }
                   else printf("Syntax error\n");
                 }
                 break;
       default:  printf("c - continue,\t x - exit,\t r - relocate heap,\t \
b - swap byte sex,\n");
                 printf("f <val 1> ... <val n> - find n consecutive \
values in heap,\n");
                 printf("s <loc> <value> - set loc to value,\t \
e <loc> - examine contents of loc\n");
                 printf("w <file> - write out heap to file,\n"); }
       }
    while ((fputs("> ",stdout),fflush(stdout),fgets(inbuf,80,stdin)) != NULL);
}


/* Relocate(ObjStart,OldOrigin, heapHasWordPtrs, noisy,nativeh):
 *    This routine is called immediately after a raw heap has been loaded
 *    into the A space.  OldOrigin was the origin of the heap in its previous
 *    life.  This routine patches up all pointers in the heap so they are
 *    correct relative to the heap's current position.
 * 
 * AJG: nativeh == 0, %if the heap is the required hybrid native heap
 *                 1, %if to clean heap totally, (all profile = -1)
 */

Relocate(ObjStart, OldOrigin, heapHasWordPtrs, noisy,nativeh)
LWord *OldOrigin, *ObjStart; int heapHasWordPtrs; int noisy,nativeh;
{
    register    LWord *HeapPtr, *start, *finish;
    LWord       len, nptrs;
    int         Offset, i;

#ifndef WORDPTRS
    if (heapHasWordPtrs)
       FatalError("Cannot relocate heap from a word-pointer machine");
   /* Well, we probably can with a bit of work, but I can't be bothered
      thinking about it right now.
    */
#endif

/*PD*/    if ((Offset = PtrDiff_(ObjStart, OldOrigin)) == 0) 
       /* Old and New origins are the same. Return if the pointer sense
          (word vs. byte) is also the same. */
  {} /* do nothing */
#ifdef WORDPTRS
/*PD         if (heapHasWordPtrs)  return; */
#else*
/*PD       if (!heapHasWordPtrs)  return; */
#endif

   /* Offset is a difference between byte pointers, so will need shifting
      for word-pointer machines. */

/*
    if (noisy) {printf("...relocating by %x (bytes)", Offset); fflush(stdout);}
 */

/* AM: the next conditional should also test whether WORDPTRS
   is the same as in the file header (for orion etc heaps) and
   if not take the first (slower) case.
   General need of tidying up, especially removing the acorn32016
   includes to hack round bug for next acorn C version.
*/
#ifdef DYNAMICPTRS
#   define OldPtr_(x)  (signed_(x) != 0 && Immed_(x))
#else
#ifdef NEGPTRS
#   define OldPtr_(x)  (signed_(x)>0)
#else
#   define OldPtr_(x)  (signed_(x)<0)
#endif
#endif

    i = 0;
    if (Immed_(OldOrigin))
       { /* oh dear, -ve heap for +ve ptrs or v.v. */
          for (HeapPtr=ByteAdd_(ObjStart,4);HeapPtr<MidOfASpace; HeapPtr+=len)
             {
        		ClassifyObject_(HeapPtr, len, nptrs, start);
                finish = start + nptrs;
                if (Tag_(HeapPtr) == TagText){
                  if (nativeh) {
                    LWord tmp;
                    Byte *pt1,*pt2;
                    tmp = (HeapPtr[1] >>16) & 0xffff;
                    if ((tmp > 0x8000) && (tmp != 0xffff)) /* WAS NC'd */
                      {
                /* this takes native code and make it BC ! */
                        pt1 = (Byte *) &HeapPtr[2];
                        pt2 = pt1 + ((0x10000 - tmp) - 0x400);
                        tmp = (bytecodelength_(HeapPtr) - 4) - (pt2 - pt1);
                        for(;tmp;tmp--) *pt1++ = *pt2++;
                      }
                    HeapPtr[1] = (0xffff << 16) | BCTAG; /* tag normally */
                                                    /* ie. for not castling */
                  } else { 
                    if ((HeapPtr[1] & 0xffff) != NCTAG)
                        HeapPtr[1] = (0xffff << 16) | BCTAG; /* tag normally */
                  }
                }
                for(;start<finish;start++)
                   if (OldPtr_(*start))
                      {
                         i++;
#ifdef WORDPTRS
                         if (!heapHasWordPtrs)
                            (*start) = (*start + Offset) >> 2;
                         else
                            (*start) += (Offset >> 2);
#else
                         (*start) += Offset;
#endif
                      }
/*
 * Note that here the bit-pattern 0x00000000 is left unaltered. This is
 * a misery if the original heap had positive pointers and the most
 * negative fixnum was present in the heap, since it will have been
 * represented by this pattern and will now not get adjusted the way it
 * really needed to be.  Oh well, maybe nobody uses that value anyway!
 */
                   else if (*start != 0) *start ^= 0x80000000;
             }
       }
    else
       { /* pointers are pointers (aka 68k) */
          for (HeapPtr=ByteAdd_(ObjStart,4);HeapPtr<MidOfASpace; HeapPtr+=len)
             {
                ClassifyObject_(HeapPtr, len, nptrs, start);
                finish = start + nptrs;
                if (Tag_(HeapPtr) == TagText){
                  if (nativeh) {
                    LWord tmp;
                    Byte *pt1,*pt2;
                    tmp = (HeapPtr[1] >>16) & 0xffff;
                    if ((tmp > 0x8000) && (tmp != 0xffff)) /* WAS NC'd */
                      {
                        /* this takes native code and make it BC ! */
                        pt1 = (Byte *) &HeapPtr[2];
                        pt2 = pt1 + ((0x10000 - tmp) - 0x400);
                        tmp = (bytecodelength_(HeapPtr) - 4) - (pt2 - pt1);
                        for(;tmp;tmp--) *pt1++ = *pt2++;
                      }
                    HeapPtr[1] = (0xffff << 16) | BCTAG; /* tag normaly */
                                                    /* ie. for not castling */
                  } else { 
                    if ((HeapPtr[1] & 0xffff) != NCTAG)
                        HeapPtr[1] = (0xffff << 16) | BCTAG; /* tag normaly */
                  }
                }
                for(;start<finish;start++)
                   if (Ptr_(*start))
                      {
                         i++;
#ifdef WORDPTRS
                         if (!heapHasWordPtrs)
                            (*start) = (*start + Offset) >> 2;
                         else
                            (*start) += (Offset >> 2);
#else
                         (*start) += Offset;
#endif
                      }
             }
       }

/*
    if (noisy)
       {
          printf(" (%d pointers relocated)", i);
          fflush(stdout);
       }
*/
 }

LWord nptrs;
LWord *lastprof;   /*[AJG] the profile pointer, points to its last ref */
LWord dynchanged;

/*********************************************************************
  The new collectors; G.M. Kobine Oct 89 - June 90. In case of 
  emergency I may be contacted at Spider Systems after 3/9/90.
  All collectors require only the `A' heap space. Thus when using the
  -h option to get x Kbytes of heap space one gets ONE heap of size 
  x, not two!
*********************************************************************/

/*********************************************************************
  The Partitioning Collector (a.k.a. Special Collector) filters
  references from the other objects in heap to form two distinct 
  areas - `The Pure' and `The References' areas. The Pure area is
  sharable amongst multiple users on the same machine. This has yet
  to be implemented. Try to reduce the size of the References area
  as currently it makes up about 44% of the compiler! Currently all
  UpRecN, UpRec1, State, Stack and Process objects are considered to
  be references.
*********************************************************************/

LWord nptrs,*scanned,*EndScan;

LWord forwarding_address(LWord *p)
{
    return (LWord)((char *)p - ptrbase) | MARKBIT;
}

LWord forwarded(LWord p)
{
    return (LWord)(ptrbase + (p & ~MARKBIT));
}

LWord *SpecialCopyObject(Object)
register LWord *Object;
{   register int i;
    int len;
    /*register*/ LWord *start, *finish, *newobj; 

/* NICK: Sun4 compiler bug? */
    i = (LWord) (Object[-1]);
    if (i & MARKBIT) return (LWord *)forwarded(i);
    else {
        ClassifyObject_(Object, len, nptrs, start);
        HeapAllocd[Tag_(Object)] += len*4;
#ifdef ALIGNREALS
        if ((Tag_(Object) == TagReal) && (((LWord)MidOfASpace & 0x7))) {
           *MidOfASpace = ((0xC000 + TagRecN) << TAGSHIFT); MidOfASpace += 1; }
#endif

        Refs -= len;      /* Copy references to top of heap space */
        newobj = Refs;    /* growing downwards.                   */

        newobj[-1] = Object[-1];
        Object[-1] = forwarding_address(newobj);
        for(i=len-2; i>=0; i--) newobj[i] = Object[i]; 
        return(newobj);
      }
  }

/*
  The following function perfroms a Two Pointer scan of references 
  copied to top of heap during Partitioning collection.
*/

SpecialScanRefs()
{
  LWord *start,*finish,nptrs,*temp,*newobj,*begin;
  register LWord *Object,*refscanned;
  int len;
  register int i;
     
  while ((LWord)EndScan>(LWord)Refs)
    {temp=Refs;
     refscanned=Refs;
     while ((LWord)refscanned<(LWord)EndScan)
       {ClassifyObject_(refscanned,len,nptrs,start);
        refscanned+=len;
        begin=start;
        for(finish=begin+nptrs;begin<finish;begin++)
          {if (Ptr_(*begin))
             {if ((LWord)(*begin)<(LWord)BegOfASpace)
                  {
                   Object=(LWord *)(*begin);
                   i = (LWord)(Object[-1]);
                   if (i & MARKBIT)
                      (*begin)=forwarded(i);
                   else {
                         ClassifyObject_(Object,len,nptrs,begin);
                         HeapAllocd[Tag_(Object)] += len*4;
#ifdef ALIGNREALS
                         if ((Tag_(Object) == TagReal) && 
                             (((LWord)MidOfASpace & 0x7))) {
                           *MidOfASpace = ((0xC000 + TagRecN) << 
                           TAGSHIFT); MidOfASpace += 1; }
#endif
                         switch(Tag_(Object))
                           {case TagUpRecN:
                            case TagUpRec1:
                            case TagStack:
                            case TagState:
                            case TagProcess:
                              Refs -= len;
                              newobj = Refs;
                            break;                      
                            default:
                              newobj = MidOfASpace;
#ifdef acorn32016
                              MidOfASpace = newobj+len;
#else
                              MidOfASpace += len;
#endif
                           }
                         newobj[-1] = Object[-1];
                         Object[-1] = forwarding_address(newobj);
                         for(i=len-2; i>=0; i--) 
                           newobj[i] = Object[i];
                         (*begin)=(LWord)newobj;
                        }
                  }
             }
          }
       }
     EndScan=temp;
    }
}

/*
  The following function performs a Two Pointer scan of the Pure 
  objects copied to the to-space during Partitioning collection.
*/

SpecialScanNew()
{
  LWord *start,*finish,nptrs,*newobj,*begin;
  register LWord *Object;
  int len;
  register int i;
     
  while ((LWord)scanned<(LWord)MidOfASpace)
    {ClassifyObject_(scanned,len,nptrs,start);
     scanned+=len;
     begin=start;
     for(finish=begin+nptrs;begin<finish;begin++)
       {if (Ptr_(*begin))
          {if ((LWord)(*begin)<(LWord)BegOfASpace)
                 {
                   Object=(LWord *)(*begin);
                   i = (LWord) (Object[-1]);
                   if (i & MARKBIT)
                      (*begin)=forwarded(i);
                   else {
                         ClassifyObject_(Object, len, nptrs, start);
                         HeapAllocd[Tag_(Object)] += len*4;
#ifdef ALIGNREALS
                         if ((Tag_(Object) == TagReal) && 
                             (((LWord)MidOfASpace & 0x7))) {
                            *MidOfASpace = ((0xC000 + TagRecN) << 
                            TAGSHIFT); MidOfASpace += 1; }
#endif
                         switch(Tag_(Object))
                           {
                            case TagUpRecN:         
                            case TagUpRec1:                  
                            case TagStack:
                            case TagState:
                            case TagProcess:
                              Refs -= len;
                              newobj = Refs;
                            break;                      
                            default:
                              newobj = MidOfASpace;
#ifdef acorn32016
                              MidOfASpace = newobj+len;
#else
                              MidOfASpace += len;
#endif
                           }
                         (*begin)=(LWord)newobj;
                         newobj[-1] = Object[-1];
                         Object[-1] = forwarding_address(newobj);
                         for(i=len-2; i>=0; i--)
                           newobj[i] = Object[i];
                        }
                 }
          }
       }
    }
}

/*********************************************************************
  The Major Collector garbage collets those obects in the Older
  generation (see my report of 30/5/90). May be possible to improve
  this collector to avoid the extra comparisons indicated below by
  rearranging the heap in some manner.
*********************************************************************/

/*
  The following function performs a Two Pointer scan of the X region
  during Major collections.
*/

ScanX()
{
  LWord *start,*finish,nptrs,*newobj,*begin,texttag;
  register LWord *scan,*Object;
  int len;
  register int i;
                  
  scan=BegOfX;
  while ((LWord)scan<(LWord)EndOfX)
    {ClassifyObject_(scan,len,nptrs,start);
     begin=start;
     scan += len;
     for(finish=begin+nptrs;begin<finish;begin++)
       {if (Ptr_(*begin))
          {if (((LWord)(*begin) < (LWord)(BegOfX-1)) &&
               ((LWord)(*begin) >= (LWord)(Wall)))  /*<<This is the */
                 {                                  /* extra check  */
                  Object=(LWord *)(*begin);         /* that should  */
                  i = (LWord) (Object[-1]);         /* be avoided   */
                  if (i & MARKBIT)                  /* if possible! */
                     (*begin)=forwarded(i);
                  else {
                        ClassifyObject_(Object, len, nptrs, start);
                        HeapAllocd[Tag_(Object)] += len*4;
#ifdef ALIGNREALS
                        if ((Tag_(Object) == TagReal) && 
                            (((LWord)MidOfASpace & 0x7))) {
                          *MidOfASpace = ((0xC000 + TagRecN) << 
                          TAGSHIFT); MidOfASpace += 1; }
#endif
                        newobj = MidOfASpace;

#ifdef PROFILER
                        texttag = (Tag_(Object) == TagText);
#endif

#ifdef acorn32016
                        MidOfASpace = newobj+len;
#else
                        MidOfASpace += len;
#endif
                        (*begin)=(LWord)newobj;
                        newobj[-1] = Object[-1];
                        Object[-1] = forwarding_address(newobj);
                        for(i=len-2; i>=0; i--) newobj[i] = Object[i];
#ifdef PROFILER
                        if (texttag && dynamicprof) {
                          if ((((Text *)newobj)->ProfileVal) > 0){
                            LWord *Tmp,Tmp2;
  /* half the tab */        ((SWord)(((Text *)newobj)->ProfileVal)) >>=  1; 
                            MidOfASpace[-1] = (LWord) (0xC0030002); 
                            MidOfASpace[0] =  (LWord) newobj;   
                            MidOfASpace[1] =  (LWord) lastprof;    
                            lastprof = MidOfASpace;         
                            MidOfASpace += 3; 
                          }
                        }
#endif
                      }
                }
         } 
      } 
   }     
}

  
ScanMajorObjects()
{
  LWord *start,*finish,nptrs,*newobj,*begin,texttag;
  register LWord *scanned,*Object;
  int len;
  register int i;
                  
  scanned=EndOfX+2;
  while ((LWord)scanned < (LWord)MidOfASpace)
    {ClassifyObject_(scanned,len,nptrs,start);
     begin=start;
     scanned += len;
     for(finish=begin+nptrs;begin<finish;begin++)
       {if (Ptr_(*begin))
          {if (((LWord)(*begin) < (LWord)(BegOfX-1)) &&
               ((LWord)(*begin) >= (LWord)(Wall)))   /* Extra check */
                 {
                  Object=(LWord *)(*begin);
                  i = (LWord) (Object[-1]);
                  if (i & MARKBIT)
                     (*begin)=forwarded(i);
                  else {
                        ClassifyObject_(Object, len, nptrs, start);
                        HeapAllocd[Tag_(Object)] += len*4;
#ifdef ALIGNREALS
                        if ((Tag_(Object) == TagReal) && 
                            (((LWord)MidOfASpace & 0x7))) {
                          *MidOfASpace = ((0xC000 + TagRecN) << 
                          TAGSHIFT); MidOfASpace += 1; }
#endif
                        newobj = MidOfASpace;

#ifdef PROFILER
                        texttag = (Tag_(Object) == TagText);
#endif

#ifdef acorn32016
                        MidOfASpace = newobj+len;
#else
                        MidOfASpace += len;
#endif
                        (*begin)=(LWord)newobj;
                        newobj[-1] = Object[-1];
                        Object[-1] = forwarding_address(newobj);
                        for(i=len-2; i>=0; i--) newobj[i] = Object[i];
#ifdef PROFILER
                        if (texttag && dynamicprof) {
                          if ((((Text *)newobj)->ProfileVal) > 0){
                            LWord *Tmp,Tmp2;
  /* half the tab */        ((SWord)(((Text *)newobj)->ProfileVal)) >>=  1; 
                            MidOfASpace[-1] = (LWord) (0xC0030002); 
                            MidOfASpace[0] =  (LWord) newobj;
                            MidOfASpace[1] =  (LWord) lastprof;    
                            lastprof = MidOfASpace;         
                            MidOfASpace += 3; 
                          }
                        }
#endif
                      }
                }
         } 
      } 
   }     
}

ScanRefs()
{
  LWord *start,*finish,*newobj,*begin,nptrs;
  register LWord *scan,*Object;
  int len;
  register int i;

  scan = BegOfRefs;
  while ((LWord)(scan)<(LWord)Wall)
    {ClassifyObject_(scan,len,nptrs,start);
     begin=start;
     scan += len;
     for(finish=begin+nptrs;begin<finish;begin++)
       {if (Ptr_(*begin))
          {if (((LWord)Wall <= (LWord)(*begin)) &&   /* Extra check */
               ((LWord)(*begin) < (LWord)(BegOfX-1)))
                 {
                  Object=(LWord *)(*begin);
                  i = (LWord) (Object[-1]);
                  if (i & MARKBIT)
                     (*begin)=forwarded(i);
                  else {
                        ClassifyObject_(Object, len, nptrs, start);
                        HeapAllocd[Tag_(Object)] += len*4;
#ifdef ALIGNREALS
                        if ((Tag_(Object) == TagReal) && 
                            (((LWord)MidOfASpace & 0x7))) {
                          *MidOfASpace = ((0xC000 + TagRecN) << 
                          TAGSHIFT); MidOfASpace += 1; }
#endif
                        newobj = MidOfASpace;
#ifdef acorn32016
                        MidOfASpace = newobj+len;
#else
                        MidOfASpace += len;
#endif
                        (*begin)=(LWord)newobj;
                        newobj[-1] = Object[-1];
                        Object[-1] = forwarding_address(newobj);
                        for(i=len-2; i>=0; i--) newobj[i] = Object[i];
                       }
                 }
          }
       }
    }
}

/*********************************************************************
  The Minor Collector is the most frequently used of the three 
  collectors and should be kept as efficienct as possible at all times.
*********************************************************************/

ScanMinorObjects()
{
  LWord *start,*finish,nptrs,*newobj,*begin;
  int len;
  register LWord *Object,*scanned;
  register int i;
                  
  scanned=BegOfX;  
  while ((LWord)scanned<(LWord)MidOfASpace)  
    {ClassifyObject_(scanned,len,nptrs,start);
     scanned+=len;
     begin=start;
     for(finish=begin+nptrs;begin<finish;begin++)
       {if (Ptr_(*begin))
          {if (((LWord)(*begin) > (LWord)HalfWay))
                 {
                  Object=(LWord *)(*begin);
                  i = (LWord) (Object[-1]);
                  if (i & MARKBIT)
                     (*begin)=forwarded(i);
                  else {
                        ClassifyObject_(Object, len, nptrs, start);
                        HeapAllocd[Tag_(Object)] += len*4;
#ifdef ALIGNREALS
                        if ((Tag_(Object) == TagReal) && 
                            (((LWord)MidOfASpace & 0x7))) {
                          *MidOfASpace = ((0xC000 + TagRecN) << 
                          TAGSHIFT); MidOfASpace += 1; }
#endif
                        newobj = MidOfASpace;
#ifdef acorn32016
                        MidOfASpace = newobj+len;
#else
                        MidOfASpace += len;
#endif
                        (*begin)=(LWord)newobj;
                        newobj[-1] = Object[-1];
                        Object[-1] = forwarding_address(newobj);
                        for(i=len-2; i>=0; i--) newobj[i] = Object[i];
                       }
                 }
          }
       }
    }     
}

ScanSingleObject(object)
register LWord *object;
{
  LWord *Obj,*newobj,*begin,*start,*finish,nptrs;
  int len;
  register int i;
                             
  ClassifyObject_(object,len,nptrs,start);
  begin=start;
  HeapAllocd [Tag_(object)] += len*4;
  for(finish=begin+nptrs; begin<finish; begin++)
    {if (Ptr_(*begin))
       {if (((LWord)(*begin) > (LWord)HalfWay) /*&&
            ((LWord)(*begin) < (LWord)EndOfASpace)*/) 
              {
               Obj=(LWord *)(*begin);
               i = (LWord) (Obj[-1]);
               if (i & MARKBIT)
                  (*begin)=forwarded(i);
               else {
                     ClassifyObject_(Obj, len, nptrs, start);
                     HeapAllocd[Tag_(Obj)] += len*4;
#ifdef ALIGNREALS
                     if ((Tag_(Obj) == TagReal) && 
                       (((LWord)MidOfASpace & 0x7))) {
                     *MidOfASpace = ((0xC000 + TagRecN) << TAGSHIFT);
                     MidOfASpace += 1; }
#endif

                     newobj = MidOfASpace;
#ifdef acorn32016
                     MidOfASpace = newobj+len;
#else
                     MidOfASpace += len;
#endif

                     (*begin)=(LWord)newobj;
                     newobj[-1] = Obj[-1];
                     Obj[-1] = forwarding_address(newobj);
                     for(i=len-2; i>=0; i--) newobj[i] = Obj[i];
                    }
        }
       }
    }
}

/*
  N.B. The Combined Collector is set up in such a manner that it can
  only deal with ONE process (see lines marked below). 
*/

ScanVector()
{
  LWord *start,*finish,nptrs,*obj,*begin,*newobj;
  register LWord *scan,*Object;
  struct Process *proc;
  Stack *stck;
  int len;
  register int i;
         
  ScanSingleObject((LWord *)CurrentState); /* Scan the state record */
    
  proc=CurrentState -> WaitingProcesses;   /* Collector only scans  */
  ScanSingleObject((LWord *)proc);         /* the first process.    */
         
  stck=proc -> ArgStk;                     /* Scan the stacks       */
  ScanSingleObject((LWord *)stck);
                     
  stck=proc -> CtlStk;
  ScanSingleObject((LWord *)stck);

  scan=EndOfASpace;                        /* Scan the refernces    */
  while((LWord)scan < (LWord)OldEnd)       /* listed in the vector. */
    {obj=(LWord *)(*scan);
     obj[-1] = obj[-1] ^ ASSIGNED;
     scan++;
     ClassifyObject_(obj,len,nptrs,start);
     begin=start;
     for(finish=begin+nptrs;begin<finish;begin++)
       {if (Ptr_(*begin))
          {if (((LWord)(*begin) > (LWord)HalfWay))
                 {
                  Object=(LWord *)(*begin);
                  i = (LWord) (Object[-1]);
                  if (i & MARKBIT)
                     (*begin)=forwarded(i);
                  else {
                        ClassifyObject_(Object, len, nptrs, start);
                        HeapAllocd[Tag_(Object)] += len*4;
#ifdef ALIGNREALS
                        if ((Tag_(Object) == TagReal) && 
                            (((LWord)MidOfASpace & 0x7))) { 
                          *MidOfASpace = ((0xC000 + TagRecN) << 
                          TAGSHIFT); MidOfASpace += 1; }
#endif
                        newobj = MidOfASpace;
#ifdef acorn32016
                        MidOfASpace = newobj+len;
#else
                        MidOfASpace += len;
#endif
                        (*begin)=(LWord)newobj;
                        newobj[-1] = Object[-1];
                        Object[-1] = forwarding_address(newobj);
                        for(i=len-2; i>=0; i--) newobj[i] = Object[i];
                       }
               }
          }
       }
    }
}

/*********************************************************************
  End of new collectors.
*********************************************************************/

/*********************************************************************
  New collectors called from here.
*********************************************************************/

/* sort of the (LWord)BefOf ... line soon (AJG) */

SpecialCopyingGC()
{
    OldA=BegOfASpace;                
                                      /* Divide heap space in two  */
    BegOfASpace = ByteAdd_(BegOfASpace,HeapSize/2);
                                      /* Collect into high address */
    MidOfASpace=BegOfASpace+TagSize;  /* half.                     */
    
    Refs=EndOfASpace+TagSize;
    EndScan=Refs;
    scanned=MidOfASpace;

#ifndef CWIN
    if (GCMsgsRequired) printf("Special Copying...\n");
#endif
    CurrentState = (State *)SpecialCopyObject((LWord *) CurrentState);

    do{
       SpecialScanRefs();
       SpecialScanNew();
      }while (((LWord)scanned<(LWord)MidOfASpace) ||
              ((LWord)EndScan>(LWord)Refs));
    
    Relocator();              /* Move Pure and Refs areas back down */
                              /* down to low address end of heap.   */
}

MajorGC()
{      
#ifndef CWIN
/* ACN thinks that the GC was MUCH to verbose so for CWIN has cut it down */
    if (GCMsgsRequired) printf("Major Copying...\n");
#endif
    MidOfASpace=EndOfX+2;

#ifndef CWIN
    if (GCMsgsRequired) {printf("Scanning Refs...");fflush(stdout); }
#endif
    ScanRefs();

#ifndef CWIN
    if (GCMsgsRequired) {printf("Scanning X...");fflush(stdout); }
#endif
    ScanX();

#ifndef CWIN
    if (GCMsgsRequired) {
      printf("Scanning New Objects...");fflush(stdout);}
#endif
    ScanMajorObjects();

    Shifter();     /* Shift Older generation objects back down to */
    GCCount++;     /* bottom of second generation.                */

}

MinorGC()
{ 
    MidOfASpace=BegOfX;
/* AJGDEL
    if (GCMsgsRequired) { 
        printf("Minor Copying...\n");
        printf("Scanning Vector...");
        fflush(stdout);
    }
*/
    ScanVector();
/*AJGDEL
    if (GCMsgsRequired) {
       printf("Scanning New Objects...");fflush(stdout); }
*/
    ScanMinorObjects();

    EndOfASpace=OldEnd;
    EndOfX=MidOfASpace-2;

    {   LWord end = (LWord)EndOfASpace, wall = (LWord)Wall;
        LWord diff = end - wall;    
        if ((LWord)EndOfX >= wall + diff/2)
        {
#ifdef PROFILER
            if (dynamicprof && ProfRef)
            {   /* stop the GC following needlessly */
                ResetConstants();  /* find the correct ProfRef */
                (ProfRef) -> at = (LWord) lastprof;    
                dynchanged = 1;
            }
#endif 
            MajorGC();
        }
    }

    SetUpResAndFree();
}

Shifter()
{   LWord *scan,*start,*finish,*OldBeg,shift,nptrs,temp;
    int len;
        
    shift=(BegOfX-Wall)*4;
    BegOfX--;
    OldBeg=BegOfX;
#ifndef CWIN
    if (GCMsgsRequired) {
        printf("Moving Objects...");fflush(stdout);}
#endif
    scan=Wall-1;
    while(BegOfX < MidOfASpace-1)
      {(*scan)=(*BegOfX);
       scan++;
       BegOfX++;}   
             
    temp = (LWord)MidOfASpace;
    temp -= shift;
    MidOfASpace = (LWord *)temp;
#ifndef CWIN
    if (GCMsgsRequired) {
    printf("Updating Pointers...");fflush(stdout);}
#endif
    scan=BegOfRefs;
    while((LWord)scan < (LWord)(MidOfASpace-1))
      {ClassifyObject_(scan,len,nptrs,start);
       for(finish=start+nptrs;start<finish;start++)
         {if (Ptr_(*start))
            {if ((LWord)(*start) >= (LWord)(OldBeg))
               (*start)-=shift;
            }
         }
       scan+=len;
      }
}

Relocator()
{   LWord *scan,*dest,*start,*finish,pureshift,refsshift,nptrs,temp;
    int len,i;

    BegOfRefs=MidOfASpace;
    pureshift=(BegOfASpace-OldA)*4;
    refsshift=(Refs-MidOfASpace)*4+pureshift;

#ifndef CWIN
    printf("Moving Pure...");fflush(stdout);
#endif
    scan=BegOfASpace;
    dest=OldA;
    while(scan<MidOfASpace-1)
      {(*dest) = (*scan);
       dest++;
       scan++;}

#ifndef CWIN
    printf("Moving Refs...");fflush(stdout);
#endif
    scan=Refs-1;
    while(scan<EndOfASpace) 
      {(*dest) = (*scan);
       dest++; scan++;}

#ifndef CWIN
    printf("Updating Pointers...");fflush(stdout);
#endif
    scan=OldA+TagSize;
    while(scan<=dest)
      {ClassifyObject_(scan,len,nptrs,start);
       for(finish=start+nptrs;start<finish;start++)
         {if (Ptr_(*start))
            {if ((*start)<(LWord)MidOfASpace)
                  {(*start)-=pureshift;}
            else
              {if ((*start)<(LWord)EndOfASpace)
                    {(*start)-=refsshift;}
              }
            }
         }
       scan+=len;
      }

    MidOfASpace=dest+1;
    Wall=MidOfASpace;
    temp = (LWord)CurrentState;
    temp -= refsshift;
    CurrentState = (State *)temp;

    temp = (LWord)BegOfRefs;
    temp -= pureshift;
    BegOfRefs = (LWord *)temp;
    BegOfASpace=OldA;

#ifndef CWIN
    printf("Complete.\n");
#endif
}        

Byte SpecialCollection=0;

LWord *CommonCollect(len,obj)
int len; LWord *obj;
{
    int i; register LWord *newobj, *pos;

#ifdef DEBUGinterp
    Byte savednextbyte;
    savednextbyte = nextbyte; nextbyte = 0;
#endif

#ifdef acorn32016
    newobj = MidOfASpace; MidOfASpace = ByteAdd_(newobj, -len);
#else
    MidOfASpace = ByteAdd_(MidOfASpace, -len);  /* AM: see AllocObject_ */
#endif

    pos = NIL;

    pagerand(); 

    if (GCMsgsRequired = cbool_(CurrentState -> GCMsgs -> at))
        printf("[GC: ");

    SaveProcessState();

#ifdef PROFILER
    dynchanged = 0;
    lastprof= 0;    
#endif
/*    if (!dynamicprof) { if (ProfRef) {ProfRef->at = (LWord) 0; }}*/

#ifdef NATIVE
  NativeToTagged(); /* [AJG: box the pointers used in NC returns ] */
#endif

    for (i=NUM_TYPES-1; i>=0; HeapAllocd[i] = 0, i--);

#ifdef transputer
   /* NICK: The transputer implementation uses the on-chip cache for its stack,
      of which there isn't very much. Don't try to use the (recursive!)
      copying collector. */
#else
    if (cbool_(CurrentState -> CompactGC -> at))
        printf("Can't CompactionGC, Sorry\n");
    if (!BegOfRefs || SpecialCollection)
      { MinorGC(); 
        if((EndOfX-BegOfASpace)<HeapSize/8)
          {
            /* put patch here to stop needless following of profiler 
               info - see previous version */
            SpecialCopyingGC();
            Wall=MidOfASpace;
            SetUpResAndFree();
            GCCount++;
          }
        else
          {
            printf("\nInsufficient heap space to Special Collect!\n");
            printf("Overriding request.%c\n",7);
          }
      }
    else MinorGC();
#endif              /* transputer */

    if (GCMsgsRequired) {
        printf("%d%% (%d/%d Kbytes) used",
            (PtrDiff_(EndOfX,BegOfASpace) * 100) / HeapSize,
            PtrDiff_(EndOfX,BegOfASpace)/1024,
            HeapSize/1024);
#ifdef CWIN
        printf("]\n");
#else
        printf(".\nSpace used (in bytes)\n\
States %d, Processes %d,Refs %d, Rec(1) %d, Rec(2) %d,\n\
Rec(N) %d, Strings/Numbers %d, Variants %d, Bytecodes %d,\n\
Stacks %d, Bigvariants %d]\n",
            HeapAllocd[0],HeapAllocd[1],HeapAllocd[9],
            HeapAllocd[2]+HeapAllocd[9],
            HeapAllocd[3]+HeapAllocd[10],HeapAllocd[4]+HeapAllocd[11],
            HeapAllocd[5]+HeapAllocd[12]+HeapAllocd[13],
            HeapAllocd[6],HeapAllocd[7],HeapAllocd[8],HeapAllocd[14]);
#endif
        }

    ResetConstants();  SetTopProcess();  

#ifdef PROFILER
    if(dynamicprof && dynchanged && ProfRef)
      ProfRef->at = (LWord) lastprof; /* Place at Top Level */
#endif

     RestoreProcessState();

#ifdef NATIVE
    TaggedToNative();  /* [AJG: (re) box the pointers used in NC returns ] */
                      /* note: (1) the async, of S,N2T,R,N2T */
                      /*       (2) very like NT switch */
#endif

    pagenorm(); GCCount++;

#ifdef DEBUGinterp
    nextbyte = savednextbyte;
#endif

    fflush(stdout);
    if (len > 0) {
        if ((MidOfASpace = ByteAdd_(newobj=MidOfASpace,len)) > EndOfASpace)
            { printf("Heap space exhausted.\n"); exit(0); }
        return(newobj);  }
    else return(NIL); /* AJG: use to be  "else return(pos);" */
}

LWord *Collect(len)
int len;
{   LWord *res; 
    res = CommonCollect(len,NIL);
    return (res); }

LWord *SpecialCollect(len)
int len;
{   LWord *res;

    SpecialCollection=1;
/*  if(ProfRef) (ProfRef) -> at = (LWord) 0; */
    /* GC, please dont follow this */
    res = Collect(len);
    SpecialCollection=0;
    return (res);
}

LWord *ObjCollect(obj)       /* MK: This is now obsolete !! */
LWord *obj;
{   LWord *res; res = CommonCollect(0,obj);
    return res; }

InitCollect() { CurrentProcess=CurrentState->WaitingProcesses;
                RestoreProcessState(); SpecialCollect(0); SaveProcessState(); }

SaveProcessState()
{ register Stack *tempstack;
  tempstack = CurrentProcess -> ArgStk;
  (tempstack -> StkPos) = PtrDiff_(FAM_AP, tempstack);
  (CurrentProcess -> Frame) = FAM_FP;
  (CurrentProcess -> PC) = PtrDiff_(FAM_PC, (FAM_FP-> text));
  tempstack = CurrentProcess -> CtlStk;
  (tempstack -> StkPos) = PtrDiff_(FAM_CP, tempstack);
  (tempstack -> TrapPos) = PtrDiff_(FAM_TrapTop, tempstack);
}

RestoreProcessState()
{ register Stack *tempstack;
  tempstack = CurrentProcess -> ArgStk;
  FAM_AP = ByteAdd_(tempstack, (tempstack -> StkPos));
  FAM_FP = CurrentProcess -> Frame;
  FAM_PC = (Byte *)ByteAdd_((FAM_FP -> text), (CurrentProcess -> PC));
  tempstack = CurrentProcess -> CtlStk;
  FAM_CP = ByteAdd_(tempstack, (tempstack -> StkPos));
  FAM_TrapTop = ByteAdd_(tempstack, (tempstack -> TrapPos));
}

int CheckEq(arg1, arg2)
LWord *arg1, *arg2;
{ register int i;  int nptrs, len; LWord *start;
check:
  if ((LWord)arg1 == (LWord)arg2) return(1);
  if (Immed_(arg1) || Immed_(arg2) ||
      (arg1[-1] != arg2[-1])) return(0);

  switch (Tag_(arg1)) {
  case TagText:
  case TagStack:
  case TagState:
  case TagUpRec1:
  case TagUpRec2:
  case TagUpRecN:
  case TagProcess: return(0);

  case TagString:
  case TagReal:
     return(memcmp(stringchar_(arg1),stringchar_(arg2),stringlength_(arg1))
            == 0);

  case TagBigVar: {  /* RJG 07-Feb-89 */
     if (arg1[1] != arg2[1]) return(0); /* same tag */
     arg1 = (LWord *)arg1[2]; arg2 = (LWord *)arg2[2];
     goto check; }
    
  default: {
     ClassifyObject_(arg1, len, nptrs, start);
     if (nptrs == 0) return(1);
     for (i=nptrs-1; i>0; i--) {
       if (!CheckEq((LWord *)arg1[i], (LWord *)arg2[i])) return(0); }
     arg1 = (LWord *)arg1[0]; arg2 = (LWord *)arg2[0];
     goto check; }
  }
}

#ifdef NATIVE

/*
 *  preprocesser to the GC stage 
 *
 */ 


NativeToTagged()
{
  register LWord *indexer;  /* [AJG, collection preprocessor ] */
  register LWord *temptop;

/*
 *  ok, we go 'up' the CP stack, looking for NC continuations, tagging them.
 */

  temptop = (LWord *) (CurrentProcess -> CtlStk);
  temptop += SizeOfAMStack_((Stack *)temptop)-1;
  for(indexer=FAM_CP; indexer < temptop;){
    if(Ptr_(indexer[1])) 
      { /* continuation frame */
        if (Ptr_(indexer[0]))
          { /* a NC closure, so [0] is < 0x40000000, so change to  */
            indexer[0] = (LWord) 
              ((indexer[0] - ((LWord) *((LWord *)(indexer[1])))) + 0x80000000);
          } 
        indexer += 2; /* size of continuation stuff */
      } else { /* exception frame */
        indexer += 5; /* size of a exception frame */
      }

  }
}

TaggedToNative()
{
  register LWord *indexer;  /* [AJG, collection postprocessor ] */
  register LWord *temptop;

/*
 *  ok, we go 'up' the CP stack, looking for NC continuations, boxing them.
 */
  temptop = (LWord *) (CurrentProcess -> CtlStk);
  temptop += SizeOfAMStack_((Stack *)temptop)-1;
  for(indexer=FAM_CP; indexer < temptop;){
    if(Ptr_(indexer[1])) 
      { /* continuation frame */
        if (((SLWord) cint_(indexer[0]))<0)
          { /* a NC closure, so [0] is < 0x40000000, so change to  */
            indexer[0] = (LWord) 
              ((indexer[0]) - 0x80000000) + ((LWord)* ((LWord *)(indexer[1])));
          } 
        indexer += 2; /* size of continuation stuff */
      } else { /* exception frame */
        indexer += 5; /* size of a exception frame */
      }

  }
}

#endif 
