Artifact e356fa2f7249a8a4e64c3bbf38b37152b756c8907e00bcea2f4efe77bed554b4:

• File psl-1983/3-1/kernel/20/allocators.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: 5535) [annotate] [blame] [check-ins using] [more...]

%
% ALLOCATORS.RED - Low level storage management
%
% Author:      Eric Benson
%              Computer Science Dept.
%              University of Utah
% Date:        27 August 1981
% Copyright (c) 1981 University of Utah
%

%  <SWANSON.TEST>ALLOCATORS.UPD.2,  3-Apr-83 09:57:03, Edit by SWANSON
%  Added changes required to fit Ext-20 model
%  <PSL.KERNEL>ALLOCATORS.RED.7, 23-Mar-83 11:35:37, Edit by KESSLER
%  Added OldHeapTrapBound to exported WVars, so we can update the heap trap

%  bound upon switch.
% Edit by Cris Perdue, 16 Feb 1983 1834-PST
% Pre-GC trap, known-free-space fns
%  <PSL.KERNEL>ALLOCATORS.RED.4, 10-Jan-83 15:50:50, Edit by PERDUE
%  Added GtEVect

on SysLisp;

external WArray BPS, Heap, Heap2;

CommentOutCode <<			% For the compacting GC
exported WVar HeapLast = &Heap[0],	% pointer to next free slot in heap

	      HeapLowerBound = &Heap[0],	% bottom of heap
	      HeapUpperBound = &Heap[HeapSize],
	      HeapTrapBound = &Heap[HeapSize]; % Value of HeapLast for trap

>>;
exported WVar HeapLast = &Heap[0],	% pointer to next free slot in heap

	      HeapLowerBound = &Heap[0],	% bottom of heap
	      HeapUpperBound = &Heap[HeapSize], % end of active heap
	      OldHeapLast,
	      OldHeapLowerBound = &Heap2[0],
	      OldHeapUpperBound = &Heap2[HeapSize],
	      HeapTrapBound = &Heap[HeapSize], % Value of HeapLast for trap

	      OldHeapTrapBound = &Heap2[HeapSize];
>>);
exported WVar HeapTrapped = NIL;	% Boolean: trap since last GC?


compiletime flag('(GtHeap1), 'InternalFunction);

syslsp procedure Known!-Free!-Space;
MkInt((HeapUpperBound - HeapLast)/AddressingUnitsPerItem);

syslsp procedure GtHEAP N;		%. get heap block of N words
if null N then known!-free!-space() else
    GtHeap1(N, NIL);

syslsp procedure GtHeap1(N, LastTryP);
begin scalar PrevLast;
    PrevLast := HeapLast;
    HeapLast := HeapLast + N*AddressingUnitsPerItem;
    if HeapLast > HeapTrapBound then
	if HeapLast > HeapUpperBound then
	<<  HeapLast := PrevLast;
	    if LastTryP then FatalError "Heap space exhausted"
	    else
	    <<  !%Reclaim();
		return GtHeap1(N, T) >> >>
	else
	%% From one GC to the next there can be at most 1 GC trap,
	%%  done the first time space gets "low".  %Reclaim resets
	%%  HeapTrapped to NIL.
	if HeapTrapped = NIL then
	    <<  HeapTrapped := T;
	        GC!-Trap!-Level() >>;
    return PrevLast
end;

syslsp procedure GC!-Trap!-Level;
MkInt (HeapUpperBound - HeapTrapBound)/AddressingUnitsPerItem;

syslsp procedure Set!-GC!-Trap!-Level N;
<<  if not IntP(N) then NonIntegerError(N, 'Set!-GC!-Trap!-Level);
    N := IntInf N;
    HeapTrapBound := HeapUpperBound - N*AddressingUnitsPerItem;
    T >>;

syslsp procedure DelHeap(LowPointer, HighPointer);
    if HighPointer eq HeapLast then HeapLast := LowPointer;

syslsp procedure GtSTR N;		%. Allocate space for a string N chars
begin scalar S, NW;
    S := GtHEAP((NW := STRPack N) + 1);
    @S := MkItem(HBytes, N);
    S[NW] := 0;				% clear last word, including last byte
    return S;
end;

syslsp procedure GtConstSTR N;	 %. allocate un-collected string for print name
begin scalar S, NW;			% same as GtSTR, but uses BPS, not heap
    S := GtBPS((NW := STRPack N) + 1);
    @S := N;
    S[NW] := 0;				% clear last word, including last byte
    return S;
end;

syslsp procedure GtHalfWords N;		%. Allocate space for N halfwords
begin scalar S, NW;
    S := GtHEAP((NW := HalfWordPack N) + 1);
    @S := MkItem(HHalfWords, N);
    return S;
end;

syslsp procedure GtVECT N;		%. Allocate space for a vector N items
begin scalar V;
    V := GtHEAP(VECTPack N + 1);
    @V := MkItem(HVECT, N);
    return V;
end;

Putd('GtEvect,'expr,cdr getd 'GtVect);

syslsp procedure GtWRDS N;		%. Allocate space for N untraced words
begin scalar W;
    W := GtHEAP(WRDPack N + 1);
    @W := MkItem(HWRDS, N);
    return W;
end;


syslsp procedure GtFIXN();		%. allocate space for a fixnum
begin scalar W;
    W := GtHEAP(WRDPack 0 + 1);
    @W := MkItem(HWRDS, 0);
    return W;
end;

syslsp procedure GtFLTN();		%. allocate space for a float
begin scalar W;
    W := GtHEAP(WRDPack 1 + 1);
    @W := MkItem(HWRDS, 1);
    return W;
end;

% NextSymbol and SymbolTableSize are globally declared

syslsp procedure GtID();		%. Allocate a new ID
%
% IDs are allocated as a linked free list through the SymNam cell,
% with a 0 to indicate the end of the list.
%
begin scalar U;
    if NextSymbol = 0 then
    <<  Reclaim();
	if NextSymbol = 0 then
	    return FatalError "Ran out of ID space" >>;
    U := NextSymbol;
    NextSymbol := SymNam U;
    return U;
end;

external WVar NextBPS,
	      LastBPS;

syslsp procedure GtBPS N;		%. Allocate N words for binary code
begin scalar B;
    if null N then return((LastBPS - NextBPS)/AddressingUnitsPerItem);
					% GTBPS NIL returns # left
    B := NextBPS;
    NextBPS := NextBPS + N*AddressingUnitsPerItem;
    return if NextBPS > LastBPS then
	StdError '"Ran out of binary program space"
    else B;
end;

syslsp procedure DelBPS(Bottom, Top);	%. Return space to BPS
    if NextBPS eq Top then NextBPS := Bottom;

syslsp procedure GtWArray N;	%. Allocate N words for WVar/WArray/WString
begin scalar B;
    if null N then return((LastBPS - NextBPS)/AddressingUnitsPerItem);
					% GtWArray NIL returns # left
    B := LastBPS - N*AddressingUnitsPerItem;
    return if NextBPS > B then
	StdError '"Ran out of WArray space"
    else
	LastBPS := B;
end;

syslsp procedure DelWArray(Bottom, Top);	%. Return space for WArray
    if LastBPS eq Bottom then LastBPS := Top;

off SysLisp;

END;