From: orpheus@reed.edu (P. Hawthorne)
Subject: Re: Memory allocation in your app
Organization: Reed College, Portland, OR
Date: Sat, 23 Jan 1993 05:41:28 GMT

  bpb9204@tamsun.tamu.edu (Brent Burton) asks:
: I was looking through the Mem Mgr and found out that you can create more
: than one memory zone, where the NewPtr, NewHandle, and Dispose* calls
: are active.  Does this mean that, for example in a compiler, you may
: allocate hundreds of little chunks of memory, and then when you are
: done using them, you may deallocate them all by destroying that memory
: zone?  

  You can do this, yes. It's remarkably simple. I think Rich Siegel posted
a snippet of code that does this a couple of months ago. But, remember,
the Macintosh memory manager is not designed to handle the oodles and
oodles of blocks that your average compiler wants to deal with. If you have
the time and the inclination, you can write a dynamic memory allocator
with the same functionality as the memory manager, with remarkably
different resource requirements.

  Here's an Object Pascal class I was working on last month.  It aint
production quality, nor would it build right off the bat, but it's
informative. It was going to become the memory zone class for the framework
I've been working on, but the recent example apps I've been working on
don't need variable length blocks, so it has been left to gather dust.

  It's your basic double two-way circular linked list of free and allocated
blocks, but it doesn't use tags per se. It isn't very faithful to the sort
of allocs you generally see around, but then, it's really cool for the
stone age Macintosh memory model, so, I guess it's okay. Sometimes
reinventing the wheel can be a lot of fun! I'd like to implement the binary
free tree technique that's mentioned in an exercise in Knuth, but haven't
had time. Maybe someone else could do it. I've radically changed the
WackyHandle datatype so that it can migrate between temporary memory and
application memory at will, for instance on suspend and resume events, but
this class doesn't grok the new interface.

  Oh, by the way, it uses offsets from a handle instead of pointers so
there is some dereferencing overhead, which reflects my idiosyncratic two
cents worth on memory management. Also, it presently uses a method for
dereferencing blocks, which reflects my feelings about typing while coding
extremely dangerous and sleazy hacks like this.

  Commentary more than just welcome.

  Cut here.


Unit QPool;

Interface

Uses
 Core;

Type
 BlockO = Longint;
 BlockP = ^BlockR;
 BlockR = Record
   length: Longint;
   backBlock, nextBlock: BlockO;
   free: Boolean;
   backFree, nextFree: BlockO;
  End;
 BlockA = Array[1..256] Of BlockR;
 BlockAP = ^BlockA;
 BlockAH = ^BlockAP;

Const
 BlockRSize = Longint(SizeOf(BlockR));
 SizeOfFreeLinks = Longint(SizeOf(BlockO) + SizeOf(BlockO));
 poolHead = 0;
 freeHead = BlockRSize;
 HeaderSize = Longint(BlockRSize + BlockRSize);

Type
 QPool = Object(QContent)
   pool: BlockAH;

   presentCapacity: Longint;
   usedCapacity: Longint;
   usualCapacity: Longint;
   growthCapacity: Longint;

   freeCount: Longint;
   freeCursor: BlockO;

   usesTemporaryMemory: Boolean;

   Function QPool.Construct: Boolean;
   override;
   Procedure QPool.Destruct;
   override;
   Procedure QPool.Loosen;
   override;
   Procedure QPool.Fasten;
   override;

   Procedure QPool.Check;

   Function QPool.Ref (aBlock: BlockO): BlockP;
   Function QPool.AvailBlock (Var aBlock: BlockO; aSize: Longint): Boolean;
   Procedure QPool.ReleaseBlock (Var aBlock: BlockO);
   Procedure QPool.ChangeBlock (source, destination: BlockO);
   Procedure QPool.Compact;
  End;


Procedure QuiverTest;

Implementation

Function AvailWackyHandle (Var aHandle: Univ Handle; aSize: Longint; temporary: Boolean): Boolean;
 Var
  aResult: OSErr;
 Begin
 If temporary Then
  Begin
  aHandle := MFTempNewHandle(aSize, aResult);
  If aHandle <> Nil Then
   If Not ourMemory.AddTemporaryHandle(aHandle) Then
    Begin
    MFTempDisposHandle(aHandle, aResult);
    aHandle := Nil;
    End;
  End
 Else
  aHandle := NewHandleClear(aSize);
 AvailWackyHandle := (aHandle <> Nil);
 End;

Procedure ReleaseWackyHandle (Var aHandle: Univ Handle; temporary: Boolean);
 Var
  aResult: OSErr;
 Begin
 If temporary Then
  Begin
  MFTempDisposHandle(aHandle, aResult);
  ourMemory.RemoveTemporaryHandle(aHandle);
  End
 Else
  DisposHandle(aHandle);
 aHandle := Nil;
 End;

Procedure LockWackyHandle (aHandle: Univ Handle; temporary: Boolean);
 Var
  aResult: OSErr;
 Begin
 If temporary Then
  MFTempHLock(aHandle, aResult)
 Else
  HLock(aHandle);
 End;

Procedure UnlockWackyHandle (aHandle: Univ Handle; temporary: Boolean);
 Var
  aResult: OSErr;
 Begin
 If temporary Then
  MFTempHUnlock(aHandle, aResult)
 Else
  HUnlock(aHandle);
 End;

Function GrowWackyHandle (Var aHandle: Univ Handle; aSize: Longint; temporary: Boolean): OSErr;
 Var
  aNewHandle: Handle;
  aResult: OSErr;
  aBoolean: Boolean;
 Begin
 If temporary Then
  Begin
  aNewHandle := MFTempNewHandle(aSize, aResult);
  If aNewHandle = Nil Then
   Begin
   GrowWackyHandle := aResult;
   Exit(GrowWackyHandle);
   End;
  MFTempHLock(aNewHandle, aResult);
  MFTempHLock(aHandle, aResult);
  BlockMove(@aHandle^^, @aNewHandle^^, aSize);
  MFTempDisposHandle(aHandle, aResult);
  ourMemory.RemoveTemporaryHandle(aHandle);
  aHandle := aNewHandle;
  aBoolean := ourMemory.AddTemporaryHandle(aHandle);
  GrowWackyHandle := noErr;
  End
 Else
  GrowWackyHandle := GrowHandle(aHandle, aSize);
 End;

Procedure SizeWackyHandle (Var aHandle: Univ Handle; aSize: Longint; temporary: Boolean);
 Var
  aNewHandle: Handle;
  aResult: OSErr;
  aBoolean: Boolean;
 Begin
 If temporary Then
  Begin
  aNewHandle := MFTempNewHandle(aSize, aResult);
  If aNewHandle = Nil Then
   Exit(SizeWackyHandle);
  BlockMove(@aHandle^^, @aNewHandle^^, aSize);
  MFTempDisposHandle(aHandle, aResult);
  ourMemory.RemoveTemporaryHandle(aHandle);
  aHandle := aNewHandle;
  aBoolean := ourMemory.AddTemporaryHandle(aHandle);
  MFTempHLock(aHandle, aResult);
  End
 Else
  SizeHandle(aHandle, aSize);
 End;

Function QPool.Construct: Boolean;
 Var
  freeP, poolP, newP: BlockP;

 Begin
 Construct := false;
 If Not Inherited Construct Then
  Exit(Construct);
 If (usualCapacity > BlockRSize) & AvailWackyHandle(pool, Longint(HeaderSize + usualCapacity), usesTemporaryMemory) Then
  Begin
  LockWackyHandle(pool, usesTemporaryMemory);
  presentCapacity := HeaderSize + usualCapacity;

  poolP := Ref(poolHead);
  poolP^.backBlock := HeaderSize;
  poolP^.nextBlock := HeaderSize;

  freeP := Ref(freeHead);
  freeP^.backFree := HeaderSize;
  freeP^.nextFree := HeaderSize;
  freeP^.free := true;

  newP := Ref(HeaderSize);
  newP^.backBlock := poolHead;
  newP^.nextBlock := poolHead;
  newP^.backFree := freeHead;
  newP^.nextFree := freeHead;
  newP^.length := usualCapacity - BlockRSize;
  newP^.free := true;

  poolP^.free := false;
  poolP^.length := 0;
  freeP^.free := true;
  freeP^.length := 0;
  freeP^.nextBlock := 0;
  freeP^.backBlock := 0;

  freeCount := 1;
  freeCursor := HeaderSize;
  End
 Else If AvailWackyHandle(pool, HeaderSize, usesTemporaryMemory) Then
  Begin
  LockWackyHandle(pool, usesTemporaryMemory);
  presentCapacity := HeaderSize;

  poolP := Ref(poolHead);
  poolP^.backBlock := poolHead;
  poolP^.nextBlock := poolHead;

  freeP := Ref(freeHead);
  freeP^.backFree := freeHead;
  freeP^.nextFree := freeHead;
  freeP^.free := true;
  freeCursor := freeHead;
  End
 Else
  Exit(Construct);

 usedCapacity := HeaderSize;
 Construct := true;
 End;

Procedure QPool.Destruct;
 Begin
 ReleaseWackyHandle(pool, usesTemporaryMemory);
 Inherited Destruct;
 End;

Procedure QPool.Loosen;
 Begin
 UnlockWackyHandle(pool, usesTemporaryMemory);
 Inherited Loosen;
 End;

Procedure QPool.Fasten;
 Begin
 Inherited Fasten;
 LockWackyHandle(pool, usesTemporaryMemory);
 End;

Function QPool.Ref (aBlock: BlockO): BlockP;
 Begin
 If aBlock < 0 Then
  Debugger
 Else If aBlock > presentCapacity Then
  Debugger;
 Ref := BlockP(Clean(LongintPtr(pool)^) + aBlock);
 End;

Function QPool.AvailBlock (Var aBlock: BlockO; aSize: Longint): Boolean;
 Var
  startCursor: BlockO;
  freeCursorP: BlockP;
  leastSize, requiredSize, thisSize, newCapacity: Longint;
  aBlockP, poolP, lastP, freeP: BlockP;
  spareO: BlockO;
  spareP: BlockP;
  spareLength: Longint;
  gotExtra: Boolean;
 Begin
 aSize := aSize - SizeOfFreeLinks;
 If aSize < 0 Then
  aSize := 0;
 AvailBlock := false;

 If freeCount > 0 Then
  Begin
  leastSize := aSize + BlockRSize;
  requiredSize := leastSize + BlockRSize;

  startCursor := freeCursor;
  Repeat
   freeCursorP := Ref(freeCursor);
   If (freeCursor <> freeHead) And (Not freeCursorP^.free) Then
    Debugger;
   thisSize := freeCursorP^.length;
   If (freeCursor <> freeHead) & ((thisSize = leastSize) | (thisSize >= requiredSize)) Then
    Begin
    aBlock := freeCursor;
    usedCapacity := usedCapacity + BlockRSize + aSize;

    freeCursorP^.length := aSize;
    freeCursorP^.free := false;
    freeCount := freeCount - 1;

    spareLength := thisSize - aSize;
{If spareLength = 0 Then}
{DebugStr('Exact fit!');}
{Writeln('Exact fit at ', LongintToString(freeCursor), '.');}
{else}
{Writeln('Fit at ', LongintToString(freeCursor), '.');}

    If spareLength = 0 Then
     Begin {Cut this block out of the free list}
     Ref(freeCursorP^.backFree)^.nextFree := freeCursorP^.nextFree;
     Ref(freeCursorP^.nextFree)^.backFree := freeCursorP^.backFree;
     freeCursor := freeCursorP^.nextFree;
     End
    Else
     Begin
     spareO := freeCursor + BlockRSize + aSize;
     spareP := Ref(spareO);

{Replace this block in the free list with a new block toward the end}
     spareP^.backFree := freeCursorP^.backFree;
     spareP^.nextFree := freeCursorP^.nextFree;
     Ref(spareP^.backFree)^.nextFree := spareO;
     Ref(spareP^.nextFree)^.backFree := spareO;

{Insert this new block into the pool list}
     spareP^.nextBlock := freeCursorP^.nextBlock;
     Ref(spareP^.nextBlock)^.backBlock := spareO;
     freeCursorP^.nextBlock := spareO;
     spareP^.backBlock := freeCursor;

     spareP^.length := spareLength - BlockRsize;
     spareP^.free := true;

     freeCursor := spareO;
     freeCount := freeCount + 1;
     End;

    AvailBlock := true;
    Exit(AvailBlock);
    End
   Else
    freeCursor := freeCursorP^.nextFree;
  Until freeCursor = startCursor;
  End;

 gotExtra := (growthCapacity > BlockRSize);
 newCapacity := presentCapacity + BlockRSize + aSize + growthCapacity;
 If GrowWackyHandle(pool, newCapacity, usesTemporaryMemory) <> noErr Then
  Begin
  gotExtra := false;
  newCapacity := newCapacity - growthCapacity;
  If GrowWackyHandle(pool, newCapacity, usesTemporaryMemory) <> noErr Then
   Exit(AvailBlock);
  End;

{Writeln('Growing for ', LongintToString(presentCapacity), '.');}

 aBlock := presentCapacity;
 presentCapacity := newCapacity;
 usedCapacity := usedCapacity + BlockRSize + aSize;

 aBlockP := Ref(aBlock);
 poolP := Ref(poolHead);
 lastP := Ref(poolP^.backBlock);

 lastP^.nextBlock := aBlock;
 aBlockP^.backBlock := poolP^.backBlock;
 aBlockP^.nextBlock := poolHead;
 poolP^.backBlock := aBlock;

 aBlockP^.length := aSize;
 aBlockP^.free := false;

 If gotExtra Then
  Begin
  spareO := aBlock + BlockRSize + aBlockP^.length;
  spareP := Ref(spareO);
  spareP^.free := true;
  spareP^.length := presentCapacity - spareO - BlockRSize;

  aBlockP^.nextBlock := spareO;
  spareP^.backBlock := poolP^.backBlock;
  spareP^.nextBlock := poolHead;
  poolP^.backBlock := spareO;

  freeP := Ref(freeHead);
  spareP^.backFree := freeP^.backFree;
  spareP^.nextFree := freeHead;
  Ref(spareP^.backFree)^.nextFree := spareO;
  freeP^.backFree := spareO;

  freeCount := freeCount + 1;
  End;
 AvailBlock := true;
 End;

Procedure QPool.ReleaseBlock (Var aBlock: BlockO);
 Var
  aBlockP: BlockP;
  cursorO: BlockO;
  cursorP: BlockP;
 Begin
 aBlockP := Ref(aBlock);
 If aBlockP^.free Then
  Debugger;
 aBlockP^.free := true;

 usedCapacity := usedCapacity - BlockRSize - aBlockP^.length;

 If freeCount = 0 Then
  Begin
  cursorP := Ref(freeHead);
  cursorP^.backFree := aBlock;
  cursorP^.nextFree := aBlock;
  aBlockP^.nextFree := freeHead;
  aBlockP^.backFree := freeHead;
  End
 Else
  Begin
  cursorO := freeHead;
  cursorP := Ref(freeHead);

  If Abs(cursorP^.backFree - aBlock) <= Abs(cursorP^.nextFree - aBlock) Then
   Begin {Scan backward from head of free list}
   If (freeCursor > aBlock) Then
    cursorP := Ref(freeCursor);
   Repeat
    cursorO := cursorP^.backFree;
    cursorP := Ref(cursorO);
   Until (cursorO < aBlock) | (cursorO = freeHead);
   End
  Else
   Begin {Scan foreward from head of free list}
   If (freeCursor < aBlock) Then
    cursorP := Ref(freeCursor);
   Repeat
    cursorO := cursorP^.nextFree;
    cursorP := Ref(cursorO);
   Until (cursorO > aBlock) | (cursorO = freeHead);
   cursorO := cursorP^.backFree;
   cursorP := Ref(cursorO);
   End;

  aBlockP^.nextFree := cursorP^.nextFree;
  Ref(aBlockP^.nextFree)^.backFree := aBlock;
  aBlockP^.backFree := cursorO;
  cursorP^.nextFree := aBlock;

  If cursorP^.nextBlock = aBlock Then
   Begin
{Writeln('Joining ', LongintToString(cursorO), ' to ', LongintToString(aBlock), '.');}
   cursorP^.length := cursorP^.length + BlockRSize + aBlockP^.length;
   cursorP^.nextFree := aBlockP^.nextFree;
   Ref(cursorP^.nextFree)^.backFree := cursorO;
   cursorP^.nextBlock := aBlockP^.nextBlock;
   Ref(cursorP^.nextBlock)^.backBlock := cursorO;

   aBlock := cursorO;
   aBlockP := cursorP;
   freeCount := freeCount - 1;
   End;

  If aBlockP^.nextBlock = aBlockP^.nextFree Then
   Begin
{Writeln('Merging ', LongintToString(aBlock), ' with ', LongintToString(aBlockP^.nextFree), '.');}
   cursorP := Ref(aBlockP^.nextFree);
   aBlockP^.length := aBlockP^.length + BlockRSize + cursorP^.length;
   aBlockP^.nextFree := cursorP^.nextFree;
   Ref(aBlockP^.nextFree)^.backFree := aBlock;
   aBlockP^.nextBlock := cursorP^.nextBlock;
   Ref(aBlockP^.nextBlock)^.backBlock := aBlock;
   freeCount := freeCount - 1;
   End;
  End;

 freeCount := freeCount + 1;

 If (aBlock > usualCapacity) & (aBlockP^.nextBlock = poolHead) Then
  Begin
{Writeln('Truncating at ', LongintToString(aBlock), '.');}

  freeCount := freeCount - 1;

  Ref(freeHead)^.backFree := aBlockP^.backFree;
  Ref(aBlockP^.backFree)^.nextFree := freeHead;

  Ref(poolHead)^.backBlock := aBlockP^.backBlock;
  Ref(aBlockP^.backBlock)^.nextBlock := poolHead;

  freeCursor := Ref(freeHead)^.nextFree;

  presentCapacity := aBlock;
  SizeWackyHandle(pool, presentCapacity, usesTemporaryMemory);

  End
 Else
  freeCursor := aBlock;

 aBlock := 0;
 End;

Procedure QPool.Check;
 Var
  previousO, cursorO: BlockO;
  previousP, cursorP: BlockP;
  totalFree: Longint;
 Begin

 If usedCapacity < 0 Then
  Debugger;

 If freeCount < 0 Then
  Debugger;

{Check pool list}
 cursorO := poolHead;
 cursorP := Ref(poolHead);

 Repeat
  previousO := cursorO;
  previousP := cursorP;
  cursorO := cursorP^.nextBlock;
  cursorP := Ref(cursorO);
  If cursorP^.backBlock <> previousO Then
   Debugger;
 Until cursorO = poolHead;

{Check free list}
 If freeCount = 0 Then
  Begin
  If usedCapacity <> presentCapacity Then
   Nothing;
  End
 Else
  Begin
  cursorO := freeHead;
  cursorP := Ref(freeHead);

  totalFree := 0;
  Repeat
   previousO := cursorO;
   previousP := cursorP;
   cursorO := cursorP^.nextFree;
   cursorP := Ref(cursorO);
   If cursorO <> freeHead Then
    totalFree := totalFree + cursorP^.length + BlockRSize;
   If cursorP^.backFree <> previousO Then
    Debugger;
   If cursorP^.nextFree = cursorP^.nextBlock Then
    Debugger;
  Until cursorO = freeHead;

  If Abs(totalFree - (presentCapacity - usedCapacity)) > 0 Then
   Debugger;
  End;
 End;

Procedure QPool.ChangeBlock (source, destination: BlockO);
 Var
  a: Longint;
 Begin
{if source <> destination then}
{for a := 1 to N do}
{if offsets[a] = source then}
{begin}
{offsets[a] := destination;}
{Leave;}
{end;}
 End;

Procedure QPool.Compact;
 Var
  FreeP, PoolP: BlockP;
  TargetO, StartO, FinishO, NextTargetO, CursorO, NextCursorO: BlockO;
  TargetP, StartP, FinishP, NextTargetP, CursorP: BlockP;
  Delta, Length: Longint;

 Begin
 FreeP := Ref(freeHead);
 PoolP := Ref(poolHead);

 FreeCursor := freeHead;

 While (FreeP^.nextFree <> freeHead) & (PoolP^.backBlock <> FreeP^.nextFree) Do
  Begin
  TargetO := FreeP^.nextFree;
  TargetP := Ref(TargetO);

  StartO := TargetP^.nextBlock;
  StartP := Ref(StartO);

  NextTargetO := TargetP^.nextFree;
  If NextTargetO = freeHead Then
   NextTargetO := poolHead;
  NextTargetP := Ref(NextTargetO);

  FinishO := Ref(NextTargetO)^.backBlock;
  FinishP := Ref(FinishO);

  CursorO := StartO;
  CursorP := StartP;
  Delta := TargetO - StartO;
  Length := 0;
  Repeat
   Length := Length + BlockRSize + CursorP^.length;
   ChangeBlock(CursorO, CursorO + Delta);

   CursorP^.backBlock := CursorP^.backBlock + Delta;
   CursorO := CursorP^.nextBlock;
   CursorP^.nextBlock := CursorP^.nextBlock + Delta;
   CursorP := Ref(CursorO);
  Until CursorO = NextTargetO;

  CursorO := TargetO + Length;
  CursorP := Ref(CursorO);
  StartP^.backBlock := TargetP^.backBlock;
  FinishP^.nextBlock := CursorO;

  BlockMove(Ptr(StartP), Ptr(TargetP), Length);

  CursorP^.length := Abs(Delta);
  If NextTargetO <> poolHead Then
   CursorP^.length := CursorP^.length + NextTargetP^.length;
{BlockRSize added and subtracted to CursorP^.length}
  CursorP^.free := true;

  CursorP^.backBlock := FinishO + Delta;
  CursorP^.backFree := freeHead;
  FreeP^.nextFree := CursorO;

  If NextTargetO = poolHead Then
   Begin
   CursorP^.nextFree := freeHead;
   FreeP^.backFree := CursorO;

   CursorP^.nextBlock := poolHead;
   PoolP^.backBlock := CursorO;
   End
  Else
   Begin
   CursorP^.nextFree := NextTargetP^.nextFree;
   Ref(CursorP^.nextFree)^.backFree := CursorO;

   CursorP^.nextBlock := NextTargetP^.nextBlock;
   Ref(CursorP^.nextBlock)^.backBlock := CursorO;

   FreeCount := FreeCount - 1;
   End;
  End;

 If (PresentCapacity > UsualCapacity) & (FreeP^.backFree = PoolP^.backBlock) Then
  Begin
  CursorO := FreeP^.backFree;
  CursorP := Ref(CursorO);

{Writeln('Shortening at ', LongintToString(CursorO), '.');}

  FreeP^.backFree := CursorP^.backFree;
  Ref(CursorP^.backFree)^.nextFree := freeHead;

  PoolP^.backBlock := CursorP^.backBlock;
  Ref(CursorP^.backBlock)^.nextBlock := poolHead;

  presentCapacity := CursorO;
  SizeWackyHandle(Pool, PresentCapacity, usesTemporaryMemory);

  FreeCount := FreeCount - 1;
  End;

 End;

Procedure QuiverTest;
 Const
  N = 2500;
  MinimumLength = 12;
  MaximumLength = 24;

  iterationsBeforeReport = 4096;

 Var
  offsets: Array[1..N] Of BlockO;
  sizes: Array[1..N] Of Longint;

  epoch: Longint;

  aPool: QPool;
  a, e, i: Longint;
  aBlock: BlockO;
  aBlockP: BlockP;
  aStringP: StringPtr;
  anEvent: EventRecord;

 Begin
 ShowText;
 DebugStr('You must uncomment the ChangeBlock method.');

 For a := 1 To 4 Do
  randseed := randseed * TickCount * Random;
{randseed := Longint(-230814419);}
 Writeln('randseed = ', LongintToString(randseed));
 Writeln;

 New(aPool);
 aPool.Dub('The Pool We Are Testing.');
 aPool.usesTemporaryMemory := true;
 aPool.usualCapacity := Trunc(n * (BlockRSize + (minimumLength + maximumLength) / 2));
 aPool.growthCapacity := 1000;
 If Not aPool.Construct Then
  Exit(QuiverTest);

 i := aPool.usedCapacity;
 For a := 1 To N Do
  Begin
  e := MonteCarlo(MinimumLength, MaximumLength);
  i := i + e + BlockRSize;
  If Not aPool.AvailBlock(aBlock, e) Then
   Debugger;
  aBlockP := aPool.Ref(aBlock);
  If aBlockP^.free Then
   Debugger;
  aStringP := StringPtr(Clean(aBlockP) + BlockRSize - SizeOfFreeLinks);
  aStringP^ := LongintToString(Longint(e - SizeOfFreeLinks));
  offsets[a] := aBlock;
  sizes[a] := e;
  If i <> aPool.usedCapacity Then
   Nothing;
{aPool.Check;}
  End;

 Repeat
  e := MonteCarlo(1, N);

  aBlock := offsets[e];
  aBlockP := aPool.Ref(aBlock);

  If aBlock <> 0 Then
   Begin
{Writeln('Releasing ', LongintToString(aBlock), '.');}
   aStringP := StringPtr(Clean(aBlockP) + BlockRSize - SizeOfFreeLinks);
   If aStringP^ <> LongintToString(aBlockP^.length) Then
    Debugger;

   aPool.ReleaseBlock(offsets[e]);
   If offsets[e] <> 0 Then
    Debugger;
   sizes[e] := 0;
   End
  Else
   Begin
   i := MonteCarlo(MinimumLength, MaximumLength);
   If Not aPool.AvailBlock(offsets[e], i) Then
    If Not aPool.AvailBlock(offsets[e], i) Then
     Debugger;
{Writeln('Created ', LongintToString(offsets[e]), '.');}
   If offsets[e] = 0 Then
    Debugger;
   aBlockP := aPool.Ref(offsets[e]);
   aStringP := StringPtr(Clean(aBlockP) + BlockRSize - SizeOfFreeLinks);
   aStringP^ := LongintToString(Longint(i - SizeOfFreeLinks));
   sizes[e] := i;
   End;

{aPool.Check;}
{Writeln;}

  GetKeys;

  epoch := epoch + 1;
  If epoch > iterationsBeforeReport Then
   Begin
{If Button Then}
   Begin
   Write('CompactingI ');
   aPool.usualCapacity := aPool.usedCapacity;
   aPool.Compact;
   Write('Done. ');
   End;

   Writeln(PercentageToString(Percentage(aPool.usedCapacity, aPool.presentCapacity)), ' used.');
{aPool.Check;}
   epoch := 0;

   SystemTask;
   aPool.Loosen;
   If WaitNextEvent(everyEvent, anEvent, 3000, Nil) Then
    Nothing;
   aPool.Fasten;
   End;

  If epoch Mod (iterationsBeforeReport Div 4) = 0 Then
   Begin
   aPool.Loosen;
   If WaitNextEvent(everyEvent, anEvent, 0, Nil) Then
    Nothing;
   aPool.Fasten;
   End;

 Until SpaceKey;

 aPool.Destruct;
 End;

End.