home *** CD-ROM | disk | FTP | other *** search
/ Amiga MA Magazine 1998 #6 / amigamamagazinepolishissue1998.iso / coders / collector / collectors.mod < prev    next >
Text File  |  1995-03-31  |  24KB  |  861 lines

  1. (* (* $VER: CollectorS 1.0 (10-Feb-94) Copyright © by Lars Düning *) *)
  2.  
  3. MODULE CollectorS;
  4.  
  5. (*---------------------------------------------------------------------------
  6. ** Allocation and garbage-collection of elemental objects.
  7. **
  8. ** Copyright © 1993-1994 by Lars Düning  -  All rights reserved.
  9. ** Permission granted for non-commercial use.
  10. **---------------------------------------------------------------------------
  11. ** The GC is a variant of Dijkstra's incremental update collector as
  12. ** described in:
  13. **   Paul R. Wilson: Uniprocessor Garbage Collection Techniques
  14. **   1992 International Workshop on Memory Management
  15. **   Springer-Verlag, Lecture Notes
  16. ** This implementation imposes a rather small memory overhead, but may need
  17. ** several runs for a full gc.
  18. **---------------------------------------------------------------------------
  19. ** Oberon-2: Amiga-Oberon v3.10, F. Siebert / A+L AG
  20. **---------------------------------------------------------------------------
  21. ** [lars] Lars Düning; Am Wendenwehr 25; D-38114-Braunschweig;
  22. **                     Germany; Tel. 49-531-345692
  23. **---------------------------------------------------------------------------
  24. ** 07-Feb-94 [lars] Derived from Collector, using a scheme with lower
  25. **                  memory overhead.
  26. ** 09-Feb-94 [lars] Option 'Statistics' dropped; enforced collection.
  27. ** 10-Feb-94 [lars] 'Rootness' is now part of the element type.
  28. **                  'gcReqT' added.
  29. ** 10-Feb-94 [lars] actual
  30. **---------------------------------------------------------------------------
  31. *)
  32.  
  33. (* $StackChk- $OvflChk- *)
  34.  
  35. IMPORT
  36.   (* $IF Debug *) Debug, (* $END *)
  37.   SYSTEM;
  38.  
  39. (*-------------------------------------------------------------------------*)
  40.  
  41. TYPE
  42.   ElementP  *= POINTER TO Element;
  43.   FreeDataP *= POINTER TO FreeData;
  44.   FreeElemP *= POINTER TO FreeElem;
  45.  
  46. TYPE
  47.  
  48.   (* Base structure of an collectable element
  49.   ** The color of an element is solely determined by the ring it is part of.
  50.   *)
  51.   Element *= RECORD
  52.     next     : ElementP;  (* next element; NIL for unchained elements *)
  53.     ecType  -: SHORTINT;  (* type of this element *)
  54.     ecFlags *: SHORTSET;  (* color and other flags *)
  55.   END;
  56.  
  57. CONST  (* Element.ecFlags *)
  58.   Black *= 0;  (* Color 'black', must be 1-White *)
  59.   White *= 1;  (* Color 'white', must be 1-Black *)
  60.   Grey  *= 2;  (* Color 'grey' *)
  61.   Root  *= 6;  (* set for members of the root set *)
  62.   Base  *= 7;  (* Baseelement of a ring *)
  63.  
  64. TYPE
  65.  
  66.   (* A freed element
  67.   ** The size of this record must be equal to that of Element!
  68.   *)
  69.  
  70.   FreeElem = RECORD
  71.     next : FreeElemP;  (* next element in free chain *)
  72.     age  : INTEGER;    (* # of GC pass freeing this element *)
  73.   END;
  74.  
  75.   (* A Freelist entry for one ecType
  76.   *)
  77.   FreeData *= STRUCT
  78.     list    -: FreeElemP;                (* List of free elements *)
  79.     new     -: PROCEDURE () : ElementP;  (* Allocator procedure *)
  80.     root    -: BOOLEAN;                  (* Flag is these elements are 'Root' *)
  81.     max     -: LONGINT;                  (* Max number of elements to hold *)
  82.     nrList  -: LONGINT;                  (* Current number of held elements *)
  83.     nrReq   -: LONGINT;  (* Total count of requests for a new Element *)
  84.     nrRecyc -: LONGINT;  (* Count of Element requests served from the free list *)
  85.     nrFreed -: LONGINT;  (* Total count of Element freed *)
  86.   END;
  87.  
  88.   FreeListP *= POINTER TO ARRAY OF FreeData;
  89.  
  90. VAR
  91.   black -: INTEGER; (* Actual colors *)
  92.   white -: INTEGER;
  93.  
  94.   nrTypes -: SHORTINT;  (* Number of registered ecTypes *)
  95.  
  96.   freelist -: FreeListP;  (* All Freelists *)
  97.  
  98.     (* Rings of the normal element set
  99.     ** During GC:
  100.     **   black : processed and referenced
  101.     **   dark  : not grey: processed, but unreferenced
  102.     **           grey    : processed and referenced
  103.     **   white : not grey: unprocessed and/or unreferenced
  104.     **           grey    : referenced, but not processed yet
  105.     **
  106.     ** After GC:
  107.     **   black : alive elements
  108.     **   dark  : possibly dead elements (the non-grey ones)
  109.     **   white : dead elements
  110.     **
  111.     ** During Sweeping:
  112.     **   black : empty
  113.     **   dark  : possible dead elements left to sweep
  114.     **   white : alive elements from previous run, and new elements
  115.     *)
  116.   nBlack   : ElementP;  (* ring of the black elements *)
  117.   nDark    : ElementP;  (* ring of the dark elements *)
  118.   nWhite   : ElementP;  (* ring of the white element *)
  119.   nrNormal : LONGINT;   (* Number of normal elements *)
  120.   nGotGrey : BOOLEAN;   (* TRUE if there are greyed white elements *)
  121.  
  122.     (* Pointers of the root element set
  123.     ** During GC:
  124.     **   black : processed and referenced
  125.     **   dark  : not grey: processed, but unreferenced
  126.     **           grey    : processed and referenced
  127.     **   white : not grey: unprocessed, mostly unreferenced
  128.     **           grey    : unprocessed yet, but referenced
  129.     **
  130.     ** After GC:
  131.     **   black : alive elements
  132.     **   dark  : possibly dead elements (the non-grey ones)
  133.     **   white : dead elements
  134.     **
  135.     ** During Sweeping:
  136.     **  black  : empty
  137.     **  dark   : possible dead elements left to sweep
  138.     **  white  : alive elements from previous run, and new elements.
  139.     *)
  140.   rBlack   : ElementP;  (* ring of black root elements *)
  141.   rDark    : ElementP;  (* ring of dark root elements *)
  142.   rWhite   : ElementP;  (* ring of white root elements *)
  143.   nrRoot   : LONGINT;   (* Number of root elements *)
  144.  
  145.     (* Used by the GC *)
  146.   sweeping -: BOOLEAN;  (* GC state: false: marking, true: sweeping *)
  147.   gcRuns  -: LONGINT;   (* Count of GC runs *)
  148.   gcCalls -: LONGINT;   (* Calls to GC() during this run *)
  149.  
  150.     (* And for my curiosity... *)
  151.   gcReqT   -: LONGINT;  (* Total number of elements requested *)
  152.   gcFreeT  -: LONGINT;  (* Total number of elements freed by GC so far *)
  153.   gcExaT   -: LONGINT;  (* Total number of elements examinated by GC so far *)
  154.   gcCallsT -: LONGINT;  (* Total count of calls to GC() *)
  155.  
  156.     (* ..and to build those numbers... *)
  157.   gcFree -: LONGINT;  (* Actual number of elements freed this GC-run *)
  158.   gcExa  -: LONGINT;  (* Actual number of elements examinated this GC-run *)
  159.  
  160. (*=========================================================================
  161. **
  162. **                             E L E M E N T
  163. **
  164. **=========================================================================*)
  165.  
  166. (*-------------------------------------------------------------------------*)
  167. PROCEDURE (this : ElementP) mark *;
  168.  
  169. (* Mark all elements which are referenced by this element as grey.
  170. **
  171. ** Argument:
  172. **   this: the referencing element.
  173. **
  174. ** The element itself is marked by the collector.
  175. *)
  176.  
  177. BEGIN
  178.   (* Nothing to do as default. *)
  179. END mark;
  180.  
  181. (*-------------------------------------------------------------------------*)
  182. CONST (* Returnvalues of this.free() *)
  183.   keep    *= 0;
  184.   enlist  *= 1;
  185.   dispose *= 2;
  186.  
  187. PROCEDURE (this : ElementP) free * () : INTEGER;
  188.  
  189. (* Let an unreferenced element clean up itself.
  190. **
  191. ** Argument:
  192. **   this: the now unreferenced element.
  193. **
  194. ** Result:
  195. **   keep   : the element is still alive, keep it.
  196. **   enlist : put the element into its freelist.
  197. **   dispose: deallocate the element.
  198. **
  199. ** The result determines the action done by the collector.
  200. *)
  201.  
  202. BEGIN
  203.   RETURN enlist;
  204. END free;
  205.  
  206. (*=========================================================================*)
  207.  
  208. (*-------------------------------------------------------------------------*)
  209. PROCEDURE ResizeFreelist (count : SHORTINT);
  210.  
  211. (* (Re)Allocate 'count' entries in 'freelist'.
  212. **
  213. ** Argument:
  214. **   count : the new size of the freelist.
  215. **
  216. ** Existing entries are copied; it is not possible to shrink the freelist.
  217. *)
  218.  
  219. VAR
  220.   oldCount : SHORTINT;
  221.   i        : SHORTINT;
  222.   newlist  : FreeListP;
  223. BEGIN
  224.   IF (freelist # NIL) & (count <= LEN(freelist^)) THEN RETURN; END;
  225.   IF freelist # NIL THEN
  226.     oldCount := nrTypes;
  227.   ELSE
  228.     oldCount := 0;
  229.   END;
  230.   NEW(newlist, count);
  231.   FOR i := 0 TO oldCount-1 DO
  232.     newlist[i] := freelist[i];
  233.   END;
  234.   FOR i := oldCount TO count-1 DO
  235.     newlist[i].list := NIL;
  236.     newlist[i].new  := NIL;
  237.     newlist[i].max  := 0;
  238.     newlist[i].root := FALSE;
  239.     newlist[i].nrList := 0;
  240.     newlist[i].nrReq   := 0;
  241.     newlist[i].nrRecyc := 0;
  242.     newlist[i].nrFreed := 0;
  243.   END;
  244.   (* $IFNOT GarbageCollector *)
  245.     IF freelist # NIL THEN
  246.       DISPOSE(freelist);
  247.     END;
  248.   (* $END *)
  249.   freelist := newlist;
  250. END ResizeFreelist;
  251.  
  252. (*-------------------------------------------------------------------------*)
  253. PROCEDURE RegisterType * ( new    : PROCEDURE() : ElementP
  254.                          ; isRoot : BOOLEAN
  255.                          ; max    : LONGINT
  256.                          ) : SHORTINT;
  257.  
  258. (* Register a new collectable type.
  259. **
  260. ** Arguments:
  261. **   new : the procedure to allocate a record of that type.
  262. **   isRoot : TRUE if these elements are member of the root set.
  263. **   max : the max number of records to hold in the freelist.
  264. **
  265. ** Result:
  266. **   The ecType number for the registered type.
  267. *)
  268.  
  269. BEGIN
  270.   ResizeFreelist(nrTypes+1);
  271.   freelist[nrTypes].new := new;
  272.   freelist[nrTypes].max := max;
  273.   freelist[nrTypes].root := isRoot;
  274.   INC(nrTypes);
  275.   RETURN nrTypes-1;
  276. END RegisterType;
  277.  
  278. (*-------------------------------------------------------------------------*)
  279. PROCEDURE New * (type : SHORTINT) : ElementP;
  280.  
  281. (* Return an element of the given type.
  282. **
  283. ** Arguments:
  284. **   type   : the type number for the requested element.
  285. **
  286. ** Result:
  287. **   A pointer to the new element.
  288. **
  289. ** The element is allocated either from the freelist, or using the 'new'
  290. ** procedure. It is entangled into the collector lists, either in
  291. ** the normalset, or if .root is TRUE, in the rootset.
  292. *)
  293.  
  294. VAR
  295.   freep : FreeDataP;
  296.   rc : ElementP;
  297. BEGIN
  298.   freep := SYSTEM.VAL(FreeDataP, SYSTEM.ADR(freelist[type]));
  299.   INC(freep.nrReq);
  300.   INC(gcReqT);
  301.   IF freep.list # NIL THEN
  302.     rc := SYSTEM.VAL(ElementP, freep.list);
  303.     freep.list := freep.list.next;
  304.     rc.next := NIL;
  305.     DEC(freep.nrList);
  306.     INC(freep.nrRecyc);
  307.   ELSE
  308.     rc := freep.new();
  309.   END;
  310.   IF rc # NIL THEN
  311.     rc.ecType := type;
  312.     (* === Entangle(rc, isRoot); === *)
  313.       rc.ecFlags := SHORTSET{white};
  314.       IF freep.root THEN
  315.         INCL(rc.ecFlags, Root);
  316.         rc.next     := rWhite.next;
  317.         rWhite.next := rc;
  318.         INC(nrRoot);
  319.       ELSE
  320.         rc.next     := nWhite.next;
  321.         nWhite.next := rc;
  322.         INC(nrNormal);
  323.       END;
  324.     (* ====== *)
  325.   END;
  326.   RETURN rc;
  327. END New;
  328.  
  329. (*-------------------------------------------------------------------------*)
  330. PROCEDURE Allocate * (type : SHORTINT) : ElementP;
  331.  
  332. (* Return an element of the given type.
  333. **
  334. ** Arguments:
  335. **   type   : the type number for the requested element.
  336. **
  337. ** Result:
  338. **   A pointer to the new element.
  339. **
  340. ** The element is allocated either from the freelist, or using the 'new'
  341. ** procedure. It is NOT entangled into the collector lists.
  342. ** Use it with care!
  343. *)
  344.  
  345. VAR
  346.   freep : FreeDataP;
  347.   rc : ElementP;
  348. BEGIN
  349.   freep := SYSTEM.VAL(FreeDataP, SYSTEM.ADR(freelist[type]));
  350.   INC(freep.nrReq);
  351.   IF freep.list # NIL THEN
  352.     rc := SYSTEM.VAL(ElementP, freep.list);
  353.     freep.list := freep.list.next;
  354.     rc.next := NIL;
  355.     DEC(freep.nrList);
  356.     INC(freep.nrRecyc);
  357.   ELSE
  358.     rc := freep.new();
  359.     IF rc # NIL THEN
  360.       rc.ecType := type;
  361.       rc.next := NIL;
  362.     END;
  363.   END;
  364.   rc.ecFlags := SHORTSET{};
  365.   RETURN rc;
  366. END Allocate;
  367.  
  368. (*-------------------------------------------------------------------------*)
  369. PROCEDURE Free * (elem : ElementP; prev : ElementP; dealloc : BOOLEAN);
  370.  
  371. (* Remove an element from the active ring.
  372. **
  373. ** Arguments:
  374. **   elem    : the element to remove.
  375. **   prev    : the element preceeding 'elem', or NIL.
  376. **   dealloc : flag if the element should be deallocated.
  377. **
  378. ** The element is removed from its ring (if any) and added to the freelist
  379. ** of its type, unless 'dealloc' is false, then it is deallocated.
  380. *)
  381.  
  382. VAR
  383.   freep : FreeDataP;
  384.   felp  : FreeElemP;
  385. BEGIN
  386.   IF elem.next # NIL THEN
  387.     IF Base IN elem.ecFlags THEN RETURN; END;
  388.     IF Root IN elem.ecFlags THEN DEC(nrRoot);
  389.                             ELSE DEC(nrNormal);
  390.     END;
  391.   (* === Detangle(elem) === *)
  392.     IF prev = NIL THEN
  393.       prev := elem.next;
  394.       WHILE prev.next # elem DO
  395.         prev := prev.next;
  396.       END;
  397.     END;
  398.     prev.next := elem.next;
  399.     elem.next := NIL;
  400.   (* ====== *)
  401.   END;
  402.   freep := SYSTEM.VAL(FreeDataP, SYSTEM.ADR(freelist[elem.ecType]));
  403.   INC(freep.nrFreed);
  404.   IF dealloc OR (freep.nrList >= freep.max) THEN
  405.     (* $IFNOT GarbageCollector *)
  406.       DISPOSE(elem);
  407.     (* $ELSE *)
  408.       elem := NIL;
  409.     (* $END *)
  410.   ELSE
  411.     felp := SYSTEM.VAL(FreeElemP, elem);
  412.     felp.next := freep.list;
  413.     freep.list := felp;
  414.     felp.age := SHORT(gcRuns);
  415.     INC(freep.nrList);
  416.   END;
  417. END Free;
  418.  
  419. (*-------------------------------------------------------------------------*)
  420. PROCEDURE ShortenLists * (age : INTEGER);
  421.  
  422. (* Remove old elements from the freelists.
  423. **
  424. ** Argument:
  425. **   age : the age in GC runs an element needs to stay in the lists.
  426. **
  427. ** Elements older than 'age' GC runs are deallocated; with an 'age' of 0
  428. ** causing the deallocation of all elements.
  429. *)
  430.  
  431. VAR
  432.   freep      : FreeDataP;
  433.   i          : SHORTINT;
  434.   count      : LONGINT;
  435.   this, prev : FreeElemP;
  436. BEGIN
  437.   age := SHORT(gcRuns-age);  (* get min gc-run# *)
  438.   FOR i := 0 TO nrTypes-1 DO
  439.     IF freelist[i].list # NIL THEN
  440.       freep := SYSTEM.VAL(FreeDataP, SYSTEM.ADR(freelist[i]));
  441.       prev := NIL;
  442.       this := freep.list;
  443.       WHILE this.age > age DO
  444.         prev := this;
  445.         this := this.next;
  446.       END;
  447.       IF this # NIL THEN
  448.         count := freep.nrList;
  449.         IF prev = NIL THEN freep.list := NIL;
  450.                       ELSE prev.next := NIL;
  451.         END;
  452.         REPEAT
  453.           prev := this; this := this.next;
  454.           (* $IFNOT GarbageCollector *)
  455.             DISPOSE(prev);
  456.           (* $ELSE *)
  457.             prev := NIL;
  458.           (* $END *)
  459.           DEC(count);
  460.         UNTIL this = NIL;
  461.         freep.nrList := count;
  462.       END;
  463.     END;
  464.   END;
  465. END ShortenLists;
  466.  
  467. (*-------------------------------------------------------------------------*)
  468. PROCEDURE Mark * (this : ElementP);
  469.  
  470. (* Color an element grey.
  471. **
  472. ** Argument:
  473. **   this : the element to shade grey.
  474. **
  475. ** The element 'elem' is colored grey (meaning "referenced but unprocessed")
  476. ** if it is not black.
  477. **
  478. ** This function is to be called by the .mark()-methods during GC, and
  479. ** by Check() (in fact it is inlined by Check()).
  480. **
  481. ** Inlining this procedure is advisable.
  482. *)
  483.  
  484. BEGIN
  485.   IF (this # NIL) & ~(black IN this.ecFlags) THEN
  486.     INCL(this.ecFlags, Grey);
  487.   END;
  488. END Mark;
  489.  
  490. (*-------------------------------------------------------------------------*)
  491. PROCEDURE Check * (this, elem : ElementP);
  492.  
  493. (* Check and possibly recolor an element after referencing.
  494. **
  495. ** Argument:
  496. **   this : the element 'elem' was assigned to.
  497. **   elem : the element referenced.
  498. **
  499. ** The element 'elem' is colored grey (meaning "referenced but unprocessed")
  500. ** if referenced by non-white elements.
  501. **
  502. ** This function is to be called if 'elem' was just referenced
  503. ** by 'this' element.
  504. **
  505. ** Inlining this procedure is advisable.
  506. *)
  507.  
  508. BEGIN
  509.   IF   (this # NIL)
  510.      & (this.ecFlags * SHORTSET{Root, black, Grey} # SHORTSET{})
  511.      & (elem # NIL)
  512.      & (elem.ecFlags * SHORTSET{black, Grey} # SHORTSET{})
  513.   THEN
  514.     INCL(elem.ecFlags, Grey);
  515.   END;
  516. END Check;
  517.  
  518. (*-------------------------------------------------------------------------*)
  519. PROCEDURE GC * (steps : LONGINT) : BOOLEAN;
  520.  
  521. (* Perform a garbage collection - one step of a full run.
  522. **
  523. ** Argument:
  524. **   steps : total number of steps (calls) the GC shall need.
  525. **           A value < 2 enforces a completing/full run.
  526. **
  527. ** Result:
  528. **   TRUE if the GC is complete.
  529. **
  530. ** Perform one step (or a completing/complete run) of the Mark-and-Sweep-GC
  531. ** for the elements.
  532. ** The procedure loops either over n elements or until the end of one run.
  533. ** 'n' is derived from the number of existing elements divided by the
  534. ** given number of 'steps' to do.
  535. ** If the GC is complete, a call to ShortenLists() should be done.
  536. **
  537. ** Note that a 'complete' GC does not necessarily mean that all unreferenced
  538. ** memory has been returned already IF referenced normal elements
  539. ** are blindly colored grey even when already black.
  540. ** This is especially true if the GC was just completing a previous GC
  541. **
  542. ** It is not guaranteed that an incremental GC really needs just 'steps'
  543. ** calls to complete.
  544. *)
  545.  
  546. VAR
  547.   todo     : LONGINT;
  548.   prev     : ElementP;
  549.   elem     : ElementP;
  550.   elem2    : ElementP;
  551.   rc       : INTEGER;
  552.   fullRun  : BOOLEAN;
  553. BEGIN
  554.   INC(gcCalls);
  555.  
  556.     (* In case of 'fullRun's, the exact number of elements to do
  557.     ** can't be predicted, so just loop until done.
  558.     *)
  559.  
  560.   IF (steps < 2) THEN
  561.     todo := 1;
  562.     fullRun := TRUE;
  563.   ELSE
  564.     todo := (nrRoot+3*nrNormal) DIV steps + 1;
  565.     fullRun := FALSE;
  566.   END;
  567.  
  568.   (*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  569.   ** Mark all referenced elements
  570.   *)
  571.  
  572.   IF ~sweeping THEN
  573.  
  574.     (* ------ Walk through the unprocessed white rootset elements ------ *)
  575.  
  576.     IF rWhite.next # rWhite THEN
  577.  
  578.       prev := rWhite;
  579.       elem := rWhite.next;
  580.  
  581.       WHILE (elem # rWhite) & (todo > 0) DO
  582.         INC (gcExa);
  583.         elem.mark;
  584.         IF Grey IN elem.ecFlags THEN
  585.           EXCL(elem.ecFlags, Grey);
  586.           EXCL(elem.ecFlags, white);
  587.           INCL(elem.ecFlags, black);
  588.           prev := elem;
  589.           elem := elem.next;
  590.         ELSE
  591.             (* Requeue as Dark *)
  592.           elem2 := elem.next;
  593.           prev.next := elem.next;
  594.           elem.next := rDark.next;
  595.           rDark.next := elem;
  596.           elem := elem2;
  597.         END;
  598.  
  599.         IF ~fullRun THEN DEC (todo); END;
  600.       END;
  601.  
  602.       (* ...now all elements of white might have gone into the dark ring.
  603.       ** If not, define those up to 'prev' as black.
  604.       *)
  605.  
  606.       IF (rWhite.next # rWhite) & (prev # rWhite) THEN
  607.         prev.next := rBlack.next;
  608.         rBlack.next := rWhite.next;
  609.         rWhite.next := elem;
  610.       END;
  611.  
  612.       (* No need to reloop through them - all depending elements have
  613.       ** been marked unconditionally anyway.
  614.       *)
  615.  
  616.       IF todo < 1 THEN RETURN FALSE; END;
  617.     END;
  618.  
  619.     (* ------ Loop over the white normal elements ------ *)
  620.  
  621.     REPEAT
  622.  
  623.       (* --- Walk through the unprocessed grey normal elements --- *)
  624.  
  625.       IF nWhite.next # nWhite THEN
  626.  
  627.         prev := nWhite;
  628.         elem := nWhite.next;
  629.  
  630.         WHILE (elem # nWhite) & (todo > 0) DO
  631.           INC (gcExa);
  632.           IF Grey IN elem.ecFlags THEN
  633.             elem.mark;
  634.             EXCL(elem.ecFlags, Grey);
  635.             EXCL(elem.ecFlags, white);
  636.             INCL(elem.ecFlags, black);
  637.             prev := elem;
  638.             elem := elem.next;
  639.             nGotGrey := TRUE;
  640.           ELSE
  641.               (* Requeue as Dark *)
  642.             elem2 := elem.next;
  643.             prev.next := elem.next;
  644.             elem.next := nDark.next;
  645.             nDark.next := elem;
  646.             elem := elem2;
  647.           END;
  648.           IF ~fullRun THEN DEC (todo); END;
  649.         END;
  650.  
  651.         (* ...now all elements of white might have gone into the dark ring.
  652.         ** If not, define those up to 'prev' as black.
  653.         ** If not, define them as black.
  654.         *)
  655.  
  656.         IF (nWhite.next # nWhite) & (prev # nWhite) THEN
  657.           prev.next := nBlack.next;
  658.           nBlack.next := nWhite.next;
  659.           nWhite.next := elem;
  660.         END;
  661.  
  662.         IF todo < 1 THEN RETURN FALSE; END;
  663.  
  664.       END;
  665.  
  666.       (* --- Requeue possibly 'grey' white elements --- *)
  667.  
  668.       IF (nWhite.next = nWhite) & nGotGrey THEN
  669.         elem   := nWhite;
  670.         nWhite := nDark;
  671.         nDark  := elem;
  672.  
  673.         nGotGrey := FALSE;
  674.       END;
  675.  
  676.     UNTIL nWhite.next = nWhite;
  677.  
  678.     (* ------ Mark done, now setup for sweeping. ------ *)
  679.  
  680.     sweeping := TRUE;
  681.     white := black;
  682.     black := 1-white;
  683.  
  684.     (* Requeue the alive elements into the 'white' ring.
  685.     ** The dead ones are already in the 'dark' ring.
  686.     *)
  687.  
  688.     elem   := nWhite;
  689.     nWhite := nBlack;
  690.     nBlack := elem;
  691.  
  692.     (* Requeue the alive rootset elements into the 'white' ring.
  693.     ** The possibly dead ones are alread in the 'dark' ring.
  694.     *)
  695.     elem   := rWhite;
  696.     rWhite := rBlack;
  697.     rBlack := elem;
  698.  
  699.   END; (* IF ~sweeping *)
  700.  
  701.   (*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  702.   ** Sweep the unreferenced objects.
  703.   *)
  704.  
  705.   (* ------ Try to free all unreferenced objects from normal set ------ *)
  706.  
  707.   IF nDark.next # nDark THEN
  708.  
  709.     prev := nDark;
  710.     elem := nDark.next;
  711.  
  712.     WHILE (elem # nDark) & (todo > 0) DO
  713.       (* Dark elements should not be marked 'grey' after their processing
  714.       ** but take care if it happens...
  715.       *)
  716.       IF Grey IN elem.ecFlags THEN
  717.         rc := keep;
  718.       ELSE
  719.         rc := elem.free();
  720.       END;
  721.  
  722.       IF rc = keep THEN
  723.         elem.ecFlags := SHORTSET{white};
  724.         prev := elem;
  725.         elem := elem.next;
  726.       ELSE
  727.         elem2 := elem.next;
  728.         Free(elem, prev, rc = dispose);
  729.         INC (gcFree);
  730.         elem := elem2;
  731.       END;
  732.  
  733.       IF ~fullRun THEN DEC (todo); END;
  734.     END;
  735.  
  736.     (* ...now all elements of dark might have been freed.
  737.     ** If not, requeue those up to 'prev' as white.
  738.     *)
  739.  
  740.     IF (nDark.next # nDark) & (prev # nDark) THEN
  741.       prev.next := nWhite.next;
  742.       nWhite.next := nDark.next;
  743.       nDark.next := elem;
  744.     END;
  745.  
  746.     IF todo < 1 THEN RETURN FALSE; END;
  747.  
  748.   END;
  749.  
  750.   (* ------ Try to free all unreferenced objects from root set ------ *)
  751.  
  752.   IF rDark.next # rDark THEN
  753.  
  754.     prev := rDark;
  755.     elem := rDark.next;
  756.  
  757.     WHILE (elem # rDark) & (todo > 0) DO
  758.       (* Dark elements may be marked 'grey' after their processing
  759.       ** so take care for them.
  760.       *)
  761.       IF Grey IN elem.ecFlags THEN
  762.         rc := keep;
  763.       ELSE
  764.         rc := elem.free();
  765.       END;
  766.  
  767.       IF rc = keep THEN
  768.         elem.ecFlags := SHORTSET{Root,white};
  769.         prev := elem;
  770.         elem := elem.next;
  771.       ELSE
  772.         elem2 := elem.next;
  773.         Free(elem, prev, rc = dispose);
  774.         INC (gcFree);
  775.         elem := elem2;
  776.       END;
  777.  
  778.       IF ~fullRun THEN DEC (todo); END;
  779.     END;
  780.  
  781.     (* ...now all elements of dark might have been freed.
  782.     ** If not, requeue those up to 'prev' as white.
  783.     *)
  784.  
  785.     IF (rDark.next # rDark) & (prev # rDark) THEN
  786.       prev.next := rWhite.next;
  787.       rWhite.next := rDark.next;
  788.       rDark.next := elem;
  789.     END;
  790.  
  791.     IF todo < 1 THEN RETURN FALSE; END;
  792.   END;
  793.  
  794.   (*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  795.   ** Prepare for a new run of the GC
  796.   *)
  797.  
  798.   INC(gcRuns);
  799.  
  800.   INC(gcCallsT, gcCalls); gcCalls := 0;
  801.   INC(gcFreeT, gcFree); gcFree := 0;
  802.   INC(gcExaT , gcExa ); gcExa := 0;
  803.  
  804.   sweeping := FALSE;
  805.   nGotGrey := FALSE;
  806.  
  807.  
  808.   (* If we arrive here, the GC is complete *)
  809.  
  810.   RETURN TRUE;
  811. END GC;
  812.  
  813. (*=========================================================================*)
  814.  
  815. BEGIN
  816.   black := Black; white := White;
  817.   nrTypes := 0;
  818.  
  819.   freelist := NIL;
  820.   ResizeFreelist(20);  (* Reserve an initial amount of entries *)
  821.  
  822.     (* Init rootset
  823.     *)
  824.   NEW(rWhite);
  825.   rWhite.next := rWhite;
  826.   rWhite.ecFlags := SHORTSET{Root, Base};
  827.   NEW(rDark);
  828.   rDark.next := rDark;
  829.   rDark.ecFlags := SHORTSET{Root, Base};
  830.   NEW(rBlack);
  831.   rBlack.next := rBlack;
  832.   rBlack.ecFlags := SHORTSET{Root, Base};
  833.  
  834.   nrRoot := 0;
  835.  
  836.     (* Init normalset
  837.     *)
  838.   NEW(nBlack);
  839.   nBlack.next := nBlack;
  840.   nBlack.ecFlags := SHORTSET{Base};
  841.   NEW(nDark);
  842.   nDark.next := nDark;
  843.   nDark.ecFlags := SHORTSET{Base};
  844.   NEW(nWhite);
  845.   nWhite.next := nWhite;
  846.   nWhite.ecFlags := SHORTSET{Base};
  847.  
  848.   nrNormal := 0;
  849.   nGotGrey := FALSE;
  850.  
  851.   sweeping := FALSE;
  852.  
  853.   gcRuns := 0;
  854.   gcReqT := 0;
  855.   gcCallsT := 0; gcCalls := 0;
  856.   gcFreeT  := 0; gcExaT  := 0;
  857.   gcFree   := 0; gcExa   := 0;
  858. END CollectorS.
  859.  
  860. (***************************************************************************)
  861.