Artifact f4adde00d23f629d1771fe65d7a28d77b29a913246aebe96986d3a26dfaf1748:

• File psl-1983/3-1/kernel/nonrec-gc.red — part of check-in [eb17ceb7f6] at 2020-04-21 19:40:01 on branch master — Add Reduce 3.0 to the historical section of the archive, and some more
  files relating to version sof PSL from the early 1980s. Thanks are due to
  Paul McJones and Nelson Beebe for these, as well as to all the original
  authors.

  git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/historical@5328 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 6690) [annotate] [blame] [check-ins using] [more...]

%
% 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;