File psl-1983/3-1/kernel/nonrec-gc.red from the latest check-in


%
% NONREC-GC.RED - Non-recursive copying 2-space garbage collector for PSL
% 
% Author:      Eric Benson
%              Computer Science Dept.
%              University of Utah
% Date:        30 November 1981
% Copyright (c) 1981 Eric Benson
%

% Edit by Cris Perdue, 29 Mar 1983 1256-PST
% Removed "LispVar" from initialization of heap-warn-level,
%  added code in !%Reclaim to swap old and new trap bounds.
% Edit by Cris Perdue, 1 Mar 1983
% Removed external declaration of HeapPreviousLast (the only occurrence)
% Now using "known-free-space" function and heap-warn-level
% Sets HeapTrapped to NIL now.  (Value is T iff pre-GC trap has
% occurred since last GC.)
%  <PSL.KERNEL>COPYING-GC.RED.6,  4-Oct-82 17:56:49, Edit by BENSON
%  Added GCTime!*

fluid '(!*GC
	GCKnt!*
	GCTime!*
	Heap!-Warn!-Level	% Error if not this many items free after GC
	);

LoadTime
<<  GCKnt!* := 0;
    GCTime!* := 0;
    !*GC := T;
    Heap!-Warn!-Level := 1000
>>;

on SysLisp;

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

syslsp smacro procedure WithinOldHeapPointer X;
    X >= !%chipmunk!-kludge OldHeapLowerBound
and X <= !%chipmunk!-kludge OldHeapLast;

syslsp smacro procedure Mark X;
    MkItem(Forward, X);

syslsp smacro procedure Marked X;
    Tag X eq Forward;

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;

flag('(CopyFromAllBases CopyFromRange CopyFromBase CopyItem CopyItem1
       CopyFromNewHeap
       MarkAndCopyFromID MakeIDFreeList GCStats),
     'InternalFunction);
>>;

external WVar ST, StackLowerBound,
	      BndStkLowerBound, BndStkPtr,
              HeapLast, HeapLowerBound, HeapUpperBound,
              OldHeapLast, OldHeapLowerBound, OldHeapUpperBound,
	      HeapTrapBound, OldHeapTrapBound, HeapTrapped;

internal WVar StackLast, OldTime, OldSize;

syslsp procedure Reclaim();
    !%Reclaim();

syslsp procedure !%Reclaim();
begin scalar Tmp1, Tmp2;
    if LispVar !*GC then ErrorPrintF "*** Garbage collection starting";
    BeforeGCSystemHook();
    StackLast := MakeAddressFromStackPointer AdjustStackPointer(ST,
-FrameSize());
    OldTime := TimC();
    OldSize := HeapLast - HeapLowerBound;
    LispVar GCKnt!* := LispVar GCKnt!* + 1;
    OldHeapLast := HeapLast;
    HeapLast := OldHeapLowerBound;
    Tmp1 := HeapLowerBound;
    Tmp2 := HeapUpperBound;
    HeapLowerBound := OldHeapLowerBound;
    HeapUpperBound := OldHeapUpperBound;
    OldHeapLowerBound := Tmp1;
    OldHeapUpperBound := Tmp2;
    Tmp1 := HeapTrapBound;
    HeapTrapBound := OldHeapTrapBound;
    OldHeapTrapBound := Tmp1;
    CopyFromAllBases();
    MakeIDFreeList();
    AfterGCSystemHook();
    OldTime := TimC() - OldTime;
    LispVar GCTime!* := Plus2(LispVar GCTime!*, OldTime);
    if LispVar !*GC then GCStats();
    HeapTrapped := NIL;
    if IntInf Known!-Free!-Space() < IntInf (LispVar Heap!-Warning!-Level) then
	ContinuableError(99, "Heap space low", NIL)
>>;

syslsp procedure MarkAndCopyFromID X;
% SymNam has to be copied before marking, since the mark destroys the tag
% No problem since it's only a string, can't reference itself.
<<  CopyFromBase &SymNam X;
    MarkID X;
    CopyFromBase &SymPrp X;
    CopyFromBase &SymVal X >>;

syslsp procedure CopyFromAllBases();
begin scalar LastSymbol, B;
    MarkAndCopyFromID 128;% Mark NIL first
    for I := 0 step 1 until 127 do
if not MarkedID I then MarkAndCopyFromID I;
    for I := 0 step 1 until MaxObArray do
    <<  B := ObArray I;
if B > 0 and not MarkedID B then MarkAndCopyFromID B >>;
    B := BndStkLowerBound;
    while << B := AdjustBndStkPtr(B, 1);
     B <= BndStkPtr >> do
CopyFromBase B;
    for I := StackLowerBound step StackDirection*AddressingUnitsPerItem
     until StackLast do
CopyFromBase I;
    CopyFromNewHeap();
end;

syslsp procedure CopyFromNewHeap();
begin scalar P, Q;
    P := HeapLowerBound;
    while P < HeapLast do
    <<  Q := @P;
case Tag Q of
  HBYTES:
    P := &P[StrPack StrLen P];
  HHalfWords:
    P := &P[HalfWordPack HalfWordLen P];
  HWRDS:
    P := &P[WrdPack WrdLen P];
  HVECT:
    NIL;
  default:
    @P := CopyItem Q;
end;
P := &P[1] >>;
end;

syslsp procedure CopyFromRange(Lo, Hi);
begin scalar X, I;
    X := Lo;
    I := 0;
    while X <= Hi do
    <<  CopyFromBase X;
I := I + 1;
X := &Lo[I] >>;
end;

syslsp procedure CopyFromBase P;
    @P := CopyItem @P;

syslsp procedure CopyItem X;
begin scalar Typ, Info, Hdr;
    Typ := Tag X;
    if not PointerTagP Typ then return
    <<  if Typ = ID and not null X then% don't follow NIL, for speed
<<  Info := IDInf X;
    if not MarkedID Info then MarkAndCopyFromID Info >>;
X >>;
    Info := Inf X;
    if not WithinOldHeapPointer Info then return X;
    Hdr := @Info;
    if Marked Hdr then return MkItem(Typ, Inf Hdr);
    return CopyItem1 X;
end;

syslsp procedure CopyItem1 S;% Copier for GC
begin scalar NewS, Len, Ptr, StripS;
    return case Tag S of
      PAIR:
<<  Ptr := car S;
    Rplaca(S, Mark(NewS := GtHeap PairPack()));
    NewS[1] := cdr S;
    NewS[0] := Ptr;
    MkPAIR NewS >>;
      STR:
<<  @StrInf S := Mark(NewS := CopyString S);
    NewS >>;
      VECT:
<<  StripS := VecInf S;
    Len := VecLen StripS;
    @StripS := Mark(Ptr := GtVECT Len);
    for I := 0 step 1 until Len do
VecItm(Ptr, I) := VecItm(StripS, I);
    MkVEC Ptr >>;
      EVECT:
<<  StripS := VecInf S;
    Len := VecLen StripS;
    @StripS := Mark(Ptr := GtVECT Len);
    for I := 0 step 1 until Len do
VecItm(Ptr, I) := VecItm(StripS, I);
    MkItem(EVECT, Ptr) >>;
      WRDS, FIXN, FLTN, BIGN:
<<  Ptr := Tag S;
    @Inf S := Mark(NewS := CopyWRDS S);
    MkItem(Ptr, NewS) >>;
      default:
FatalError "Unexpected tag found during garbage collection";
    end;
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 GCStats();
<<  ErrorPrintF("*** GC %w: time %d ms, %d recovered, %d free",
LispVar GCKnt!*,   OldTime,
(OldSize - (HeapLast - HeapLowerBound))/AddressingUnitsPerItem,
(HeapUpperBound - HeapLast)/AddressingUnitsPerItem) >>;

off SysLisp;

END;


REDUCE Historical
REDUCE Sourceforge Project | Historical SVN Repository | GitHub Mirror | SourceHut Mirror | NotABug Mirror | Chisel Mirror | Chisel RSS ]