home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Amiga MA Magazine 1998 #6
/
amigamamagazinepolishissue1998.iso
/
coders
/
collector
/
collectors.mod
< prev
next >
Wrap
Text File
|
1995-03-31
|
24KB
|
861 lines
(* (* $VER: CollectorS 1.0 (10-Feb-94) Copyright © by Lars Düning *) *)
MODULE CollectorS;
(*---------------------------------------------------------------------------
** 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
** This implementation imposes a rather small memory overhead, but may need
** several runs for a full gc.
**---------------------------------------------------------------------------
** 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
**---------------------------------------------------------------------------
** 07-Feb-94 [lars] Derived from Collector, using a scheme with lower
** memory overhead.
** 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;
FreeElemP *= POINTER TO FreeElem;
TYPE
(* Base structure of an collectable element
** The color of an element is solely determined by the ring it is part of.
*)
Element *= RECORD
next : ElementP; (* next element; NIL for unchained elements *)
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' *)
Root *= 6; (* set for members of the root set *)
Base *= 7; (* Baseelement of a ring *)
TYPE
(* A freed element
** The size of this record must be equal to that of Element!
*)
FreeElem = RECORD
next : FreeElemP; (* next element in free chain *)
age : INTEGER; (* # of GC pass freeing this element *)
END;
(* A Freelist entry for one ecType
*)
FreeData *= STRUCT
list -: FreeElemP; (* List of free elements *)
new -: PROCEDURE () : ElementP; (* Allocator procedure *)
root -: BOOLEAN; (* Flag is 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
** dark : not grey: processed, but unreferenced
** grey : processed and referenced
** white : not grey: unprocessed and/or unreferenced
** grey : referenced, but not processed yet
**
** After GC:
** black : alive elements
** dark : possibly dead elements (the non-grey ones)
** white : dead elements
**
** During Sweeping:
** black : empty
** dark : possible dead elements left to sweep
** white : alive elements from previous run, and new elements
*)
nBlack : ElementP; (* ring of the black elements *)
nDark : ElementP; (* ring of the dark elements *)
nWhite : ElementP; (* ring of the white element *)
nrNormal : LONGINT; (* Number of normal elements *)
nGotGrey : BOOLEAN; (* TRUE if there are greyed white elements *)
(* Pointers of the root element set
** During GC:
** black : processed and referenced
** dark : not grey: processed, but unreferenced
** grey : processed and referenced
** white : not grey: unprocessed, mostly unreferenced
** grey : unprocessed yet, but referenced
**
** After GC:
** black : alive elements
** dark : possibly dead elements (the non-grey ones)
** white : dead elements
**
** During Sweeping:
** black : empty
** dark : possible dead elements left to sweep
** white : alive elements from previous run, and new elements.
*)
rBlack : ElementP; (* ring of black 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].max := 0;
newlist[i].root := FALSE;
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 member 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();
END;
IF rc # NIL THEN
rc.ecType := type;
(* === Entangle(rc, isRoot); === *)
rc.ecFlags := SHORTSET{white};
IF freep.root THEN
INCL(rc.ecFlags, Root);
rc.next := rWhite.next;
rWhite.next := rc;
INC(nrRoot);
ELSE
rc.next := nWhite.next;
nWhite.next := rc;
INC(nrNormal);
END;
(* ====== *)
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;
rc.ecFlags := SHORTSET{};
RETURN rc;
END Allocate;
(*-------------------------------------------------------------------------*)
PROCEDURE Free * (elem : ElementP; prev : ElementP; dealloc : BOOLEAN);
(* Remove an element from the active ring.
**
** Arguments:
** elem : the element to remove.
** prev : the element preceeding 'elem', or NIL.
** 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;
felp : FreeElemP;
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) === *)
IF prev = NIL THEN
prev := elem.next;
WHILE prev.next # elem DO
prev := prev.next;
END;
END;
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
felp := SYSTEM.VAL(FreeElemP, elem);
felp.next := freep.list;
freep.list := felp;
felp.age := SHORT(gcRuns);
INC(freep.nrList);
END;
END Free;
(*-------------------------------------------------------------------------*)
PROCEDURE ShortenLists * (age : INTEGER);
(* 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 : FreeElemP;
BEGIN
age := SHORT(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 this.age > 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);
(* Color an element grey.
**
** Argument:
** this : the element to shade grey.
**
** The element 'elem' is colored grey (meaning "referenced but unprocessed")
** if it is not black.
**
** This function is to be called by the .mark()-methods during GC, and
** by Check() (in fact it is inlined by Check()).
**
** Inlining this procedure is advisable.
*)
BEGIN
IF (this # NIL) & ~(black IN this.ecFlags) THEN
INCL(this.ecFlags, Grey);
END;
END Mark;
(*-------------------------------------------------------------------------*)
PROCEDURE Check * (this, elem : ElementP);
(* Check and possibly recolor an element after referencing.
**
** Argument:
** this : the element 'elem' was assigned to.
** elem : the element referenced.
**
** The element 'elem' is colored grey (meaning "referenced but unprocessed")
** if referenced by non-white elements.
**
** This function is to be called if 'elem' was just referenced
** by 'this' element.
**
** Inlining this procedure is advisable.
*)
BEGIN
IF (this # NIL)
& (this.ecFlags * SHORTSET{Root, black, Grey} # SHORTSET{})
& (elem # NIL)
& (elem.ecFlags * SHORTSET{black, Grey} # SHORTSET{})
THEN
INCL(elem.ecFlags, Grey);
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 referenced normal elements
** are blindly colored grey even when already black.
** This is especially true if the GC was just completing a previous GC
**
** It is not guaranteed that an incremental GC really needs just 'steps'
** calls to complete.
*)
VAR
todo : LONGINT;
prev : ElementP;
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+3*nrNormal) DIV steps + 1;
fullRun := FALSE;
END;
(*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
** Mark all referenced elements
*)
IF ~sweeping THEN
(* ------ Walk through the unprocessed white rootset elements ------ *)
IF rWhite.next # rWhite THEN
prev := rWhite;
elem := rWhite.next;
WHILE (elem # rWhite) & (todo > 0) DO
INC (gcExa);
elem.mark;
IF Grey IN elem.ecFlags THEN
EXCL(elem.ecFlags, Grey);
EXCL(elem.ecFlags, white);
INCL(elem.ecFlags, black);
prev := elem;
elem := elem.next;
ELSE
(* Requeue as Dark *)
elem2 := elem.next;
prev.next := elem.next;
elem.next := rDark.next;
rDark.next := 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, define those up to 'prev' as black.
*)
IF (rWhite.next # rWhite) & (prev # rWhite) THEN
prev.next := rBlack.next;
rBlack.next := rWhite.next;
rWhite.next := elem;
END;
(* No need to reloop through them - all depending elements have
** been marked unconditionally anyway.
*)
IF todo < 1 THEN RETURN FALSE; END;
END;
(* ------ Loop over the white normal elements ------ *)
REPEAT
(* --- Walk through the unprocessed grey normal elements --- *)
IF nWhite.next # nWhite THEN
prev := nWhite;
elem := nWhite.next;
WHILE (elem # nWhite) & (todo > 0) DO
INC (gcExa);
IF Grey IN elem.ecFlags THEN
elem.mark;
EXCL(elem.ecFlags, Grey);
EXCL(elem.ecFlags, white);
INCL(elem.ecFlags, black);
prev := elem;
elem := elem.next;
nGotGrey := TRUE;
ELSE
(* Requeue as Dark *)
elem2 := elem.next;
prev.next := elem.next;
elem.next := nDark.next;
nDark.next := 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, define those up to 'prev' as black.
** If not, define them as black.
*)
IF (nWhite.next # nWhite) & (prev # nWhite) THEN
prev.next := nBlack.next;
nBlack.next := nWhite.next;
nWhite.next := elem;
END;
IF todo < 1 THEN RETURN FALSE; END;
END;
(* --- Requeue possibly 'grey' white elements --- *)
IF (nWhite.next = nWhite) & nGotGrey THEN
elem := nWhite;
nWhite := nDark;
nDark := elem;
nGotGrey := FALSE;
END;
UNTIL nWhite.next = nWhite;
(* ------ Mark done, now setup for sweeping. ------ *)
sweeping := TRUE;
white := black;
black := 1-white;
(* Requeue the alive elements into the 'white' ring.
** The dead ones are already in the 'dark' ring.
*)
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 ------ *)
IF nDark.next # nDark THEN
prev := nDark;
elem := nDark.next;
WHILE (elem # nDark) & (todo > 0) DO
(* Dark elements should not be marked 'grey' after their processing
** but take care if it happens...
*)
IF Grey IN elem.ecFlags THEN
rc := keep;
ELSE
rc := elem.free();
END;
IF rc = keep THEN
elem.ecFlags := SHORTSET{white};
prev := elem;
elem := elem.next;
ELSE
elem2 := elem.next;
Free(elem, prev, 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, requeue those up to 'prev' as white.
*)
IF (nDark.next # nDark) & (prev # nDark) THEN
prev.next := nWhite.next;
nWhite.next := nDark.next;
nDark.next := elem;
END;
IF todo < 1 THEN RETURN FALSE; END;
END;
(* ------ Try to free all unreferenced objects from root set ------ *)
IF rDark.next # rDark THEN
prev := rDark;
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};
prev := elem;
elem := elem.next;
ELSE
elem2 := elem.next;
Free(elem, prev, 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, requeue those up to 'prev' as white.
*)
IF (rDark.next # rDark) & (prev # rDark) THEN
prev.next := rWhite.next;
rWhite.next := rDark.next;
rDark.next := elem;
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;
nGotGrey := FALSE;
(* If we arrive here, the GC is complete *)
RETURN TRUE;
END GC;
(*=========================================================================*)
BEGIN
black := Black; white := White;
nrTypes := 0;
freelist := NIL;
ResizeFreelist(20); (* Reserve an initial amount of entries *)
(* Init rootset
*)
NEW(rWhite);
rWhite.next := rWhite;
rWhite.ecFlags := SHORTSET{Root, Base};
NEW(rDark);
rDark.next := rDark;
rDark.ecFlags := SHORTSET{Root, Base};
NEW(rBlack);
rBlack.next := rBlack;
rBlack.ecFlags := SHORTSET{Root, Base};
nrRoot := 0;
(* Init normalset
*)
NEW(nBlack);
nBlack.next := nBlack;
nBlack.ecFlags := SHORTSET{Base};
NEW(nDark);
nDark.next := nDark;
nDark.ecFlags := SHORTSET{Base};
NEW(nWhite);
nWhite.next := nWhite;
nWhite.ecFlags := SHORTSET{Base};
nrNormal := 0;
nGotGrey := FALSE;
sweeping := FALSE;
gcRuns := 0;
gcReqT := 0;
gcCallsT := 0; gcCalls := 0;
gcFreeT := 0; gcExaT := 0;
gcFree := 0; gcExa := 0;
END CollectorS.
(***************************************************************************)