reduce-historical/psl-1983/3-1/tests/p-comp-gc.red

%
% p-comp-GC.RED - Compacting garbage collector for PSL
% 
% Author:      Martin Griss and Eric Benson
%	       Symbolic Computation Group
%              Computer Science Dept.
%              University of Utah
% Date:        28 August 1981
% Copyright (c) 1981 University of Utah
%

% WARNING!  This file has not been parameterized using
% AddressingUnitsPerItem.  It will not work on machines that
% address bytes. /csp 3-1-83

% All data types have either explicit header tag in first item,
% or are assumed to be 1st element of pair.

% Revision History:
% Edit by Griss, 17 March 1983.
%  Move major data structures to XXX-HEADER: GCArray
% Edit by Cris Perdue, 16 Feb 1983 1407-PST
% Fixed GtHeap and collector(s) to use only HeapLast, not HeapPreviousLast
% Sets HeapTrapped to NIL now.
% Using known-free-space function
%  Added check of Heap-Warn-Level after %Reclaim
%  Defined and used known-free-space function
%  <PSL.KERNEL>COMPACTING-GC.RED.9,  4-Oct-82 17:59:55, Edit by BENSON
%  Added GCTime!*
%  <PSL.KERNEL>COMPACTING-GC.RED.3, 21-Sep-82 10:43:21, Edit by BENSON
%  Flagged most functions internal
% (M.L. Griss, March, 1977).
% (Update to speed up, July 1978)
% Converted to Syslisp July 1980
% En-STRUCT-ed, Eric Benson April 1981
% Added EVECT tag, M. Griss, 3 July 1982
fluid '(!*GC				% Controls printing of statistics
	GCTime!*			% Total amount of time spent in GC
	GCKnt!*				% count of # of GC's since system build
	heap!-warn!-level);		% Continuable error if this much not
					% free after %Reclaim.

LoadTime <<
    !*GC := T;				% Do print GC messages (SL Rep says no)
    GCTime!* := 0;
    GCKnt!* := 0;			% Initialize to zero
    Heap!-Warn!-Level := 1000;
>>;

on Syslisp;


% Predicates for whether to follow pointers

external WVar HeapLowerBound,		% Bottom of heap
	      HeapUpperBound,		% Top of heap
	      HeapLast,			% Last item allocated
	      HeapTrapped;		% Boolean: has trap occurred since GC?

CompileTime <<

flag('(MarkFromAllBases BuildRelocationFields UpdateAllBases CompactHeap
       MarkFromOneSymbol MakeIDFreeList
       GCMessage MarkFromSymbols MarkFromRange MarkFromBase MarkFromVector
       GCError UpdateSymbols UpdateRegion UpdateItem UpdateHeap),
     'NotYetInternalFunction);

syslsp smacro procedure PointerTagP X;
    X > PosInt and X < Code;

syslsp smacro procedure WithinHeapPointer X;
    X >= HeapLowerBound and X <= HeapLast;

>>;

% Marking primitives

internal WConst GCMarkValue = 8#777,
		HSkip = Forward;

CompileTime <<
syslsp smacro procedure Mark X;		% Get GC mark bits in item X points to
    GCField @X;

syslsp smacro procedure SetMark X;	% Set GC mark bits in item X points to
    GCField @X := GCMarkValue;

syslsp smacro procedure ClearMark X;  % Clear GC mark bits in item X points to
    GCField @X := if NegIntP @X then -1 else 0;

syslsp smacro procedure Marked X;	% Is item pointed to by X marked?
    Mark X eq GCMarkValue;


syslsp smacro procedure MarkID X;
    Field(SymNam X, TagStartingBit, TagBitLength) := Forward;

syslsp smacro procedure MarkedID X;
    Tag SymNam X eq Forward;

syslsp smacro procedure ClearIDMark X;
    Field(SymNam X, TagStartingBit, TagBitLength) := STR;


% Relocation primitives

syslsp smacro procedure SkipLength X;	% Stored in heap header
    Inf @X;

syslsp smacro procedure PutSkipLength(X, L);	% Store in heap header
    Inf @X := L;

put('SkipLength, 'Assign!-Op, 'PutSkipLength);
>>;

internal WConst BitsInSegment = 13,
		SegmentLength = LShift(1, BitsInSegment),
		SegmentMask = SegmentLength - 1;

External WArray GCArray;


CompileTime <<
syslsp smacro procedure SegmentNumber X;	% Get segment part of pointer
    LShift(X - HeapLowerBound, -BitsInSegment);

syslsp smacro procedure OffsetInSegment X;	% Get offset part of pointer
    LAnd(X - HeapLowerBound, SegmentMask);

syslsp smacro procedure MovementWithinSegment X;	% Reloc field in item
    GCField @X;

syslsp smacro procedure PutMovementWithinSegment(X, M);	% Store reloc field
    GCField @X := M;

syslsp smacro procedure ClearMovementWithinSegment X;	% Clear reloc field
    GCField @X := if NegIntP @X then -1 else 0;

put('MovementWithinSegment, 'Assign!-Op, 'PutMovementWithinSegment);

syslsp smacro procedure SegmentMovement X;	% Segment table
    GCArray[X];

syslsp smacro procedure PutSegmentMovement(X, M);	% Store in seg table
    GCArray[X] := M;

put('SegmentMovement, 'Assign!-Op, 'PutSegmentMovement);

syslsp smacro procedure Reloc X;	% Compute pointer adjustment
    X - (SegmentMovement SegmentNumber X + MovementWithinSegment X);
>>;

external WVar ST,			% stack pointer
	      StackLowerBound;		% bottom of stack

% Base registers marked from by collector

% SymNam, SymPrp and SymVal are declared for all

external WVar NextSymbol;		% next ID number to be allocated

external WVar BndStkLowerBound,		% Bottom of binding stack
	      BndStkPtr;		% Binding stack pointer

internal WVar StackEnd,			% Holds address of bottom of stack
	      StackStart,		% Holds address of top of stack
	      MarkTag,			% Used by MarkFromBase only
	      Hole,			% First location moved in heap
	      HeapShrink,		% Total amount reclaimed
	      StartingRealTime;

syslsp procedure Reclaim();		%. User call to garbage collector
<<  !%Reclaim();
    NIL >>;

syslsp procedure !%Reclaim();		% Garbage collector
<<  StackEnd := MakeAddressFromStackPointer ST - FrameSize();
    StackStart := StackLowerBound;
    if LispVar !*GC then ErrorPrintF "*** Garbage collection starting";
    StartingRealTime := TimC();
    LispVar GCKnt!* := LispVar GCKnt!* + 1; % must be INUM > 0, so needn't chk
    MarkFromAllBases();
    MakeIDFreeList();
    BuildRelocationFields();
    UpdateAllBases();
    CompactHeap();
    HeapLast := HeapLast - HeapShrink;
    StartingRealTime := TimC() - StartingRealTime;
    LispVar GCTime!* := Plus2(LispVar GCTime!*, StartingRealTime);
    if LispVar !*GC then GCMessage();
    HeapTrapped := NIL;
    if IntInf known!-free!-space() < IntInf (LispVar Heap!-Warn!-Level) then
	ContinuableError(99, "Heap space low", NIL);
>>;

syslsp procedure MarkFromAllBases();
begin scalar B;
    MarkFromSymbols();
    MarkFromRange(StackStart, StackEnd);
    B := BndStkLowerBound;
    while << B := AdjustBndStkPtr(B, 1);
	     B <= BndStkPtr >> do
	MarkFromBase @B;
end;

syslsp procedure MarkFromSymbols();
begin scalar B;
    MarkFromOneSymbol 128;		% mark NIL first
    for I := 0 step 1 until 127 do
	if not MarkedID I then MarkFromOneSymbol I;
    for I := 0 step 1 until MaxObArray do
    <<  B := ObArray I;
	if B > 0 and not MarkedID B then MarkFromOneSymbol B >>;
end;

syslsp procedure MarkFromOneSymbol X;
% SymNam has to be marked from before marking ID, since the mark uses its tag
% No problem since it's only a string, can't reference itself.
<<  MarkFromBase SymNam X;
    MarkID X;
    MarkFromBase SymPrp X;
    MarkFromBase SymVal X >>;

syslsp procedure MarkFromRange(Low, High);
    for Ptr := Low step 1 until High do MarkFromBase @Ptr;

syslsp procedure MarkFromBase Base;
begin scalar MarkInfo;
    MarkTag := Tag Base;
    if not PointerTagP MarkTag then return
    <<  if MarkTag = ID and not null Base then
	<<  MarkInfo := IDInf Base;
	    if not MarkedID MarkInfo then MarkFromOneSymbol MarkInfo >> >>;
    MarkInfo := Inf Base;
    if not WithinHeapPointer MarkInfo
	or Marked MarkInfo then return;
    SetMark MarkInfo;
CommentOutCode    CheckAndSetMark MarkInfo;
    return if MarkTag eq VECT or MarkTag eq EVECT then
	MarkFromVector MarkInfo
    else if MarkTag eq PAIR then
	<<  MarkFromBase car Base;
	    MarkFromBase cdr Base >>;
end;

CommentOutCode <<
syslsp procedure CheckAndSetMark P;
begin scalar HeadAtP;
    HeadAtP := Tag @P;
    case MarkTag of
    STR:
	if HeadAtP eq HBYTES then SetMark P;
    FIXN, FLTN, BIGN, WRDS:
	if HeadAtP eq HWRDS then SetMark P;
    VECT, EVECT:
	if HeadAtP eq HVECT then SetMark P;
    PAIR:
	SetMark P;
    default:
	GCError("Internal error in marking phase, at %o", P)
    end;
end;
>>;

syslsp procedure MarkFromVector Info;
begin scalar Uplim;
CommentOutCode    if Tag @Info neq HVECT then return;
    Uplim := &VecItm(Info, VecLen Info);
    for Ptr := &VecItm(Info, 0) step 1 until Uplim do
	MarkFromBase @Ptr;
end;

syslsp procedure MakeIDFreeList();
begin scalar Previous;
    for I := 0 step 1 until 128 do
	ClearIDMark I;
    Previous := 129;
    while MarkedID Previous and Previous <= MaxSymbols do
    <<  ClearIDMark Previous;
	Previous := Previous + 1 >>;
    if Previous >= MaxSymbols then
	NextSymbol := 0
    else
	NextSymbol := Previous;		% free list starts here
    for I := Previous + 1 step 1 until MaxSymbols do
	if MarkedID I then ClearIDMark I
	else
	<<  SymNam Previous := I;
	    Previous := I >>;
    SymNam Previous := 0;		% end of free list
end;

syslsp procedure BuildRelocationFields();
%
%        Pass 2 - Turn off GC marks and Build SEGKNTs
%
begin scalar CurrentItem, SGCurrent, IGCurrent, TmpIG, DCount, SegLen;
    SGCurrent := IGCurrent := 0;
    SegmentMovement SGCurrent := 0;	% Dummy
    Hole := HeapLowerBound - 1;		% will be first hole
    DCount := HeapShrink := 0;		% holes in current segment, total holes
    CurrentItem := HeapLowerBound;
    while CurrentItem < HeapLast do
    begin scalar Incr;
	SegLen := case Tag @CurrentItem of
	BTRTAG, CODE, NEGINT, POSINT, ID, UNBOUND,
	STR, BYTES, FIXN, FLTN, BIGN, WRDS, Halfwords, PAIR, VECT, EVECT:
	    2;	 % must be first of pair
	HBYTES:
	    1 + StrPack StrLen CurrentItem;
	HHalfwords:
	    1 + HalfWordPack StrLen CurrentItem;
	HWRDS:
	    1 + WrdPack WrdLen CurrentItem;
	HVECT:
	    1 + VectPack VecLen CurrentItem;
	HSKIP:
	    SkipLength CurrentItem;
	default:
	    GCError("Illegal item in heap at %o", CurrentItem)
	end;	 % case
	if Marked CurrentItem then	 % a hole
	    if HeapShrink = 0 then
		ClearMark CurrentItem
	else				% segment also clears mark
	<<  MovementWithinSegment CurrentItem := DCount; % incremental shift
	    Incr := 0 >>			 % no shift
	else
	<<  @CurrentItem := MkItem(HSKIP, SegLen);	 % a skip mark
	    Incr := 1;					 % more shift
	    if Hole < HeapLowerBound then Hole := CurrentItem >>;
	TmpIG := IGCurrent + SegLen;	% set SEG size
	CurrentItem := CurrentItem + SegLen;
	while TmpIG >= SegmentLength do
	  begin scalar Tmp;
	    Tmp := SegmentLength - IGCurrent;	% Expand to next SEGMENT
	    SegLen := SegLen - Tmp;
	    if Incr eq 1 then HeapShrink := HeapShrink + Tmp;
	    DCount := IGCurrent := 0;
	    SGCurrent := SGCurrent + 1;
	    SegmentMovement SGCurrent := HeapShrink;	% Store Next Base
	    TmpIG := TmpIG - SegmentLength;
	  end;
	IGCurrent := TmpIG;
	if Incr eq 1 then
	<<  HeapShrink := HeapShrink + SegLen;
	    DCount := DCount + SegLen >>;	% Add in Hole Size
      end;
    SegmentMovement(SGCurrent + 1) := HeapShrink;
end;

syslsp procedure UpdateAllBases();
begin scalar B;
    UpdateSymbols();
    UpdateRegion(StackStart, StackEnd);
    B := BndStkLowerBound;
    while << B := AdjustBndStkPtr(B, 1);
	     B <= BndStkPtr >> do
	UpdateItem B;
    UpdateHeap() >>;

syslsp procedure UpdateSymbols();
    for I := 0 step 1 until MaxSymbols do
    begin scalar NameLoc;
	NameLoc := &SymNam I;
	if StringP @NameLoc then
	<<  UpdateItem NameLoc;
	    UpdateItem &SymVal I;
	    UpdateItem &SymPrp I >>;
    end;

syslsp procedure UpdateRegion(Low, High);
    for Ptr := Low step 1 until High do UpdateItem Ptr;

syslsp procedure UpdateHeap();
begin scalar CurrentItem;
    CurrentItem := HeapLowerBound;
    while CurrentItem < HeapLast do
    begin
	case Tag @CurrentItem of
	BTRTAG, CODE, NEGINT, POSINT, ID, UNBOUND:
	    CurrentItem := CurrentItem + 1;
	STR, BYTES, FIXN, FLTN, BIGN, WRDS, Halfwords, PAIR, VECT, EVECT:
	<<  if Inf @CurrentItem >= Hole and Inf @CurrentItem <= HeapLast then
		Inf @CurrentItem := Reloc Inf @CurrentItem;
	    CurrentItem := CurrentItem + 1 >>;
	HBYTES:
	    CurrentItem := CurrentItem + 1 + StrPack StrLen CurrentItem;
	HHalfwords:
	    CurrentItem := CurrentItem + 1 + HalfwordPack StrLen CurrentItem;
	HWRDS:
	    CurrentItem := CurrentItem + 1 + WrdPack WrdLen CurrentItem;
	HVECT:
	begin scalar Tmp;
	    Tmp := VecLen CurrentItem;
	    CurrentItem := CurrentItem + 1;	% Move over header
	    for I := 0 step 1 until Tmp do	% VecLen + 1 items
	    begin scalar Tmp2, Tmp3;
		Tmp2 := @CurrentItem;
		Tmp3 := Tag Tmp2;
		if PointerTagP Tmp3
			and Inf Tmp2 >= Hole and Inf Tmp2 <= HeapLast then
		    Inf @CurrentItem := Reloc Inf Tmp2;
		CurrentItem := CurrentItem + 1;
	    end;
	  end;
	HSKIP:
	    CurrentItem := CurrentItem + SkipLength CurrentItem;
	default:
	    GCError("Internal error in updating phase at %o", CurrentItem)
	end;	 % case
    end
end;

syslsp procedure UpdateItem Ptr;
begin scalar Tg, Info;
    Tg := Tag @Ptr;
    if not PointerTagP Tg then return;
    Info := INF @Ptr;
    if Info < Hole or Info > HeapLast then return;
    Inf @Ptr := Reloc Info;
end;

syslsp procedure CompactHeap();
begin scalar OldItemPtr, NewItemPtr, SegLen;
    if Hole < HeapLowerBound then return;
    NewItemPtr := OldItemPtr := Hole;
    while OldItemPtr < HeapLast do
      begin;
	case Tag @OldItemPtr of
	BTRTAG, CODE, NEGINT, POSINT, ID, UNBOUND,
	STR, BYTES, FIXN, FLTN, BIGN, WRDS, Halfwords, PAIR, VECT, EVECT:
	    SegLen := PairPack OldItemPtr;
	HBYTES:
	    SegLen := 1 + StrPack StrLen OldItemPtr;
	HHalfwords:
	    SegLen := 1 + HalfWordPack HalfwordLen OldItemPtr;
	HWRDS:
	    SegLen := 1 + WrdPack WrdLen OldItemPtr;
	HVECT:
	    SegLen := 1 + VectPack VecLen OldItemPtr;
	HSKIP:
	<<  OldItemPtr := OldItemPtr + SkipLength OldItemPtr;
	    goto WhileNext >>;
	default:
	    GCError("Internal error in compaction at %o", OldItemPtr)
	end;	 % case
	ClearMovementWithinSegment OldItemPtr;
	for I := 1 step 1 until SegLen do
	<<  @NewItemPtr := @OldItemPtr;
	    NewItemPtr := NewItemPtr + 1;
	    OldItemPtr := OldItemPtr + 1 >>;
    WhileNext:
      end;
end;

syslsp procedure GCError(Message, P);
<<  ErrorPrintF("***** Fatal error during garbage collection");
    ErrorPrintF(Message, P);
    while T do Quit; >>;

syslsp procedure GCMessage();
<<  ErrorPrintF("*** GC %w: time %d ms",
	LispVar GCKnt!*,  StartingRealTime);
    ErrorPrintF("*** %d recovered, %d stable, %d active, %d free",
		HeapShrink, Hole - HeapLowerBound,
					HeapLast - Hole,
					  intinf known!-free!-space() ) >>;

off SysLisp;

END;