* best match for main freelist

  * removed root field, saves 4 bytes per block
  * fixed crash in dumpblocks

rtl/inc/heap.inc

@@ -23,17 +23,23 @@
 { Allocate small blocks at heapptr instead of walking the freelist }
 {$define SMALLATHEAPPTR}
 
-{ Dump info when the heap needs to grow }
+{ Try to find the best matching block in general freelist }
+{$define BESTMATCH}
+
+{ DEBUG: Dump info when the heap needs to grow }
 { define DUMPGROW}
 
 { Default heap settings }
 const
   blocksize    = 16;  { at least size of freerecord }
   blockshr     = 4;   { shr value for blocksize=2^blockshr}
-  maxblocksize = 1024+blocksize; { 1024+8 needed for heaprecord }
+  maxblocksize = 512+blocksize; { 1024+8 needed for heaprecord }
   maxblock     = maxblocksize div blocksize;
   maxreusebigger = 8; { max reuse bigger tries }
 
+  usedmask = $80000000;
+  sizemask = not usedmask;
+
 {****************************************************************************}
 
 {$ifdef DUMPGROW}
@@ -54,17 +60,15 @@ type
   pfreerecord  = ^tfreerecord;
   tfreerecord  = record
     size  : longint;
-    root  : ppfreerecord;
     next,
     prev  : pfreerecord;
-  end; { 16 bytes }
+  end; { 12 bytes }
 
   pheaprecord = ^theaprecord;
   theaprecord = record
   { this should overlap with tfreerecord }
     size  : longint;
-    root  : ppfreerecord;
-  end; { 8 bytes }
+  end; { 4 bytes }
 
   tfreelists   = array[0..maxblock] of pfreerecord;
   pfreelists   = ^tfreelists;
@@ -73,7 +77,6 @@ var
   internal_memavail  : longint;
   internal_heapsize  : longint;
   freelists          : tfreelists;
-  checkfreememsize   : boolean;
 
 {*****************************************************************************
                              Memory Manager
@@ -172,8 +175,8 @@ begin
      j:=0;
      while assigned(hp) do
       begin
-        hp:=hp^.next;
         inc(j);
+        hp:=hp^.next;
       end;
      writeln('Block ',i*blocksize,': ',j);
    end;
@@ -183,10 +186,10 @@ begin
   s:=0;
   while assigned(hp) do
    begin
-     hp:=hp^.next;
      inc(j);
      if hp^.size>s then
       s:=hp^.size;
+     hp:=hp^.next;
    end;
   writeln('Main: ',j,' maxsize: ',s);
 end;
@@ -204,9 +207,11 @@ var
   proc  : heaperrorproc;
   pcurr : pfreerecord;
   again : boolean;
-  heapfree,
   s,s1,i,
   sizeleft : longint;
+{$ifdef BESTMATCH}
+  pbest : pfreerecord;
+{$endif}
 begin
 { Something to allocate ? }
   if size<=0 then
@@ -222,114 +227,143 @@ begin
   size:=(size+sizeof(theaprecord)+(blocksize-1)) and (not (blocksize-1));
   dec(internal_memavail,size);
 { try to find a block in one of the freelists per size }
-  pcurr:=nil;
   s:=size shr blockshr;
   if s<=maxblock then
    begin
+     pcurr:=freelists[s];
      { correct size match ? }
-     if assigned(freelists[s]) then
+     if assigned(pcurr) then
       begin
         { create the block we should return }
-        p:=pointer(freelists[s])+sizeof(theaprecord);
+        p:=pointer(pcurr)+sizeof(theaprecord);
+        { fix size }
+        pcurr^.size:=pcurr^.size or usedmask;
         { update freelist }
-        freelists[s]:=freelists[s]^.next;
+        freelists[s]:=pcurr^.next;
         if assigned(freelists[s]) then
          freelists[s]^.prev:=nil;
         exit;
       end;
+{$ifdef SMALLATHEAPPTR}
+     if heapend-heapptr>size then
+      begin
+        p:=heapptr;
+        pheaprecord(p)^.size:=size;
+        inc(p,sizeof(theaprecord));
+        inc(heapptr,size);
+        exit;
+      end;
+{$endif}
 {$ifdef REUSEBIGGER}
      { try a bigger block }
      s1:=s+s;
      i:=0;
      while (s1<=maxblock) and (i<maxreusebigger) do
       begin
-        if assigned(freelists[s1]) then
+        pcurr:=freelists[s1];
+        if assigned(pcurr) then
          begin
-           pcurr:=freelists[s1];
+           s:=s1;
            break;
          end;
-        inc(s1,s);
+        inc(s1);
         inc(i);
       end;
 {$endif}
    end
   else
-   s:=0;
+   pcurr:=nil;
+{ not found, then check the main freelist for the first match }
+  if not(assigned(pcurr)) then
+   begin
+     s:=0;
+{$ifdef BESTMATCH}
+     pbest:=nil;
+{$endif}
+     pcurr:=freelists[0];
+     while assigned(pcurr) do
+      begin
+{$ifdef BESTMATCH}
+        if pcurr^.size=size then
+         break
+        else
+         begin
+           if (pcurr^.size>size) then
+            begin
+              if (not assigned(pbest)) or
+                 (pcurr^.size<pbest^.size) then
+               pbest:=pcurr;
+            end;
+         end;
+{$else}
+        if pcurr^.size>=size then
+         break;
+{$endif}
+        pcurr:=pcurr^.next;
+      end;
+{$ifdef BESTMATCH}
+     if not assigned(pcurr) then
+      pcurr:=pbest;
+{$endif}
+   end;
+  { have we found a block, then get it and free up the other left part,
+    if no blocks are found then allocated at the heapptr or grow the heap }
+  if assigned(pcurr) then
+   begin
+     { get pointer of the block we should return }
+     p:=pointer(pcurr);
+     { remove the current block from the freelist }
+     if assigned(pcurr^.next) then
+      pcurr^.next^.prev:=pcurr^.prev;
+     if assigned(pcurr^.prev) then
+      pcurr^.prev^.next:=pcurr^.next
+     else
+      freelists[s]:=pcurr^.next;
+     { create the left over freelist block, if at least 16 bytes are free }
+     sizeleft:=pcurr^.size-size;
+     if sizeleft>sizeof(tfreerecord) then
+      begin
+        pcurr:=pfreerecord(pointer(pcurr)+size);
+        pcurr^.size:=sizeleft;
+        { insert the block in the freelist }
+        pcurr^.prev:=nil;
+        s1:=sizeleft shr blockshr;
+        if s1>maxblock then
+         s1:=0;
+        pcurr^.next:=freelists[s1];
+        if assigned(freelists[s1]) then
+         freelists[s1]^.prev:=pcurr;
+        freelists[s1]:=pcurr;
+      end;
+     { create the block we need to return }
+     pheaprecord(p)^.size:=size;
+     inc(p,sizeof(theaprecord));
+     exit;
+   end;
+  { Lastly, the top of the heap is checked, to see if there is }
+  { still memory available.                                   }
   repeat
-    { not found, then check the main freelist for the first match }
-    heapfree:=heapend-heapptr;
-    if not(assigned(pcurr)) and
-       ((size>maxblocksize) or (heapfree<size)) then
-     begin
-       pcurr:=freelists[0];
-       while assigned(pcurr) do
-        begin
-          if pcurr^.size>=size then
-           break;
-          pcurr:=pcurr^.next;
-        end;
-     end;
-    { have we found a block, then get it and free up the other left part,
-      if no blocks are found then allocated at the heapptr or grow the heap }
-    if assigned(pcurr) then
+    again:=false;
+    if heapend-heapptr>size then
      begin
-       { get pointer of the block we should return }
-       p:=pointer(pcurr);
-       { remove the current block from the freelist }
-       if assigned(pcurr^.next) then
-        pcurr^.next^.prev:=pcurr^.prev;
-       if assigned(pcurr^.prev) then
-        pcurr^.prev^.next:=pcurr^.next
-       else
-        pcurr^.root^:=pcurr^.next;
-       { create the left over freelist block, if at least 16 bytes are free }
-       sizeleft:=pcurr^.size-size;
-       s1:=sizeleft shr blockshr;
-       if s1>0 then
-        begin
-          if s1>maxblock then
-           s1:=0;
-          pcurr:=pfreerecord(pointer(pcurr)+size);
-          pcurr^.size:=sizeleft;
-          pcurr^.root:=@freelists[s1];
-          { insert the block in the freelist }
-          pcurr^.next:=freelists[s1];
-          pcurr^.prev:=nil;
-          if assigned(freelists[s1]) then
-           freelists[s1]^.prev:=pcurr;
-          freelists[s1]:=pcurr;
-        end;
-       { create the block we need to return }
+       p:=heapptr;
        pheaprecord(p)^.size:=size;
-       pheaprecord(p)^.root:=@freelists[s];
        inc(p,sizeof(theaprecord));
+       inc(heapptr,size);
        exit;
      end;
-    { Lastly, the top of the heap is checked, to see if there is }
-    { still memory available.                                   }
-    again:=false;
-    if heapfree<size then
+    { Call the heaperror proc }
+    if assigned(heaperror) then
      begin
-       if assigned(heaperror) then
-        begin
-          proc:=heaperrorproc(heaperror);
-          case proc(size) of
-           0 : HandleError(203);
-           1 : p:=nil;
-           2 : again:=true;
-          end;
-        end
-       else
-        HandleError(203);
+       proc:=heaperrorproc(heaperror);
+       case proc(size) of
+        0 : HandleError(203);
+        1 : p:=nil;
+        2 : again:=true;
+       end;
      end
     else
-     begin
-       p:=heapptr;
-       pheaprecord(p)^.size:=size;
-       pheaprecord(p)^.root:=@freelists[s];
-       inc(p,sizeof(theaprecord));
-       inc(heapptr,size);
-     end;
+     HandleError(203);
   until not again;
 end;
 
@@ -339,23 +373,33 @@ end;
 *****************************************************************************}
 
 procedure SysFreeMem(var p : pointer);
+var
+  s : longint;
+  pcurr : pfreerecord;
 begin
   if p=nil then
    HandleError(204);
 { fix p to point to the heaprecord }
-  dec(p,sizeof(theaprecord));
-  inc(internal_memavail,pheaprecord(p)^.size);
+  pcurr:=pfreerecord(pointer(p)-sizeof(theaprecord));
+  pcurr^.size:=pcurr^.size and sizemask;
+  inc(internal_memavail,pcurr^.size);
 { insert the block in it's freelist }
-  pfreerecord(p)^.prev:=nil;
-  pfreerecord(p)^.next:=pfreerecord(p)^.root^;
-  if assigned(pfreerecord(p)^.next) then
-   pfreerecord(p)^.next^.prev:=pfreerecord(p);
-  pfreerecord(p)^.root^:=pfreerecord(p);
+  pcurr^.prev:=nil;
+  s:=pcurr^.size shr blockshr;
+  if s>maxblock then
+   s:=0;
+  pcurr^.next:=freelists[s];
+  if assigned(pcurr^.next) then
+   pcurr^.next^.prev:=pcurr;
+  freelists[s]:=pcurr;
   p:=nil;
 end;
 
 
 procedure SysFreeMemSize(var p : pointer;size : longint);
+var
+  s : longint;
+  pcurr : pfreerecord;
 begin
   if size<=0 then
    begin
@@ -367,21 +411,22 @@ begin
   if p=nil then
    HandleError(204);
 { fix p to point to the heaprecord }
-  dec(p,sizeof(theaprecord));
-  inc(internal_memavail,pheaprecord(p)^.size);
+  pcurr:=pfreerecord(pointer(p)-sizeof(theaprecord));
+  pcurr^.size:=pcurr^.size and sizemask;
+  inc(internal_memavail,pcurr^.size);
 { size check }
-  if checkfreememsize and (size<>-1) then
-   begin
-     size:=(size+sizeof(theaprecord)+(blocksize-1)) and (not (blocksize-1));
-     if size<>pheaprecord(p)^.size then
-      HandleError(204);
-   end;
+  size:=(size+sizeof(theaprecord)+(blocksize-1)) and (not (blocksize-1));
+  if size<>pcurr^.size then
+   HandleError(204);
 { insert the block in it's freelist }
-  pfreerecord(p)^.prev:=nil;
-  pfreerecord(p)^.next:=pfreerecord(p)^.root^;
-  if assigned(pfreerecord(p)^.next) then
-   pfreerecord(p)^.next^.prev:=pfreerecord(p);
-  pfreerecord(p)^.root^:=pfreerecord(p);
+  pcurr^.prev:=nil;
+  s:=pcurr^.size shr blockshr;
+  if s>maxblock then
+   s:=0;
+  pcurr^.next:=freelists[s];
+  if assigned(pcurr^.next) then
+   pcurr^.next^.prev:=pcurr;
+  freelists[s]:=pcurr;
   p:=nil;
 end;
 
@@ -416,6 +461,7 @@ end;
 
 function growheap(size :longint) : integer;
 var
+  sizeleft,
   NewPos,
   wantedsize : longint;
   pcurr      : pfreerecord;
@@ -463,11 +509,11 @@ begin
   else
    begin
      { create freelist entry for old heapptr-heapend }
-     if heapend-heapptr>blocksize then
+     sizeleft:=heapend-heapptr;
+     if sizeleft>sizeof(tfreerecord) then
       begin
         pcurr:=pfreerecord(heapptr);
-        pcurr^.size:=heapend-heapptr;
-        pcurr^.root:=@freelists[0];
+        pcurr^.size:=sizeleft;
         { insert the block in the freelist }
         pcurr^.next:=freelists[0];
         pcurr^.prev:=nil;
@@ -506,7 +552,12 @@ end;
 
 {
   $Log$
-  Revision 1.17  1999-09-20 14:17:37  peter
+  Revision 1.18  1999-09-22 21:59:02  peter
+    * best match for main freelist
+    * removed root field, saves 4 bytes per block
+    * fixed crash in dumpblocks
+
+  Revision 1.17  1999/09/20 14:17:37  peter
     * fixed growheap freelist addition when heapend-heapptr<blocksize
 
   Revision 1.16  1999/09/17 17:14:12  peter