home *** CD-ROM | disk | FTP | other *** search
/ NetNews Usenet Archive 1993 #3 / NN_1993_3.iso / spool / comp / sys / mac / programm / 22016 < prev    next >
Encoding:
Text File  |  1993-01-23  |  21.3 KB  |  849 lines
  1. Newsgroups: comp.sys.mac.programmer
  2. Path: sparky!uunet!cs.utexas.edu!sdd.hp.com!saimiri.primate.wisc.edu!usenet.coe.montana.edu!news.u.washington.edu!henson!reed!orpheus
  3. From: orpheus@reed.edu (P. Hawthorne)
  4. Subject: Re: Memory allocation in your app
  5. References: <1jqf8tINNnm7@tamsun.tamu.edu>
  6. Organization: Reed College, Portland, OR
  7. Date: Sat, 23 Jan 1993 05:41:28 GMT
  8. Message-ID: <1993Jan23.054128.29021@reed.edu>
  9. Lines: 838
  10.  
  11.   bpb9204@tamsun.tamu.edu (Brent Burton) asks:
  12. : I was looking through the Mem Mgr and found out that you can create more
  13. : than one memory zone, where the NewPtr, NewHandle, and Dispose* calls
  14. : are active.  Does this mean that, for example in a compiler, you may
  15. : allocate hundreds of little chunks of memory, and then when you are
  16. : done using them, you may deallocate them all by destroying that memory
  17. : zone?  
  18.  
  19.   You can do this, yes. It's remarkably simple. I think Rich Siegel posted
  20. a snippet of code that does this a couple of months ago. But, remember,
  21. the Macintosh memory manager is not designed to handle the oodles and
  22. oodles of blocks that your average compiler wants to deal with. If you have
  23. the time and the inclination, you can write a dynamic memory allocator
  24. with the same functionality as the memory manager, with remarkably
  25. different resource requirements.
  26.  
  27.   Here's an Object Pascal class I was working on last month.  It aint
  28. production quality, nor would it build right off the bat, but it's
  29. informative. It was going to become the memory zone class for the framework
  30. I've been working on, but the recent example apps I've been working on
  31. don't need variable length blocks, so it has been left to gather dust.
  32.  
  33.   It's your basic double two-way circular linked list of free and allocated
  34. blocks, but it doesn't use tags per se. It isn't very faithful to the sort
  35. of allocs you generally see around, but then, it's really cool for the
  36. stone age Macintosh memory model, so, I guess it's okay. Sometimes
  37. reinventing the wheel can be a lot of fun! I'd like to implement the binary
  38. free tree technique that's mentioned in an exercise in Knuth, but haven't
  39. had time. Maybe someone else could do it. I've radically changed the
  40. WackyHandle datatype so that it can migrate between temporary memory and
  41. application memory at will, for instance on suspend and resume events, but
  42. this class doesn't grok the new interface.
  43.  
  44.   Oh, by the way, it uses offsets from a handle instead of pointers so
  45. there is some dereferencing overhead, which reflects my idiosyncratic two
  46. cents worth on memory management. Also, it presently uses a method for
  47. dereferencing blocks, which reflects my feelings about typing while coding
  48. extremely dangerous and sleazy hacks like this.
  49.  
  50.   Commentary more than just welcome.
  51.  
  52.   Cut here.
  53.  
  54.  
  55. Unit QPool;
  56.  
  57. Interface
  58.  
  59. Uses
  60.  Core;
  61.  
  62. Type
  63.  BlockO = Longint;
  64.  BlockP = ^BlockR;
  65.  BlockR = Record
  66.    length: Longint;
  67.    backBlock, nextBlock: BlockO;
  68.    free: Boolean;
  69.    backFree, nextFree: BlockO;
  70.   End;
  71.  BlockA = Array[1..256] Of BlockR;
  72.  BlockAP = ^BlockA;
  73.  BlockAH = ^BlockAP;
  74.  
  75. Const
  76.  BlockRSize = Longint(SizeOf(BlockR));
  77.  SizeOfFreeLinks = Longint(SizeOf(BlockO) + SizeOf(BlockO));
  78.  poolHead = 0;
  79.  freeHead = BlockRSize;
  80.  HeaderSize = Longint(BlockRSize + BlockRSize);
  81.  
  82. Type
  83.  QPool = Object(QContent)
  84.    pool: BlockAH;
  85.  
  86.    presentCapacity: Longint;
  87.    usedCapacity: Longint;
  88.    usualCapacity: Longint;
  89.    growthCapacity: Longint;
  90.  
  91.    freeCount: Longint;
  92.    freeCursor: BlockO;
  93.  
  94.    usesTemporaryMemory: Boolean;
  95.  
  96.    Function QPool.Construct: Boolean;
  97.    override;
  98.    Procedure QPool.Destruct;
  99.    override;
  100.    Procedure QPool.Loosen;
  101.    override;
  102.    Procedure QPool.Fasten;
  103.    override;
  104.  
  105.    Procedure QPool.Check;
  106.  
  107.    Function QPool.Ref (aBlock: BlockO): BlockP;
  108.    Function QPool.AvailBlock (Var aBlock: BlockO; aSize: Longint): Boolean;
  109.    Procedure QPool.ReleaseBlock (Var aBlock: BlockO);
  110.    Procedure QPool.ChangeBlock (source, destination: BlockO);
  111.    Procedure QPool.Compact;
  112.   End;
  113.  
  114.  
  115. Procedure QuiverTest;
  116.  
  117. Implementation
  118.  
  119. Function AvailWackyHandle (Var aHandle: Univ Handle; aSize: Longint; temporary: Boolean): Boolean;
  120.  Var
  121.   aResult: OSErr;
  122.  Begin
  123.  If temporary Then
  124.   Begin
  125.   aHandle := MFTempNewHandle(aSize, aResult);
  126.   If aHandle <> Nil Then
  127.    If Not ourMemory.AddTemporaryHandle(aHandle) Then
  128.     Begin
  129.     MFTempDisposHandle(aHandle, aResult);
  130.     aHandle := Nil;
  131.     End;
  132.   End
  133.  Else
  134.   aHandle := NewHandleClear(aSize);
  135.  AvailWackyHandle := (aHandle <> Nil);
  136.  End;
  137.  
  138. Procedure ReleaseWackyHandle (Var aHandle: Univ Handle; temporary: Boolean);
  139.  Var
  140.   aResult: OSErr;
  141.  Begin
  142.  If temporary Then
  143.   Begin
  144.   MFTempDisposHandle(aHandle, aResult);
  145.   ourMemory.RemoveTemporaryHandle(aHandle);
  146.   End
  147.  Else
  148.   DisposHandle(aHandle);
  149.  aHandle := Nil;
  150.  End;
  151.  
  152. Procedure LockWackyHandle (aHandle: Univ Handle; temporary: Boolean);
  153.  Var
  154.   aResult: OSErr;
  155.  Begin
  156.  If temporary Then
  157.   MFTempHLock(aHandle, aResult)
  158.  Else
  159.   HLock(aHandle);
  160.  End;
  161.  
  162. Procedure UnlockWackyHandle (aHandle: Univ Handle; temporary: Boolean);
  163.  Var
  164.   aResult: OSErr;
  165.  Begin
  166.  If temporary Then
  167.   MFTempHUnlock(aHandle, aResult)
  168.  Else
  169.   HUnlock(aHandle);
  170.  End;
  171.  
  172. Function GrowWackyHandle (Var aHandle: Univ Handle; aSize: Longint; temporary: Boolean): OSErr;
  173.  Var
  174.   aNewHandle: Handle;
  175.   aResult: OSErr;
  176.   aBoolean: Boolean;
  177.  Begin
  178.  If temporary Then
  179.   Begin
  180.   aNewHandle := MFTempNewHandle(aSize, aResult);
  181.   If aNewHandle = Nil Then
  182.    Begin
  183.    GrowWackyHandle := aResult;
  184.    Exit(GrowWackyHandle);
  185.    End;
  186.   MFTempHLock(aNewHandle, aResult);
  187.   MFTempHLock(aHandle, aResult);
  188.   BlockMove(@aHandle^^, @aNewHandle^^, aSize);
  189.   MFTempDisposHandle(aHandle, aResult);
  190.   ourMemory.RemoveTemporaryHandle(aHandle);
  191.   aHandle := aNewHandle;
  192.   aBoolean := ourMemory.AddTemporaryHandle(aHandle);
  193.   GrowWackyHandle := noErr;
  194.   End
  195.  Else
  196.   GrowWackyHandle := GrowHandle(aHandle, aSize);
  197.  End;
  198.  
  199. Procedure SizeWackyHandle (Var aHandle: Univ Handle; aSize: Longint; temporary: Boolean);
  200.  Var
  201.   aNewHandle: Handle;
  202.   aResult: OSErr;
  203.   aBoolean: Boolean;
  204.  Begin
  205.  If temporary Then
  206.   Begin
  207.   aNewHandle := MFTempNewHandle(aSize, aResult);
  208.   If aNewHandle = Nil Then
  209.    Exit(SizeWackyHandle);
  210.   BlockMove(@aHandle^^, @aNewHandle^^, aSize);
  211.   MFTempDisposHandle(aHandle, aResult);
  212.   ourMemory.RemoveTemporaryHandle(aHandle);
  213.   aHandle := aNewHandle;
  214.   aBoolean := ourMemory.AddTemporaryHandle(aHandle);
  215.   MFTempHLock(aHandle, aResult);
  216.   End
  217.  Else
  218.   SizeHandle(aHandle, aSize);
  219.  End;
  220.  
  221. Function QPool.Construct: Boolean;
  222.  Var
  223.   freeP, poolP, newP: BlockP;
  224.  
  225.  Begin
  226.  Construct := false;
  227.  If Not Inherited Construct Then
  228.   Exit(Construct);
  229.  If (usualCapacity > BlockRSize) & AvailWackyHandle(pool, Longint(HeaderSize + usualCapacity), usesTemporaryMemory) Then
  230.   Begin
  231.   LockWackyHandle(pool, usesTemporaryMemory);
  232.   presentCapacity := HeaderSize + usualCapacity;
  233.  
  234.   poolP := Ref(poolHead);
  235.   poolP^.backBlock := HeaderSize;
  236.   poolP^.nextBlock := HeaderSize;
  237.  
  238.   freeP := Ref(freeHead);
  239.   freeP^.backFree := HeaderSize;
  240.   freeP^.nextFree := HeaderSize;
  241.   freeP^.free := true;
  242.  
  243.   newP := Ref(HeaderSize);
  244.   newP^.backBlock := poolHead;
  245.   newP^.nextBlock := poolHead;
  246.   newP^.backFree := freeHead;
  247.   newP^.nextFree := freeHead;
  248.   newP^.length := usualCapacity - BlockRSize;
  249.   newP^.free := true;
  250.  
  251.   poolP^.free := false;
  252.   poolP^.length := 0;
  253.   freeP^.free := true;
  254.   freeP^.length := 0;
  255.   freeP^.nextBlock := 0;
  256.   freeP^.backBlock := 0;
  257.  
  258.   freeCount := 1;
  259.   freeCursor := HeaderSize;
  260.   End
  261.  Else If AvailWackyHandle(pool, HeaderSize, usesTemporaryMemory) Then
  262.   Begin
  263.   LockWackyHandle(pool, usesTemporaryMemory);
  264.   presentCapacity := HeaderSize;
  265.  
  266.   poolP := Ref(poolHead);
  267.   poolP^.backBlock := poolHead;
  268.   poolP^.nextBlock := poolHead;
  269.  
  270.   freeP := Ref(freeHead);
  271.   freeP^.backFree := freeHead;
  272.   freeP^.nextFree := freeHead;
  273.   freeP^.free := true;
  274.   freeCursor := freeHead;
  275.   End
  276.  Else
  277.   Exit(Construct);
  278.  
  279.  usedCapacity := HeaderSize;
  280.  Construct := true;
  281.  End;
  282.  
  283. Procedure QPool.Destruct;
  284.  Begin
  285.  ReleaseWackyHandle(pool, usesTemporaryMemory);
  286.  Inherited Destruct;
  287.  End;
  288.  
  289. Procedure QPool.Loosen;
  290.  Begin
  291.  UnlockWackyHandle(pool, usesTemporaryMemory);
  292.  Inherited Loosen;
  293.  End;
  294.  
  295. Procedure QPool.Fasten;
  296.  Begin
  297.  Inherited Fasten;
  298.  LockWackyHandle(pool, usesTemporaryMemory);
  299.  End;
  300.  
  301. Function QPool.Ref (aBlock: BlockO): BlockP;
  302.  Begin
  303.  If aBlock < 0 Then
  304.   Debugger
  305.  Else If aBlock > presentCapacity Then
  306.   Debugger;
  307.  Ref := BlockP(Clean(LongintPtr(pool)^) + aBlock);
  308.  End;
  309.  
  310. Function QPool.AvailBlock (Var aBlock: BlockO; aSize: Longint): Boolean;
  311.  Var
  312.   startCursor: BlockO;
  313.   freeCursorP: BlockP;
  314.   leastSize, requiredSize, thisSize, newCapacity: Longint;
  315.   aBlockP, poolP, lastP, freeP: BlockP;
  316.   spareO: BlockO;
  317.   spareP: BlockP;
  318.   spareLength: Longint;
  319.   gotExtra: Boolean;
  320.  Begin
  321.  aSize := aSize - SizeOfFreeLinks;
  322.  If aSize < 0 Then
  323.   aSize := 0;
  324.  AvailBlock := false;
  325.  
  326.  If freeCount > 0 Then
  327.   Begin
  328.   leastSize := aSize + BlockRSize;
  329.   requiredSize := leastSize + BlockRSize;
  330.  
  331.   startCursor := freeCursor;
  332.   Repeat
  333.    freeCursorP := Ref(freeCursor);
  334.    If (freeCursor <> freeHead) And (Not freeCursorP^.free) Then
  335.     Debugger;
  336.    thisSize := freeCursorP^.length;
  337.    If (freeCursor <> freeHead) & ((thisSize = leastSize) | (thisSize >= requiredSize)) Then
  338.     Begin
  339.     aBlock := freeCursor;
  340.     usedCapacity := usedCapacity + BlockRSize + aSize;
  341.  
  342.     freeCursorP^.length := aSize;
  343.     freeCursorP^.free := false;
  344.     freeCount := freeCount - 1;
  345.  
  346.     spareLength := thisSize - aSize;
  347. {If spareLength = 0 Then}
  348. {DebugStr('Exact fit!');}
  349. {Writeln('Exact fit at ', LongintToString(freeCursor), '.');}
  350. {else}
  351. {Writeln('Fit at ', LongintToString(freeCursor), '.');}
  352.  
  353.     If spareLength = 0 Then
  354.      Begin {Cut this block out of the free list}
  355.      Ref(freeCursorP^.backFree)^.nextFree := freeCursorP^.nextFree;
  356.      Ref(freeCursorP^.nextFree)^.backFree := freeCursorP^.backFree;
  357.      freeCursor := freeCursorP^.nextFree;
  358.      End
  359.     Else
  360.      Begin
  361.      spareO := freeCursor + BlockRSize + aSize;
  362.      spareP := Ref(spareO);
  363.  
  364. {Replace this block in the free list with a new block toward the end}
  365.      spareP^.backFree := freeCursorP^.backFree;
  366.      spareP^.nextFree := freeCursorP^.nextFree;
  367.      Ref(spareP^.backFree)^.nextFree := spareO;
  368.      Ref(spareP^.nextFree)^.backFree := spareO;
  369.  
  370. {Insert this new block into the pool list}
  371.      spareP^.nextBlock := freeCursorP^.nextBlock;
  372.      Ref(spareP^.nextBlock)^.backBlock := spareO;
  373.      freeCursorP^.nextBlock := spareO;
  374.      spareP^.backBlock := freeCursor;
  375.  
  376.      spareP^.length := spareLength - BlockRsize;
  377.      spareP^.free := true;
  378.  
  379.      freeCursor := spareO;
  380.      freeCount := freeCount + 1;
  381.      End;
  382.  
  383.     AvailBlock := true;
  384.     Exit(AvailBlock);
  385.     End
  386.    Else
  387.     freeCursor := freeCursorP^.nextFree;
  388.   Until freeCursor = startCursor;
  389.   End;
  390.  
  391.  gotExtra := (growthCapacity > BlockRSize);
  392.  newCapacity := presentCapacity + BlockRSize + aSize + growthCapacity;
  393.  If GrowWackyHandle(pool, newCapacity, usesTemporaryMemory) <> noErr Then
  394.   Begin
  395.   gotExtra := false;
  396.   newCapacity := newCapacity - growthCapacity;
  397.   If GrowWackyHandle(pool, newCapacity, usesTemporaryMemory) <> noErr Then
  398.    Exit(AvailBlock);
  399.   End;
  400.  
  401. {Writeln('Growing for ', LongintToString(presentCapacity), '.');}
  402.  
  403.  aBlock := presentCapacity;
  404.  presentCapacity := newCapacity;
  405.  usedCapacity := usedCapacity + BlockRSize + aSize;
  406.  
  407.  aBlockP := Ref(aBlock);
  408.  poolP := Ref(poolHead);
  409.  lastP := Ref(poolP^.backBlock);
  410.  
  411.  lastP^.nextBlock := aBlock;
  412.  aBlockP^.backBlock := poolP^.backBlock;
  413.  aBlockP^.nextBlock := poolHead;
  414.  poolP^.backBlock := aBlock;
  415.  
  416.  aBlockP^.length := aSize;
  417.  aBlockP^.free := false;
  418.  
  419.  If gotExtra Then
  420.   Begin
  421.   spareO := aBlock + BlockRSize + aBlockP^.length;
  422.   spareP := Ref(spareO);
  423.   spareP^.free := true;
  424.   spareP^.length := presentCapacity - spareO - BlockRSize;
  425.  
  426.   aBlockP^.nextBlock := spareO;
  427.   spareP^.backBlock := poolP^.backBlock;
  428.   spareP^.nextBlock := poolHead;
  429.   poolP^.backBlock := spareO;
  430.  
  431.   freeP := Ref(freeHead);
  432.   spareP^.backFree := freeP^.backFree;
  433.   spareP^.nextFree := freeHead;
  434.   Ref(spareP^.backFree)^.nextFree := spareO;
  435.   freeP^.backFree := spareO;
  436.  
  437.   freeCount := freeCount + 1;
  438.   End;
  439.  AvailBlock := true;
  440.  End;
  441.  
  442. Procedure QPool.ReleaseBlock (Var aBlock: BlockO);
  443.  Var
  444.   aBlockP: BlockP;
  445.   cursorO: BlockO;
  446.   cursorP: BlockP;
  447.  Begin
  448.  aBlockP := Ref(aBlock);
  449.  If aBlockP^.free Then
  450.   Debugger;
  451.  aBlockP^.free := true;
  452.  
  453.  usedCapacity := usedCapacity - BlockRSize - aBlockP^.length;
  454.  
  455.  If freeCount = 0 Then
  456.   Begin
  457.   cursorP := Ref(freeHead);
  458.   cursorP^.backFree := aBlock;
  459.   cursorP^.nextFree := aBlock;
  460.   aBlockP^.nextFree := freeHead;
  461.   aBlockP^.backFree := freeHead;
  462.   End
  463.  Else
  464.   Begin
  465.   cursorO := freeHead;
  466.   cursorP := Ref(freeHead);
  467.  
  468.   If Abs(cursorP^.backFree - aBlock) <= Abs(cursorP^.nextFree - aBlock) Then
  469.    Begin {Scan backward from head of free list}
  470.    If (freeCursor > aBlock) Then
  471.     cursorP := Ref(freeCursor);
  472.    Repeat
  473.     cursorO := cursorP^.backFree;
  474.     cursorP := Ref(cursorO);
  475.    Until (cursorO < aBlock) | (cursorO = freeHead);
  476.    End
  477.   Else
  478.    Begin {Scan foreward from head of free list}
  479.    If (freeCursor < aBlock) Then
  480.     cursorP := Ref(freeCursor);
  481.    Repeat
  482.     cursorO := cursorP^.nextFree;
  483.     cursorP := Ref(cursorO);
  484.    Until (cursorO > aBlock) | (cursorO = freeHead);
  485.    cursorO := cursorP^.backFree;
  486.    cursorP := Ref(cursorO);
  487.    End;
  488.  
  489.   aBlockP^.nextFree := cursorP^.nextFree;
  490.   Ref(aBlockP^.nextFree)^.backFree := aBlock;
  491.   aBlockP^.backFree := cursorO;
  492.   cursorP^.nextFree := aBlock;
  493.  
  494.   If cursorP^.nextBlock = aBlock Then
  495.    Begin
  496. {Writeln('Joining ', LongintToString(cursorO), ' to ', LongintToString(aBlock), '.');}
  497.    cursorP^.length := cursorP^.length + BlockRSize + aBlockP^.length;
  498.    cursorP^.nextFree := aBlockP^.nextFree;
  499.    Ref(cursorP^.nextFree)^.backFree := cursorO;
  500.    cursorP^.nextBlock := aBlockP^.nextBlock;
  501.    Ref(cursorP^.nextBlock)^.backBlock := cursorO;
  502.  
  503.    aBlock := cursorO;
  504.    aBlockP := cursorP;
  505.    freeCount := freeCount - 1;
  506.    End;
  507.  
  508.   If aBlockP^.nextBlock = aBlockP^.nextFree Then
  509.    Begin
  510. {Writeln('Merging ', LongintToString(aBlock), ' with ', LongintToString(aBlockP^.nextFree), '.');}
  511.    cursorP := Ref(aBlockP^.nextFree);
  512.    aBlockP^.length := aBlockP^.length + BlockRSize + cursorP^.length;
  513.    aBlockP^.nextFree := cursorP^.nextFree;
  514.    Ref(aBlockP^.nextFree)^.backFree := aBlock;
  515.    aBlockP^.nextBlock := cursorP^.nextBlock;
  516.    Ref(aBlockP^.nextBlock)^.backBlock := aBlock;
  517.    freeCount := freeCount - 1;
  518.    End;
  519.   End;
  520.  
  521.  freeCount := freeCount + 1;
  522.  
  523.  If (aBlock > usualCapacity) & (aBlockP^.nextBlock = poolHead) Then
  524.   Begin
  525. {Writeln('Truncating at ', LongintToString(aBlock), '.');}
  526.  
  527.   freeCount := freeCount - 1;
  528.  
  529.   Ref(freeHead)^.backFree := aBlockP^.backFree;
  530.   Ref(aBlockP^.backFree)^.nextFree := freeHead;
  531.  
  532.   Ref(poolHead)^.backBlock := aBlockP^.backBlock;
  533.   Ref(aBlockP^.backBlock)^.nextBlock := poolHead;
  534.  
  535.   freeCursor := Ref(freeHead)^.nextFree;
  536.  
  537.   presentCapacity := aBlock;
  538.   SizeWackyHandle(pool, presentCapacity, usesTemporaryMemory);
  539.  
  540.   End
  541.  Else
  542.   freeCursor := aBlock;
  543.  
  544.  aBlock := 0;
  545.  End;
  546.  
  547. Procedure QPool.Check;
  548.  Var
  549.   previousO, cursorO: BlockO;
  550.   previousP, cursorP: BlockP;
  551.   totalFree: Longint;
  552.  Begin
  553.  
  554.  If usedCapacity < 0 Then
  555.   Debugger;
  556.  
  557.  If freeCount < 0 Then
  558.   Debugger;
  559.  
  560. {Check pool list}
  561.  cursorO := poolHead;
  562.  cursorP := Ref(poolHead);
  563.  
  564.  Repeat
  565.   previousO := cursorO;
  566.   previousP := cursorP;
  567.   cursorO := cursorP^.nextBlock;
  568.   cursorP := Ref(cursorO);
  569.   If cursorP^.backBlock <> previousO Then
  570.    Debugger;
  571.  Until cursorO = poolHead;
  572.  
  573. {Check free list}
  574.  If freeCount = 0 Then
  575.   Begin
  576.   If usedCapacity <> presentCapacity Then
  577.    Nothing;
  578.   End
  579.  Else
  580.   Begin
  581.   cursorO := freeHead;
  582.   cursorP := Ref(freeHead);
  583.  
  584.   totalFree := 0;
  585.   Repeat
  586.    previousO := cursorO;
  587.    previousP := cursorP;
  588.    cursorO := cursorP^.nextFree;
  589.    cursorP := Ref(cursorO);
  590.    If cursorO <> freeHead Then
  591.     totalFree := totalFree + cursorP^.length + BlockRSize;
  592.    If cursorP^.backFree <> previousO Then
  593.     Debugger;
  594.    If cursorP^.nextFree = cursorP^.nextBlock Then
  595.     Debugger;
  596.   Until cursorO = freeHead;
  597.  
  598.   If Abs(totalFree - (presentCapacity - usedCapacity)) > 0 Then
  599.    Debugger;
  600.   End;
  601.  End;
  602.  
  603. Procedure QPool.ChangeBlock (source, destination: BlockO);
  604.  Var
  605.   a: Longint;
  606.  Begin
  607. {if source <> destination then}
  608. {for a := 1 to N do}
  609. {if offsets[a] = source then}
  610. {begin}
  611. {offsets[a] := destination;}
  612. {Leave;}
  613. {end;}
  614.  End;
  615.  
  616. Procedure QPool.Compact;
  617.  Var
  618.   FreeP, PoolP: BlockP;
  619.   TargetO, StartO, FinishO, NextTargetO, CursorO, NextCursorO: BlockO;
  620.   TargetP, StartP, FinishP, NextTargetP, CursorP: BlockP;
  621.   Delta, Length: Longint;
  622.  
  623.  Begin
  624.  FreeP := Ref(freeHead);
  625.  PoolP := Ref(poolHead);
  626.  
  627.  FreeCursor := freeHead;
  628.  
  629.  While (FreeP^.nextFree <> freeHead) & (PoolP^.backBlock <> FreeP^.nextFree) Do
  630.   Begin
  631.   TargetO := FreeP^.nextFree;
  632.   TargetP := Ref(TargetO);
  633.  
  634.   StartO := TargetP^.nextBlock;
  635.   StartP := Ref(StartO);
  636.  
  637.   NextTargetO := TargetP^.nextFree;
  638.   If NextTargetO = freeHead Then
  639.    NextTargetO := poolHead;
  640.   NextTargetP := Ref(NextTargetO);
  641.  
  642.   FinishO := Ref(NextTargetO)^.backBlock;
  643.   FinishP := Ref(FinishO);
  644.  
  645.   CursorO := StartO;
  646.   CursorP := StartP;
  647.   Delta := TargetO - StartO;
  648.   Length := 0;
  649.   Repeat
  650.    Length := Length + BlockRSize + CursorP^.length;
  651.    ChangeBlock(CursorO, CursorO + Delta);
  652.  
  653.    CursorP^.backBlock := CursorP^.backBlock + Delta;
  654.    CursorO := CursorP^.nextBlock;
  655.    CursorP^.nextBlock := CursorP^.nextBlock + Delta;
  656.    CursorP := Ref(CursorO);
  657.   Until CursorO = NextTargetO;
  658.  
  659.   CursorO := TargetO + Length;
  660.   CursorP := Ref(CursorO);
  661.   StartP^.backBlock := TargetP^.backBlock;
  662.   FinishP^.nextBlock := CursorO;
  663.  
  664.   BlockMove(Ptr(StartP), Ptr(TargetP), Length);
  665.  
  666.   CursorP^.length := Abs(Delta);
  667.   If NextTargetO <> poolHead Then
  668.    CursorP^.length := CursorP^.length + NextTargetP^.length;
  669. {BlockRSize added and subtracted to CursorP^.length}
  670.   CursorP^.free := true;
  671.  
  672.   CursorP^.backBlock := FinishO + Delta;
  673.   CursorP^.backFree := freeHead;
  674.   FreeP^.nextFree := CursorO;
  675.  
  676.   If NextTargetO = poolHead Then
  677.    Begin
  678.    CursorP^.nextFree := freeHead;
  679.    FreeP^.backFree := CursorO;
  680.  
  681.    CursorP^.nextBlock := poolHead;
  682.    PoolP^.backBlock := CursorO;
  683.    End
  684.   Else
  685.    Begin
  686.    CursorP^.nextFree := NextTargetP^.nextFree;
  687.    Ref(CursorP^.nextFree)^.backFree := CursorO;
  688.  
  689.    CursorP^.nextBlock := NextTargetP^.nextBlock;
  690.    Ref(CursorP^.nextBlock)^.backBlock := CursorO;
  691.  
  692.    FreeCount := FreeCount - 1;
  693.    End;
  694.   End;
  695.  
  696.  If (PresentCapacity > UsualCapacity) & (FreeP^.backFree = PoolP^.backBlock) Then
  697.   Begin
  698.   CursorO := FreeP^.backFree;
  699.   CursorP := Ref(CursorO);
  700.  
  701. {Writeln('Shortening at ', LongintToString(CursorO), '.');}
  702.  
  703.   FreeP^.backFree := CursorP^.backFree;
  704.   Ref(CursorP^.backFree)^.nextFree := freeHead;
  705.  
  706.   PoolP^.backBlock := CursorP^.backBlock;
  707.   Ref(CursorP^.backBlock)^.nextBlock := poolHead;
  708.  
  709.   presentCapacity := CursorO;
  710.   SizeWackyHandle(Pool, PresentCapacity, usesTemporaryMemory);
  711.  
  712.   FreeCount := FreeCount - 1;
  713.   End;
  714.  
  715.  End;
  716.  
  717. Procedure QuiverTest;
  718.  Const
  719.   N = 2500;
  720.   MinimumLength = 12;
  721.   MaximumLength = 24;
  722.  
  723.   iterationsBeforeReport = 4096;
  724.  
  725.  Var
  726.   offsets: Array[1..N] Of BlockO;
  727.   sizes: Array[1..N] Of Longint;
  728.  
  729.   epoch: Longint;
  730.  
  731.   aPool: QPool;
  732.   a, e, i: Longint;
  733.   aBlock: BlockO;
  734.   aBlockP: BlockP;
  735.   aStringP: StringPtr;
  736.   anEvent: EventRecord;
  737.  
  738.  Begin
  739.  ShowText;
  740.  DebugStr('You must uncomment the ChangeBlock method.');
  741.  
  742.  For a := 1 To 4 Do
  743.   randseed := randseed * TickCount * Random;
  744. {randseed := Longint(-230814419);}
  745.  Writeln('randseed = ', LongintToString(randseed));
  746.  Writeln;
  747.  
  748.  New(aPool);
  749.  aPool.Dub('The Pool We Are Testing.');
  750.  aPool.usesTemporaryMemory := true;
  751.  aPool.usualCapacity := Trunc(n * (BlockRSize + (minimumLength + maximumLength) / 2));
  752.  aPool.growthCapacity := 1000;
  753.  If Not aPool.Construct Then
  754.   Exit(QuiverTest);
  755.  
  756.  i := aPool.usedCapacity;
  757.  For a := 1 To N Do
  758.   Begin
  759.   e := MonteCarlo(MinimumLength, MaximumLength);
  760.   i := i + e + BlockRSize;
  761.   If Not aPool.AvailBlock(aBlock, e) Then
  762.    Debugger;
  763.   aBlockP := aPool.Ref(aBlock);
  764.   If aBlockP^.free Then
  765.    Debugger;
  766.   aStringP := StringPtr(Clean(aBlockP) + BlockRSize - SizeOfFreeLinks);
  767.   aStringP^ := LongintToString(Longint(e - SizeOfFreeLinks));
  768.   offsets[a] := aBlock;
  769.   sizes[a] := e;
  770.   If i <> aPool.usedCapacity Then
  771.    Nothing;
  772. {aPool.Check;}
  773.   End;
  774.  
  775.  Repeat
  776.   e := MonteCarlo(1, N);
  777.  
  778.   aBlock := offsets[e];
  779.   aBlockP := aPool.Ref(aBlock);
  780.  
  781.   If aBlock <> 0 Then
  782.    Begin
  783. {Writeln('Releasing ', LongintToString(aBlock), '.');}
  784.    aStringP := StringPtr(Clean(aBlockP) + BlockRSize - SizeOfFreeLinks);
  785.    If aStringP^ <> LongintToString(aBlockP^.length) Then
  786.     Debugger;
  787.  
  788.    aPool.ReleaseBlock(offsets[e]);
  789.    If offsets[e] <> 0 Then
  790.     Debugger;
  791.    sizes[e] := 0;
  792.    End
  793.   Else
  794.    Begin
  795.    i := MonteCarlo(MinimumLength, MaximumLength);
  796.    If Not aPool.AvailBlock(offsets[e], i) Then
  797.     If Not aPool.AvailBlock(offsets[e], i) Then
  798.      Debugger;
  799. {Writeln('Created ', LongintToString(offsets[e]), '.');}
  800.    If offsets[e] = 0 Then
  801.     Debugger;
  802.    aBlockP := aPool.Ref(offsets[e]);
  803.    aStringP := StringPtr(Clean(aBlockP) + BlockRSize - SizeOfFreeLinks);
  804.    aStringP^ := LongintToString(Longint(i - SizeOfFreeLinks));
  805.    sizes[e] := i;
  806.    End;
  807.  
  808. {aPool.Check;}
  809. {Writeln;}
  810.  
  811.   GetKeys;
  812.  
  813.   epoch := epoch + 1;
  814.   If epoch > iterationsBeforeReport Then
  815.    Begin
  816. {If Button Then}
  817.    Begin
  818.    Write('CompactingI ');
  819.    aPool.usualCapacity := aPool.usedCapacity;
  820.    aPool.Compact;
  821.    Write('Done. ');
  822.    End;
  823.  
  824.    Writeln(PercentageToString(Percentage(aPool.usedCapacity, aPool.presentCapacity)), ' used.');
  825. {aPool.Check;}
  826.    epoch := 0;
  827.  
  828.    SystemTask;
  829.    aPool.Loosen;
  830.    If WaitNextEvent(everyEvent, anEvent, 3000, Nil) Then
  831.     Nothing;
  832.    aPool.Fasten;
  833.    End;
  834.  
  835.   If epoch Mod (iterationsBeforeReport Div 4) = 0 Then
  836.    Begin
  837.    aPool.Loosen;
  838.    If WaitNextEvent(everyEvent, anEvent, 0, Nil) Then
  839.     Nothing;
  840.    aPool.Fasten;
  841.    End;
  842.  
  843.  Until SpaceKey;
  844.  
  845.  aPool.Destruct;
  846.  End;
  847.  
  848. End.
  849.