(* (* $VER: Collector 1.0 (10-Feb-94) Copyright © by Lars Düning *) *)

MODULE Collector;

(*---------------------------------------------------------------------------
** Allocation and garbage-collection of elemental objects.
**
** Copyright © 1993-1994 by Lars Düning  -  All rights reserved.
** Permission granted for non-commercial use.
**---------------------------------------------------------------------------
** The GC is a variant of Dijkstra's incremental update collector as
** described in:
**   Paul R. Wilson: Uniprocessor Garbage Collection Techniques
**   1992 International Workshop on Memory Management
**   Springer-Verlag, Lecture Notes
**---------------------------------------------------------------------------
** Oberon-2: Amiga-Oberon v3.10, F. Siebert / A+L AG
**---------------------------------------------------------------------------
** [lars] Lars Düning; Am Wendenwehr 25; D-38114-Braunschweig;
**                     Germany; Tel. 49-531-345692
**---------------------------------------------------------------------------
** 01-Nov-93 [lars]
** 16-Nov-93 [lars] Option 'NoStatistics' added.
** 03-Feb-94 [lars] Split the two big rings into several small ones.
**                  Reduced the number of ring reconfigurations during GC.
** 07-Feb-94 [lars] gcRuns is needed even without 'Statistics'
** 09-Feb-94 [lars] Option 'Statistics' dropped; enforced collection.
** 10-Feb-94 [lars] 'Rootness' is now part of the element type.
**                  'gcReqT' added.
** 10-Feb-94 [lars] actual
**---------------------------------------------------------------------------
*)

(* $StackChk- $OvflChk- *)

IMPORT
  (* $IF Debug *) Debug, (* $END *)
  SYSTEM;

(*-------------------------------------------------------------------------*)

TYPE
  ElementP  *= POINTER TO Element;
  FreeDataP *= POINTER TO FreeData;

TYPE

  (* Base structure of an collectable element
  *)
  Element *= RECORD
    next     : ElementP;  (* next element; NIL for unchained elements *)
    prev     : ElementP;  (* previous element; or GC pass# of freelisting *)
    ecType  -: SHORTINT;  (* type of this element *)
    ecFlags -: SHORTSET;  (* color and other flags *)
  END;

CONST  (* Element.ecFlags *)
  Black *= 0;  (* Color 'black', must be 1-White *)
  White *= 1;  (* Color 'white', must be 1-Black *)
  Grey  *= 2;  (* Color 'grey' *)
  Dark  *= 5;  (* set for root elements which are already processed *)
  Root  *= 6;  (* set for members of the root set *)
  Base  *= 7;  (* Baseelement of a ring *)

TYPE

  (* A Freelist entry for one ecType
  *)
  FreeData *= STRUCT
    list    -: ElementP;                 (* List of free elements *)
    new     -: PROCEDURE () : ElementP;  (* Allocator procedure *)
    root    -: BOOLEAN;                  (* Flag if these elements are 'Root' *)
    max     -: LONGINT;                  (* Max number of elements to hold *)
    nrList  -: LONGINT;                  (* Current number of held elements *)
    nrReq   -: LONGINT;  (* Total count of requests for a new Element *)
    nrRecyc -: LONGINT;  (* Count of Element requests served from the free list *)
    nrFreed -: LONGINT;  (* Total count of Element freed *)
  END;

  FreeListP *= POINTER TO ARRAY OF FreeData;

VAR
  black -: INTEGER; (* Actual colors *)
  white -: INTEGER;

  nrTypes -: SHORTINT;  (* Number of registered ecTypes *)

  freelist -: FreeListP;  (* All Freelists *)

    (* Rings of the normal element set
    ** During GC:
    **   black  : processed and referenced
    **   grey   : referenced, but not processed yet
    **   white  : unprocessed and/or unreferenced
    **   garbage: empty
    **
    ** After GC:
    **   black  : alive elements
    **   grey   : empty
    **   white  : dead elements
    **   garbage: empty
    **
    ** During Sweeping:
    **   black  : empty
    **   grey   : empty
    **   white  : alive elements from previous run, and new elements
    **   garbage: elements left to deallocate
    *)
  nBlack   : ElementP;  (* ring of the black elements *)
  nGrey    : ElementP;  (* ring of the grey elements *)
  nWhite   : ElementP;  (* ring of the white element *)
  nGarbage : ElementP;  (* list of the garbage elements *)
  nrNormal : LONGINT;   (* Number of normal elements *)

    (* Pointers of the root element set
    ** During GC:
    **   black : processed and referenced
    **   grey  : unprocessed yet, but referenced
    **   dark  : processed, but unreferenced
    **   white : unprocessed, mostly unreferenced
    **
    ** After GC:
    **   black : alive elements
    **   grey  : empty
    **   dark  : possibly dead elements (the white ones)
    **   white : dead elements
    **
    ** During Sweeping:
    **  black  : empty
    **  grey   : empty
    **  dark   : possible dead elements left to sweep
    **  white  : alive elements from previous run, and new elements.
    *)
  rBlack : ElementP;  (* ring of black root elements *)
  rGrey  : ElementP;  (* ring of grey root elements *)
  rDark  : ElementP;  (* ring of dark root elements *)
  rWhite : ElementP;  (* ring of white root elements *)
  nrRoot : LONGINT;   (* Number of root elements *)

    (* Used by the GC *)
  sweeping -: BOOLEAN;  (* GC state: false: marking, true: sweeping *)
  gcRuns   -: LONGINT;  (* Count of GC runs *)
  gcCalls  -: LONGINT;  (* Calls to GC() during this run *)

    (* And for my curiosity... *)
  gcReqT   -: LONGINT;  (* Total number of elements requested *)
  gcFreeT  -: LONGINT;  (* Total number of elements freed by GC so far *)
  gcExaT   -: LONGINT;  (* Total number of elements examinated by GC so far *)
  gcCallsT -: LONGINT;  (* Total count of calls to GC() *)

    (* ..and to build those numbers... *)
  gcFree -: LONGINT;  (* Actual number of elements freed this GC-run *)
  gcExa  -: LONGINT;  (* Actual number of elements examinated this GC-run *)

(*=========================================================================
**
**                             E L E M E N T
**
**=========================================================================*)

(*-------------------------------------------------------------------------*)
PROCEDURE (this : ElementP) mark *;

(* Mark all elements which are referenced by this element as grey.
**
** Argument:
**   this: the referencing element.
**
** The element itself is marked by the collector.
*)

BEGIN
  (* Nothing to do as default. *)
END mark;

(*-------------------------------------------------------------------------*)
CONST (* Returnvalues of this.free() *)
  keep    *= 0;
  enlist  *= 1;
  dispose *= 2;

PROCEDURE (this : ElementP) free * () : INTEGER;

(* Let an unreferenced element clean up itself.
**
** Argument:
**   this: the now unreferenced element.
**
** Result:
**   keep   : the element is still alive, keep it.
**   enlist : put the element into its freelist.
**   dispose: deallocate the element.
**
** The result determines the action done by the collector.
*)

BEGIN
  RETURN enlist;
END free;

(*=========================================================================*)

(*-------------------------------------------------------------------------*)
PROCEDURE ResizeFreelist (count : SHORTINT);

(* (Re)Allocate 'count' entries in 'freelist'.
**
** Argument:
**   count : the new size of the freelist.
**
** Existing entries are copied; it is not possible to shrink the freelist.
*)

VAR
  oldCount : SHORTINT;
  i        : SHORTINT;
  newlist  : FreeListP;
BEGIN
  IF (freelist # NIL) & (count <= LEN(freelist^)) THEN RETURN; END;
  IF freelist # NIL THEN
    oldCount := nrTypes;
  ELSE
    oldCount := 0;
  END;
  NEW(newlist, count);
  FOR i := 0 TO oldCount-1 DO
    newlist[i] := freelist[i];
  END;
  FOR i := oldCount TO count-1 DO
    newlist[i].list := NIL;
    newlist[i].new  := NIL;
    newlist[i].root := FALSE;
    newlist[i].max  := 0;
    newlist[i].nrList := 0;
    newlist[i].nrReq   := 0;
    newlist[i].nrRecyc := 0;
    newlist[i].nrFreed := 0;
  END;
  (* $IFNOT GarbageCollector *)
    IF freelist # NIL THEN
      DISPOSE(freelist);
    END;
  (* $END *)
  freelist := newlist;
END ResizeFreelist;

(*-------------------------------------------------------------------------*)
PROCEDURE RegisterType * ( new    : PROCEDURE() : ElementP
                         ; isRoot : BOOLEAN
                         ; max    : LONGINT
                         ) : SHORTINT;

(* Register a new collectable type.
**
** Arguments:
**   new    : the procedure to allocate a record of that type.
**   isRoot : TRUE if these elements are to be members of the root set.
**   max    : the max number of records to hold in the freelist.
**
** Result:
**   The ecType number for the registered type.
*)

BEGIN
  ResizeFreelist(nrTypes+1);
  freelist[nrTypes].new := new;
  freelist[nrTypes].max := max;
  freelist[nrTypes].root := isRoot;
  INC(nrTypes);
  RETURN nrTypes-1;
END RegisterType;

(*-------------------------------------------------------------------------*)
PROCEDURE New * (type : SHORTINT) : ElementP;

(* Return an element of the given type.
**
** Arguments:
**   type   : the type number for the requested element.
**
** Result:
**   A pointer to the new element.
**
** The element is allocated either from the freelist, or using the 'new'
** procedure. It is entangled into the collector lists, either in
** the normalset, or if .root is TRUE, in the rootset.
*)

VAR
  freep : FreeDataP;
  rc : ElementP;
BEGIN
  freep := SYSTEM.VAL(FreeDataP, SYSTEM.ADR(freelist[type]));
  INC(freep.nrReq);
  INC(gcReqT);
  IF freep.list # NIL THEN
    rc := SYSTEM.VAL(ElementP, freep.list);
    freep.list := freep.list.next;
    rc.next := NIL;
    DEC(freep.nrList);
    INC(freep.nrRecyc);
  ELSE
    rc := freep.new();
    IF rc # NIL THEN
      rc.ecType := type;
    END;
  END;
  IF rc # NIL THEN
    (* === Entangle(rc, isRoot); === *)
      rc.ecFlags := SHORTSET{white};
      IF freep.root THEN
        INCL(rc.ecFlags, Root);
        rc.prev := rWhite.prev;
        rc.next := rWhite;
        INC(nrRoot);
      ELSE
        rc.prev := nWhite.prev;
        rc.next := nWhite;
        INC(nrNormal);
      END;
      rc.prev.next := rc;
      rc.next.prev := rc;
    (* ====== *)
  END;
  RETURN rc;
END New;

(*-------------------------------------------------------------------------*)
PROCEDURE Allocate * (type : SHORTINT) : ElementP;

(* Return an element of the given type.
**
** Arguments:
**   type   : the type number for the requested element.
**
** Result:
**   A pointer to the new element.
**
** The element is allocated either from the freelist, or using the 'new'
** procedure. It is NOT entangled into the collector lists.
** Use it with care!
*)

VAR
  freep : FreeDataP;
  rc : ElementP;
BEGIN
  freep := SYSTEM.VAL(FreeDataP, SYSTEM.ADR(freelist[type]));
  INC(freep.nrReq);
  IF freep.list # NIL THEN
    rc := SYSTEM.VAL(ElementP, freep.list);
    freep.list := freep.list.next;
    rc.next := NIL;
    DEC(freep.nrList);
    INC(freep.nrRecyc);
  ELSE
    rc := freep.new();
    IF rc # NIL THEN
      rc.ecType := type;
      rc.next := NIL;
    END;
  END;
  RETURN rc;
END Allocate;

(*-------------------------------------------------------------------------*)
PROCEDURE Free * (elem : ElementP; dealloc : BOOLEAN);

(* Remove an element from the active ring.
**
** Arguments:
**   elem    : the element to remove.
**   dealloc : flag if the element should be deallocated.
**
** The element is removed from its ring (if any) and added to the freelist
** of its type, unless 'dealloc' is false, then it is deallocated.
*)

VAR
  freep : FreeDataP;
BEGIN
  IF elem.next # NIL THEN
    IF Base IN elem.ecFlags THEN RETURN; END;
    IF Root IN elem.ecFlags THEN DEC(nrRoot);
                            ELSE DEC(nrNormal);
    END;
  (* === Detangle(elem) === *)
    elem.next.prev := elem.prev;
    elem.prev.next := elem.next;
    elem.next := NIL;
  (* ====== *)
  END;
  freep := SYSTEM.VAL(FreeDataP, SYSTEM.ADR(freelist[elem.ecType]));
  INC(freep.nrFreed);
  IF dealloc OR (freep.nrList >= freep.max) THEN
    (* $IFNOT GarbageCollector *)
      DISPOSE(elem);
    (* $ELSE *)
      elem := NIL;
    (* $END *)
  ELSE
    elem.next := freep.list;
    freep.list := elem;
    elem.prev := SYSTEM.VAL(ElementP, gcRuns);
    INC(freep.nrList);
  END;
END Free;

(*-------------------------------------------------------------------------*)
PROCEDURE ShortenLists * (age : LONGINT);

(* Remove old elements from the freelists.
**
** Argument:
**   age : the age in GC runs an element needs to stay in the lists.
**
** Elements older than 'age' GC runs are deallocated; with an 'age' of 0
** causing the deallocation of all elements.
*)

VAR
  freep      : FreeDataP;
  i          : SHORTINT;
  count      : LONGINT;
  this, prev : ElementP;
BEGIN
  age := gcRuns-age;  (* get min gc-run# *)
  FOR i := 0 TO nrTypes-1 DO
    IF freelist[i].list # NIL THEN
      freep := SYSTEM.VAL(FreeDataP, SYSTEM.ADR(freelist[i]));
      prev := NIL;
      this := freep.list;
      WHILE SYSTEM.VAL(LONGINT, this.prev) > age DO
        prev := this;
        this := this.next;
      END;
      IF this # NIL THEN
        count := freep.nrList;
        IF prev = NIL THEN freep.list := NIL;
                      ELSE prev.next := NIL;
        END;
        REPEAT
          prev := this; this := this.next;
          (* $IFNOT GarbageCollector *)
            DISPOSE(prev);
          (* $ELSE *)
            prev := NIL;
          (* $END *)
          DEC(count);
        UNTIL this = NIL;
        freep.nrList := count;
      END;
    END;
  END;
END ShortenLists;

(*-------------------------------------------------------------------------*)
PROCEDURE Mark * (this : ElementP);

(* Mark an element as grey.
**
** Argument:
**   this : the element to shade grey.
**
** The element is colored grey (meaning "referenced but unprocessed")
** and enqueued into the 'grey' ring of its set.
** Non-'white' elements are not recolored or requeued.
** Processed 'dark' white rootset elements are just recolored.
**
** This function is to be called by the .mark()-methods during GC,
** and by Check() (in fact, it is inlined by Check()).
*)

BEGIN
  IF     (this = NIL)
      OR (Base IN this.ecFlags)
      OR (SHORTSET{black, Grey} * this.ecFlags # SHORTSET{})
  THEN
    RETURN
  END;
  EXCL(this.ecFlags, white);
  INCL(this.ecFlags, Grey);
  IF SHORTSET{Root, Dark} * this.ecFlags # SHORTSET{Root, Dark} THEN
    (* === Detangle(this) === *)
      IF this.next # NIL THEN
        this.next.prev := this.prev;
        this.prev.next := this.next;
        this.next := NIL;
      END;
    (* ====== *)
    IF Root IN this.ecFlags THEN
      this.next := rGrey;
      this.prev := rGrey.prev;
    ELSE
      this.next := nGrey;
      this.prev := nGrey.prev;
    END;
    this.next.prev := this;
    this.prev.next := this;
  END;
END Mark;

(*-------------------------------------------------------------------------*)
PROCEDURE Check * (this, elem : ElementP);

(* Check and possibly recolor an element after referencing.
**
** Argument:
**   this : the element referencing 'elem'.
**   elem : the element to check.
**
** The element is colored grey (meaning "referenced but unprocessed")
** and enqueued into the 'grey' ring of its set if it is referenced
** by a non-white element 'this'.
** Non-'white' elements are not recolored or requeued.
** Processed 'dark' white rootset elements are just recolored.
**
** This function is to be called if 'elem' was just referenced
** by 'this' element.
*)

BEGIN
  IF     (this = NIL)
      OR (Base IN this.ecFlags)
      OR (SHORTSET{Root, black, Grey} * this.ecFlags = SHORTSET{})
      OR (elem = NIL)
      OR (Base IN elem.ecFlags)
      OR (SHORTSET{black, Grey} * elem.ecFlags # SHORTSET{})
  THEN
    RETURN
  END;
  (* === Mark(elem) === *)
    EXCL(elem.ecFlags, white);
    INCL(elem.ecFlags, Grey);
    IF SHORTSET{Root, Dark} * elem.ecFlags # SHORTSET{Root, Dark} THEN
      (* === Detangle(elem) === *)
        IF elem.next # NIL THEN
          elem.next.prev := elem.prev;
          elem.prev.next := elem.next;
          elem.next := NIL;
        END;
      (* ====== *)
      IF Root IN elem.ecFlags THEN
        elem.next := rGrey;
        elem.prev := rGrey.prev;
      ELSE
        elem.next := nGrey;
        elem.prev := nGrey.prev;
      END;
      elem.next.prev := elem;
      elem.prev.next := elem;
    END;
  (* ====== *)
END Check;

(*-------------------------------------------------------------------------*)
PROCEDURE GC * (steps : LONGINT) : BOOLEAN;

(* Perform a garbage collection - one step of a full run.
**
** Argument:
**   steps : total number of steps (calls) the GC shall need.
**           A value < 2 enforces a completing/full run.
**
** Result:
**   TRUE if the GC is complete.
**
** Perform one step (or a completing/complete run) of the Mark-and-Sweep-GC
** for the elements.
** The procedure loops either over n elements or until the end of one run.
** 'n' is derived from the number of existing elements divided by the
** given number of 'steps' to do.
** If the GC is complete, a call to ShortenLists() should be done.
**
** Note that a 'complete' GC does not necessarily mean that all unreferenced
** memory has been returned already IF it was just completing a previous GC.
**
** It is not guaranteed that a GC really needs just 'steps' calls to complete.
*)

VAR
  todo    : LONGINT;
  elem    : ElementP;
  elem2   : ElementP;
  rc      : INTEGER;
  fullRun : BOOLEAN;
BEGIN
  INC(gcCalls);

    (* In case of 'fullRun's, the exact number of elements to do
    ** can't be predicted, so just loop until done.
    *)

  IF (steps < 2) THEN
    todo := 1;
    fullRun := TRUE;
  ELSE
    todo := (nrRoot+nrNormal) DIV steps + 1;
    fullRun := FALSE;
  END;

  (*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  ** Mark all referenced elements
  *)

  IF ~sweeping THEN

    (* ------ Walk through the unprocessed grey rootset elements ------ *)

    IF rGrey.next # rGrey THEN

      elem := rGrey.next;

      WHILE (elem # rGrey) & (todo > 0) DO
        INC(gcExa);
        elem.mark;
        EXCL(elem.ecFlags, Grey);
        INCL(elem.ecFlags, black);
        elem := elem.next;
        IF ~fullRun THEN DEC (todo); END;
      END;

      elem.prev.next   := rBlack;
      rBlack.prev.next := rGrey.next;
      rGrey.next.prev  := rBlack.prev;
      rBlack.prev      := elem.prev;

      rGrey.next := elem;
      elem.prev := rGrey;

      IF todo < 1 THEN RETURN FALSE; END;
    END;

    (* ------ Walk through the unprocessed white rootset elements ------ *)

    IF rWhite.next # rWhite THEN

      elem := rWhite.next;

      WHILE (elem # rWhite) & (todo > 0) DO
        INC (gcExa);
        elem.mark;
        IF Grey IN elem.ecFlags THEN
          EXCL(elem.ecFlags, Grey);
          INCL(elem.ecFlags, black);
          elem := elem.next;
        ELSE
            (* Mark and requeue as Dark *)
          elem2 := elem.next;
          INCL(elem.ecFlags, Dark);
          elem.next.prev := elem.prev;
          elem.prev.next := elem.next;
          rDark.prev.next := elem;
          elem.prev := rDark.prev;
          elem.next := rDark;
          rDark.prev := elem;
          elem := elem2;
        END;

        IF ~fullRun THEN DEC (todo); END;
      END;

      (* ...now all elements of white might have gone into the dark ring.
      ** If not, put those up to 'elem' into the black ring.
      *)

      IF (rWhite.next # rWhite) & (elem.prev # rWhite) THEN
        elem.prev.next   := rBlack;
        rBlack.prev.next := rWhite.next;
        rWhite.next.prev := rBlack.prev;
        rBlack.prev      := elem.prev;

        rWhite.next := elem;
        elem.prev := rWhite;
      END;

      IF todo < 1 THEN RETURN FALSE; END;
    END;

    (* ------ Walk through the unprocessed grey normal elements ------ *)

    IF nGrey.next # nGrey THEN

      elem := nGrey.next;

      WHILE (elem # nGrey) & (todo > 0) DO
        INC (gcExa);
        elem.mark;
        EXCL(elem.ecFlags, Grey);
        INCL(elem.ecFlags, black);
        elem := elem.next;
        IF ~fullRun THEN DEC (todo); END;
      END;

      elem.prev.next   := nBlack;
      nBlack.prev.next := nGrey.next;
      nGrey.next.prev  := nBlack.prev;
      nBlack.prev      := elem.prev;

      nGrey.next := elem;
      elem.prev := nGrey;

      IF todo < 1 THEN RETURN FALSE; END;
    END;

    (* ------ Mark done, now setup for sweeping. ------ *)

    sweeping := TRUE;
    white := black;
    black := 1-white;

    (* Remove the dead elements from the normalset.
    ** Requeue the alive elements into the 'white' ring.
    *)
    IF nWhite.next # nWhite THEN
      nGarbage := nWhite.next;
      nWhite.prev.next := NIL;  (* mark the end of the list *)
    ELSE
      nGarbage := NIL;
    END;
    nWhite.next := nWhite;
    nWhite.prev := nWhite;

    elem   := nWhite;
    nWhite := nBlack;
    nBlack := elem;

    (* Requeue the alive rootset elements into the 'white' ring.
    ** The possibly dead ones are alread in the 'dark' ring.
    *)
    elem   := rWhite;
    rWhite := rBlack;
    rBlack := elem;

  END; (* IF ~sweeping *)

  (*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  ** Sweep the unreferenced objects.
  *)

  (* ------ Try to free all unreferenced objects from normal set ------ *)

  WHILE nGarbage # NIL DO
    elem := nGarbage;
    nGarbage := nGarbage.next;
    elem.next := NIL; (* !! *)
    rc := elem.free();
    IF rc = keep THEN
      elem.ecFlags := SHORTSET{white};
      elem.prev := nWhite.prev;
      elem.next := nWhite;
      elem.prev.next := elem;
      elem.next.prev := elem;
    ELSE
      IF Root IN elem.ecFlags THEN DEC(nrRoot);
                              ELSE DEC(nrNormal);
      END;
      Free(elem, rc = dispose);
      INC (gcFree);
    END;

    IF ~fullRun THEN
      DEC (todo);
      IF todo < 1 THEN RETURN FALSE; END;
    END;
  END;

  (* ------ Try to free all unreferenced objects from root set ------ *)

  IF rDark.next # rDark THEN

    elem := rDark.next;

    WHILE (elem # rDark) & (todo > 0) DO
      (* Dark elements may be marked 'grey' after their processing
      ** so take care for them.
      *)
      IF Grey IN elem.ecFlags THEN
        rc := keep;
      ELSE
        rc := elem.free();
      END;

      IF rc = keep THEN
        elem.ecFlags := SHORTSET{Root, white};
        elem := elem.next;
      ELSE
        elem2 := elem.next;
        Free(elem, rc = dispose);
        INC (gcFree);
        elem := elem2;
      END;

      IF ~fullRun THEN DEC (todo); END;
    END;

    (* ...now all elements of dark might have been freed.
    ** If not, put those up to 'elem' back into the white ring.
    *)

    IF (rDark.next # rDark) & (elem.prev # rDark) THEN
      elem.prev.next   := rWhite;
      rWhite.prev.next := rDark.next;
      rDark.next.prev  := rWhite.prev;
      rWhite.prev      := elem.prev;

      rDark.next := elem;
      elem.prev := rDark;
    END;

    IF todo < 1 THEN RETURN FALSE; END;
  END;

  (*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  ** Prepare for a new run of the GC
  *)

  INC(gcRuns);
  INC(gcCallsT, gcCalls); gcCalls := 0;
  INC(gcFreeT, gcFree); gcFree := 0;
  INC(gcExaT , gcExa ); gcExa := 0;

  sweeping := FALSE;


  (* If we come here, we are done in any case *)

  RETURN TRUE;
END GC;

(*=========================================================================*)

BEGIN
  nrTypes := 0;
  black := Black; white := White;

  freelist := NIL;
  ResizeFreelist(20);  (* Reserve an initial amount of entries *)

    (* Init rootset
    *)
  NEW(rWhite);
  rWhite.next := rWhite; rWhite.prev := rWhite;
  rWhite.ecFlags := SHORTSET{Root, Base};
  NEW(rDark);
  rDark.next := rDark; rDark.prev := rDark;
  rDark.ecFlags := SHORTSET{Root, Base};
  NEW(rGrey);
  rGrey.next := rGrey; rGrey.prev := rGrey;
  rGrey.ecFlags := SHORTSET{Root, Base};
  NEW(rBlack);
  rBlack.next := rBlack; rBlack.prev := rBlack;
  rBlack.ecFlags := SHORTSET{Root, Base};

  nrRoot := 0;

    (* Init normalset
    *)
  NEW(nBlack);
  nBlack.next := nBlack; nBlack.prev := nBlack;
  nBlack.ecFlags := SHORTSET{Base};
  NEW(nGrey);
  nGrey.next := nGrey; nGrey.prev := nGrey;
  nGrey.ecFlags := SHORTSET{Base};
  NEW(nWhite);
  nWhite.next := nWhite; nWhite.prev := nWhite;
  nWhite.ecFlags := SHORTSET{Base};

  nrNormal := 0;

  sweeping := FALSE;

  gcRuns := 0;
  gcReqT := 0;
  gcCallsT := 0; gcCalls := 0;
  gcFreeT  := 0; gcExaT  := 0;
  gcFree   := 0; gcExa   := 0;
END Collector.

(***************************************************************************)