* Fix tabs

git-svn-id: trunk@135 -

.gitattributes

@@ -3544,6 +3544,7 @@ rtl/inc/mvecimp.inc svneol=native#text/plain
 rtl/inc/objects.pp svneol=native#text/plain
 rtl/inc/objpas.inc svneol=native#text/plain
 rtl/inc/objpash.inc svneol=native#text/plain
+rtl/inc/pagemem.pp svneol=native#text/plain
 rtl/inc/printer.inc svneol=native#text/plain
 rtl/inc/printerh.inc svneol=native#text/plain
 rtl/inc/readme -text

rtl/inc/pagemem.pp

@@ -0,0 +1,887 @@
+{
+    $Id: $
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 2004 by Daniel Mantione
+      member of the Free Pascal development team
+
+    Implements a memory manager that makes use of the fact that
+    a program is running in a virtual address space where pages
+    can be allocated at random, instead of a more traditional
+    growing heap.
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+unit pagemem;
+
+{*****************************************************************************}
+                                   interface
+{*****************************************************************************}
+
+{*****************************************************************************}
+                                implementation
+{*****************************************************************************}
+
+{$packrecords 1}
+{$packenum 1}
+
+type    Tpage_type=(pt_8byte_with_bitmap,pt_suballocation,pt_direct_page);
+        Ppage_type=^Tpage_type;
+
+        Pcriterium=^Tcriterium;
+        Tcriterium=record
+            criterium1,criterium2:cardinal;
+        end;
+
+        Ptree_struct=^Ttree_struct;
+        Ttree_struct=record
+            left,right:ptruint;
+        end;
+
+        {This page layout is targeted at very short strings and linked lists
+         with very low payload. It uses fixed memory sizes of 8 byte. Memory
+         overhead should be avoided at all here. An allocation bitmap does this
+         very well, only 1 bit per memory block.}
+        Ppage_8byte_with_bitmap=^Tpage_8byte_with_bitmap;
+        Tpage_8byte_with_bitmap=record
+            page_type:Tpage_type;
+            search_index:byte;
+            free_count:word;
+            page_birthyear:cardinal;
+            freelist_prev,freelist_next:Ppage_8byte_with_bitmap;
+            block_allocation_map:array[0..15] of cardinal;
+        end;
+
+        Ppage_suballocation=^Tpage_suballocation;
+        Tpage_suballocation=record
+            page_type:Tpage_type;
+            reserved:array[1..3] of byte;
+            page_birthyear:cardinal;
+        end;
+
+        {This page layout is targeted at large memory blocks. We allocate
+         pages directly from the OS for such blocks.}
+        Ppage_direct=^Tpage_direct;
+        Tpage_direct=record
+            page_type:Tpage_type;
+            reserved:array[1..3] of byte;
+            size:cardinal;
+        end;
+
+        Pfree_block=^Tfree_block;
+        Tfree_block=record
+            size:cardinal;
+            tree_sizememloc:Ttree_struct;
+            tree_memlocation:Ttree_struct;
+        end;
+
+        Tsplay_status=(ts_not_found,ts_found_on_left,
+                       ts_found_on_p,ts_found_on_right);
+
+        Psuballoc_header=^Tsuballoc_header;
+        Tsuballoc_header=record
+            alloc_size:ptruint;
+        end;
+
+const   tree_sizememloc_offset=4;
+        tree_memlocation_offset=12;
+
+        page_size=4096;
+        page_shift=12;
+        page_mask=$00000fff;
+        page_8byte_with_bitmap_maxspace=
+                       (page_size-sizeof(Tpage_8byte_with_bitmap)) div 8;
+
+        memblock_align=4;
+        memblock_alignround=memblock_align-1;
+
+        min_suballoc_size=sizeof(Tfree_block);
+
+const   freelist_8byte_with_bitmap:Ppage_8byte_with_bitmap=nil;
+        page_8byte_with_bitmap_init:Tpage_8byte_with_bitmap=
+           (
+            page_type:pt_8byte_with_bitmap;
+            search_index:0;
+            free_count:page_8byte_with_bitmap_maxspace;
+            page_birthyear:0;
+            freelist_prev:nil;
+            freelist_next:nil;
+            block_allocation_map:($ffffffff,$ffffffff,$ffffffff,$ffffffff,
+                                  $ffffffff,$ffffffff,$ffffffff,$ffffffff,
+                                  $ffffffff,$ffffffff,$ffffffff,$ffffffff,
+                                  $ffffffff,$ffffffff,$ffffffff,$ffffffff)
+           );
+
+var tree_sizememloc,tree_memlocation:Pfree_block;
+
+{****************************************************************************
+                          Page allocation/deallocation
+ ****************************************************************************} 
+
+function fpmmap(adr:pointer;len,prot,flags,fd,off:sizeint):pointer;external name 'FPC_SYSC_MMAP';
+function fpmunmap(adr:pointer;len:sizeint):pointer;external name 'FPC_SYSC_MUNMAP';
+function geterrno:longint;external name 'FPC_SYS_GETERRNO';
+
+const   PROT_READ  = $1;             { page can be read }
+        PROT_WRITE = $2;             { page can be written }
+        PROT_EXEC  = $4;             { page can be executed }
+        PROT_NONE  = $0;             { page can not be accessed }
+
+        MAP_SHARED    = $1;          { Share changes }
+        MAP_PRIVATE   = $2;          { Changes are private }
+        MAP_TYPE      = $f;          { Mask for type of mapping }
+        MAP_FIXED     = $10;         { Interpret addr exactly }
+        MAP_ANONYMOUS = $20;         { don't use a file }
+
+        MAP_GROWSDOWN  = $100;       { stack-like segment }
+        MAP_DENYWRITE  = $800;       { ETXTBSY }
+        MAP_EXECUTABLE = $1000;      { mark it as an executable }
+        MAP_LOCKED     = $2000;      { pages are locked }
+        MAP_NORESERVE  = $4000;      { don't check for reservations }
+
+function req_pages(count:cardinal):pointer;
+
+{Requests count consecutive pages from the OS.}
+
+begin
+  req_pages:=fpmmap(nil,count shl page_shift,PROT_READ or PROT_WRITE,
+                    MAP_PRIVATE or MAP_ANONYMOUS,0,0);
+  if geterrno<>0 then
+    req_pages:=nil; {This one can fail, so we can handle an out of memory
+                     situation.}
+end;
+
+procedure sack_pages(p:pointer;count:cardinal);
+
+begin
+  fpmunmap(p,count shl page_shift);
+  if geterrno<>0 then
+    runerror(204); {This one should succees.}
+end;
+
+{****************************************************************************
+                          8-bit bitmap allocated memory
+ ****************************************************************************}
+
+procedure new_page_8byte_with_bitmap;
+
+var page:Ppage_8byte_with_bitmap;
+
+begin
+  page:=req_pages(1);
+  page^:=page_8byte_with_bitmap_init;
+  page^.freelist_next:=freelist_8byte_with_bitmap;
+  page^.freelist_prev:=nil;
+  if freelist_8byte_with_bitmap<>nil then
+    freelist_8byte_with_bitmap^.freelist_prev:=page;
+  freelist_8byte_with_bitmap:=page;
+end;
+
+function pgetmem_8byte_with_bitmap:pointer;
+
+var page:Ppage_8byte_with_bitmap;
+    bit:cardinal;
+
+begin
+  if freelist_8byte_with_bitmap=nil then
+    new_page_8byte_with_bitmap;
+  page:=freelist_8byte_with_bitmap;
+  with page^ do
+    begin
+      {Search a dword in which a bit is set.}
+      while block_allocation_map[search_index]=0 do
+        search_index:=(search_index+1) and 15;
+      ptrint(pgetmem_8byte_with_bitmap):=ptrint(page)+sizeof(page^)+search_index*256;
+      {Search for a set bit in the dword.}
+      bit:=1;
+      while block_allocation_map[search_index] and bit=0 do
+        begin
+          bit:=bit shl 1;
+          inc(ptrint(pgetmem_8byte_with_bitmap),8);
+        end;
+      {Allocate the block.}
+      block_allocation_map[search_index]:=block_allocation_map[search_index] and not bit;
+      dec(free_count);
+      if free_count=0 then
+        begin
+          {There is no space left in this page. Remove it from the freelist.}
+          if freelist_next<>nil then
+            freelist_next^.freelist_prev:=freelist_prev;
+          if freelist_prev<>nil then
+            freelist_prev^.freelist_next:=freelist_next;
+          if freelist_8byte_with_bitmap=page then
+            freelist_8byte_with_bitmap:=freelist_next;
+          freelist_prev:=nil;
+          freelist_next:=nil;
+        end;
+    end;
+end;
+
+
+function pfreemem_8byte_with_bitmap(page:Ppage_8byte_with_bitmap;p:pointer):ptrint;
+
+var index,bit:cardinal;
+
+begin
+  index:=(ptrint(p)-ptrint(page)-sizeof(page^)) div 8;
+  bit:=index and 31;
+  index:=index shr 5;
+  with page^ do
+    begin
+      if free_count=0 then
+        begin
+          {Page will get free slots. Must be included in freelist.}
+          if freelist_8byte_with_bitmap=nil then
+            freelist_8byte_with_bitmap:=page
+          else
+            begin
+              freelist_next:=freelist_8byte_with_bitmap;
+              freelist_8byte_with_bitmap^.freelist_prev:=page;
+              freelist_8byte_with_bitmap:=page;
+            end;
+          {Make sure the next allocation finds the slot without much searching.} 
+          search_index:=index;
+        end;
+      block_allocation_map[index]:=block_allocation_map[index] or (1 shl bit);
+      inc(free_count);
+      if free_count=page_8byte_with_bitmap_maxspace then
+        begin
+          {The page is completely free. It can be returned to the OS, but
+           remove it from the freelist first.}
+          if freelist_next<>nil then
+            freelist_next^.freelist_prev:=freelist_prev;
+          if freelist_prev<>nil then
+            freelist_prev^.freelist_next:=freelist_next;
+          if freelist_8byte_with_bitmap=page then
+            freelist_8byte_with_bitmap:=freelist_next;
+          sack_pages(page,1);
+        end;
+    end;
+  pfreemem_8byte_with_bitmap:=8;
+end;
+
+{****************************************************************************
+                                 Splay tree stuff
+ ****************************************************************************}
+
+{ $define debug}
+{$ifdef debug}
+procedure write_sizememloc_tree(tree:Pfree_block;level:cardinal);
+
+var i:cardinal;
+
+begin
+    if tree=nil then
+      exit;
+    write_sizememloc_tree(Pfree_block(tree^.tree_sizememloc.left),level+1);
+    for i:=1 to level do
+      write('  ');
+    writeln(tree^.size,' ',hexstr(ptruint(tree),8));
+    write_sizememloc_tree(Pfree_block(tree^.tree_sizememloc.right),level+1);
+end;
+
+procedure write_memlocation_tree(tree:Pfree_block;level:cardinal);
+
+var i:cardinal;
+
+begin
+    if tree=nil then
+      exit;
+    write_memlocation_tree(Pfree_block(tree^.tree_memlocation.left),level+1);
+    for i:=1 to level do
+      write('  ');
+    writeln(hexstr(ptruint(tree),8));
+    write_memlocation_tree(Pfree_block(tree^.tree_memlocation.right),level+1);
+end;
+{$endif}
+
+procedure rotate_l(var p:ptruint;offset:cardinal);
+
+var p1:ptruint;
+
+begin
+    p1:=Ptree_struct(p+offset)^.right;
+    Ptree_struct(p+offset)^.right:=Ptree_struct(p1+offset)^.left;
+    Ptree_struct(p1+offset)^.left:=p;
+    p:=p1;
+end;
+
+procedure rotate_r(var p:ptruint;offset:cardinal);
+
+var p1:ptruint;
+
+begin
+    p1:=Ptree_struct(p+offset)^.left;
+    Ptree_struct(p+offset)^.left:=Ptree_struct(p1+offset)^.right;
+    Ptree_struct(p1+offset)^.right:=p;
+    p:=p1;
+end;
+
+procedure zigzig(var p:ptruint;offset:cardinal);inline;
+
+begin
+    rotate_r(p,offset);
+    rotate_r(p,offset);
+end;
+
+procedure zigzag(var p:ptruint;offset:cardinal);inline;
+
+begin
+    rotate_l(Ptree_struct(p+offset)^.left,offset);
+    rotate_r(p,offset);
+end;
+
+procedure zagzig(var p:ptruint;offset:cardinal);inline;
+
+begin
+    rotate_r(Ptree_struct(p+offset)^.right,offset);
+    rotate_l(p,offset);
+end;
+
+procedure zagzag(var p:ptruint;offset:cardinal);inline;
+
+begin
+    rotate_l(p,offset);
+    rotate_l(p,offset);
+end;
+
+procedure delete_from_tree(var p:ptruint;offset:cardinal);
+
+var p1:ptruint;
+    pp1:^ptruint;
+
+begin
+  if Ptree_struct(p+offset)^.left=0 then
+    p:=Ptree_struct(p+offset)^.right
+  else
+    begin
+      if Ptree_struct(p+offset)^.right<>0 then
+        begin
+          {Both are occupied. Move right to rightmost leaf of left.}
+          p1:=Ptree_struct(p+offset)^.left;
+          repeat
+            pp1:=@Ptree_struct(p1+offset)^.right;
+            p1:=pp1^;
+          until p1=0;
+          pp1^:=Ptree_struct(p+offset)^.right;
+        end;
+      p:=Ptree_struct(p+offset)^.left;
+    end;
+end;
+
+function find_sizememloc(size:ptruint;var p:Pfree_block):Tsplay_status;
+
+begin
+  find_sizememloc:=ts_found_on_p;
+  if p=nil then
+    find_sizememloc:=ts_not_found
+  else if size<p^.size then {Do nothing if equal...}
+    case find_sizememloc(size,Pfree_block(p^.tree_sizememloc.left)) of
+      ts_not_found:
+        if p^.size<size then
+          find_sizememloc:=ts_not_found;
+      ts_found_on_left:
+        zigzig(ptruint(p),tree_sizememloc_offset);
+      ts_found_on_p:
+        find_sizememloc:=ts_found_on_left;
+      ts_found_on_right:
+        zigzag(ptruint(p),tree_sizememloc_offset);
+    end
+  else if size>p^.size then
+    case find_sizememloc(size,Pfree_block(p^.tree_sizememloc.right)) of
+      ts_not_found:
+        if p^.size<size then
+          find_sizememloc:=ts_not_found;
+      ts_found_on_left:
+        zagzig(ptruint(p),tree_sizememloc_offset);
+      ts_found_on_p:
+        find_sizememloc:=ts_found_on_right;
+      ts_found_on_right:
+        zagzag(ptruint(p),tree_sizememloc_offset);
+    end;
+end;
+
+{$if 0}
+function find_sizememloc(size,loc:ptruint;var p:Pfree_block):Tsplay_status;
+
+var on_left:boolean;
+
+begin
+  find_sizememloc:=ts_found_on_p;
+  if p=nil then
+    find_sizememloc:=ts_not_found
+  else
+    begin
+      on_left:=size<p^.size;
+      if size=p^.size then
+        if loc=ptruint(p) then
+          exit
+        else
+          on_left:=loc<ptruint(p);
+      if on_left then
+        case find_sizememloc(size,loc,Pfree_block(p^.tree_sizememloc.left)) of
+          ts_not_found:
+            find_sizememloc:=ts_not_found;
+          ts_found_on_left:
+            zigzig(ptruint(p),tree_sizememloc_offset);
+          ts_found_on_p:
+            find_sizememloc:=ts_found_on_left;
+          ts_found_on_right:
+            zigzag(ptruint(p),tree_sizememloc_offset);
+        end
+      else
+        case find_sizememloc(size,loc,Pfree_block(p^.tree_sizememloc.right)) of
+          ts_not_found:
+            find_sizememloc:=ts_not_found;
+          ts_found_on_left:
+            zagzig(ptruint(p),tree_sizememloc_offset);
+          ts_found_on_p:
+            find_sizememloc:=ts_found_on_right;
+          ts_found_on_right:
+            zagzag(ptruint(p),tree_sizememloc_offset);
+        end;
+    end;
+end;
+{$endif}
+
+function insert_sizememloc(node:Pfree_block;var p:Pfree_block):Tsplay_status;
+
+{Preconditions:
+
+ node^.size is set
+ node^.tree_sizememloc.left is set to nil
+ node^.tree_sizememloc.right is set to nil}
+
+var on_left:boolean;
+
+begin
+  insert_sizememloc:=ts_found_on_p;
+  if p=nil then
+    p:=node
+  else
+    begin
+      on_left:=node^.size<p^.size;
+      if node^.size=p^.size then
+        on_left:=ptruint(node)<ptruint(p);
+      if on_left then
+        case insert_sizememloc(node,Pfree_block(p^.tree_sizememloc.left)) of
+          ts_found_on_left:
+            zigzig(ptruint(p),tree_sizememloc_offset);
+          ts_found_on_p:
+            insert_sizememloc:=ts_found_on_left;
+          ts_found_on_right:
+            zigzag(ptruint(p),tree_sizememloc_offset);
+        end
+      else
+        case insert_sizememloc(node,Pfree_block(p^.tree_sizememloc.right)) of
+          ts_found_on_left:
+            zagzig(ptruint(p),tree_sizememloc_offset);
+          ts_found_on_p:
+            insert_sizememloc:=ts_found_on_right;
+          ts_found_on_right:
+            zagzag(ptruint(p),tree_sizememloc_offset);
+        end;
+    end;
+{$ifdef debug}
+  writeln('sizememlocboom na insert');
+  write_sizememloc_tree(tree_sizememloc,1);
+{$endif}
+end;
+
+{$if 0}
+function find_memlocation(location:ptruint;var p:Pfree_block;
+                          find_smaller:boolean):Tsplay_status;
+
+begin
+  find_memlocation:=ts_found_on_p;
+  if p=nil then
+    find_memlocation:=ts_not_found
+  else if location<ptruint(p) then {Do nothing if equal...}
+    case find_memlocation(location,Pfree_block(p^.tree_memlocation.left),
+                          find_smaller) of
+      ts_not_found:
+        if (ptruint(p)>location) or not find_smaller then
+          find_memlocation:=ts_not_found;
+      ts_found_on_left:
+        zigzig(ptruint(p),tree_memlocation_offset);
+      ts_found_on_p:
+        find_memlocation:=ts_found_on_left;
+      ts_found_on_right:
+        zigzag(ptruint(p),tree_memlocation_offset);
+    end
+  else if location>ptruint(p) then
+    case find_memlocation(location,Pfree_block(p^.tree_memlocation.right),
+                          find_smaller) of
+      ts_not_found:
+        if (ptruint(p)>location) or not find_smaller then
+          find_memlocation:=ts_not_found;
+      ts_found_on_left:
+        zagzig(ptruint(p),tree_memlocation_offset);
+      ts_found_on_p:
+        find_memlocation:=ts_found_on_right;
+      ts_found_on_right:
+        zagzag(ptruint(p),tree_memlocation_offset);
+    end;
+end;
+{$endif}
+
+function insert_memlocation(node:Pfree_block;var p:Pfree_block):Tsplay_status;
+
+{Preconditions:
+
+ node^.size is set
+ node^.tree_sizememloc.left is set to nil
+ node^.tree_sizememloc.right is set to nil}
+
+begin
+  insert_memlocation:=ts_found_on_p;
+  if p=nil then
+    p:=node
+  else if ptruint(node)<=ptruint(p) then {Equal? Insert on left.}
+    case insert_memlocation(node,Pfree_block(p^.tree_memlocation.left)) of
+      ts_found_on_left:
+        zigzig(ptruint(p),tree_memlocation_offset);
+      ts_found_on_p:
+        insert_memlocation:=ts_found_on_left;
+      ts_found_on_right:        zigzag(ptruint(p),tree_memlocation_offset);
+    end
+  else if ptruint(node)>ptruint(p) then
+    case insert_memlocation(node,Pfree_block(p^.tree_memlocation.right)) of
+      ts_found_on_left:
+        zagzig(ptruint(p),tree_memlocation_offset);
+      ts_found_on_p:
+        insert_memlocation:=ts_found_on_right;
+      ts_found_on_right:
+        zagzag(ptruint(p),tree_memlocation_offset);
+    end;
+{$ifdef debug}
+    writeln('memlocationboom na insert');
+    write_memlocation_tree(tree_memlocation,1);
+{$endif}
+end;
+
+function get_memlocation(node:Pfree_block):Pfree_block;
+
+{Iteratively delete node from tree without splaying.}
+
+var p:^Pfree_block;
+
+begin
+  p:=@tree_memlocation;
+  while (p^<>nil) and (p^<>node) do
+    if ptruint(node)<ptruint(p^) then
+      p:=@p^^.tree_memlocation.left
+    else
+      p:=@p^^.tree_memlocation.right;
+  get_memlocation:=p^;
+  if p^<>nil then
+    delete_from_tree(ptruint(p^),tree_memlocation_offset);
+end;
+
+function get_sizememloc(node:Pfree_block):Pfree_block;
+
+{Iteratively delete node from tree without splaying.}
+
+var p:^Pfree_block;
+    on_left:boolean;
+
+begin
+  p:=@tree_sizememloc;
+  while (p^<>nil) and (p^<>node) do
+    begin
+      on_left:=node^.size<p^^.size;
+      if node^.size=p^^.size then
+        on_left:=ptruint(node)<ptruint(p^);
+      if on_left then
+        p:=@p^^.tree_sizememloc.left
+      else
+        p:=@p^^.tree_sizememloc.right;
+    end;
+  get_sizememloc:=p^;
+  if p^<>nil then
+    delete_from_tree(ptruint(p^),tree_sizememloc_offset);
+end;
+
+function get_block_by_size(size:cardinal):Pfree_block;
+
+var what:^ptruint;
+
+begin
+  case find_sizememloc(size,tree_sizememloc) of
+    ts_not_found:
+      begin
+        get_block_by_size:=nil;
+        exit;
+      end;
+    ts_found_on_left:
+      what:=@tree_sizememloc^.tree_sizememloc.left;
+    ts_found_on_p:
+      what:=@tree_sizememloc;
+    ts_found_on_right:
+      what:=@tree_sizememloc^.tree_sizememloc.right;
+  end;
+  get_block_by_size:=Pfree_block(what^);
+  delete_from_tree(what^,tree_sizememloc_offset);
+  if get_memlocation(get_block_by_size)=nil then
+    runerror(204);
+end;
+
+function get_block_by_memlocation(location:ptruint):Pfree_block;
+
+var what:^ptruint;
+
+begin
+  get_block_by_memlocation:=get_memlocation(Pfree_block(location));
+  if get_block_by_memlocation<>nil then
+    begin
+      get_sizememloc(get_block_by_memlocation);
+{      case find_sizememloc(get_block_by_memlocation^.size,
+                           ptruint(get_block_by_memlocation),tree_sizememloc) of
+        ts_not_found:
+          runerror(204);
+        ts_found_on_left:
+          what:=@tree_sizememloc^.tree_sizememloc.left;
+        ts_found_on_p:
+          what:=@tree_sizememloc;
+        ts_found_on_right:
+          what:=@tree_sizememloc^.tree_sizememloc.right;
+      end;
+      delete_from_tree(what^,tree_sizememloc_offset);}
+    end;
+end;
+
+function get_smaller_neighbour(location:ptruint):Pfree_block;
+
+var p,what:^ptruint;
+
+begin
+  {Find a smaller block. Don't splay as it will be deleted.}
+  p:=@tree_memlocation;
+  what:=nil;
+  while (p^<>0) do
+    if location<=p^ then
+      p:=@Pfree_block(p^)^.tree_memlocation.left
+    else
+      begin
+        what:=p;
+        p:=@Pfree_block(p^)^.tree_memlocation.right;
+      end;
+  if (what=nil) or (ptruint(what^)+Pfree_block(what^)^.size<>location) then
+    begin
+      get_smaller_neighbour:=nil;
+      exit;
+    end;
+  get_smaller_neighbour:=Pfree_block(what^);
+  delete_from_tree(ptruint(what^),tree_memlocation_offset);
+  get_sizememloc(get_smaller_neighbour);
+end;
+
+{function pgetmem_directpage(memsize:ptrint):pointer;
+
+var npages:ptrint;
+
+begin
+  npages:=(memsize+sizeof(Tpage_direct)+page_size-1) div page_size;
+  pgetmem_directpage:=req_pages(npages);
+  with Ppage_direct(pgetmem_directpage)^ do
+    begin
+      page_type:=pt_direct_page;
+      size:=memsize;
+    end;
+end;
+}
+
+function pgetmem_suballocpage(memsize:ptrint):pointer;
+
+var free_block:Pfree_block;
+    page:pointer;
+    needsize,remaining,block_start:ptruint;
+
+begin
+{$ifdef debug}
+  writeln('-------Getmem------- ',memsize);
+{$endif}
+  {Constant parts on left because of constant evaluation.}
+  needsize:=(sizeof(Tsuballoc_header)+memblock_alignround+memsize) and not memblock_alignround;
+  if needsize<min_suballoc_size then
+    needsize:=min_suballoc_size;
+{$ifdef debug}
+  writeln('sizememlocboom voor get:');
+  write_sizememloc_tree(tree_sizememloc,2);
+{$endif}
+  free_block:=get_block_by_size(needsize);
+  if free_block=nil then
+    begin
+      page:=req_pages(1);
+      Ppage_suballocation(page)^.page_type:=pt_suballocation;
+      {Allocate at the end of the page, a free block at the start.}
+      free_block:=Pfree_block(ptruint(page)+sizeof(Tpage_suballocation));
+      remaining:=page_size-needsize-sizeof(Tpage_suballocation);
+      block_start:=ptruint(page)+page_size-needsize;
+      Psuballoc_header(block_start)^.alloc_size:=needsize;
+      pgetmem_suballocpage:=pointer(block_start+sizeof(Tsuballoc_header));
+    end
+  else
+    begin
+      block_start:=ptruint(free_block);
+      remaining:=free_block^.size-needsize;
+      if (remaining<min_suballoc_size) then
+        begin
+          needsize:=free_block^.size;
+          free_block:=nil;
+        end
+      else
+        inc(ptruint(free_block),needsize);
+      Psuballoc_header(block_start)^.alloc_size:=needsize;
+      pgetmem_suballocpage:=pointer(block_start+sizeof(Tsuballoc_header));
+    end;
+  if free_block<>nil then
+    begin
+      with free_block^ do
+        begin
+          size:=remaining;
+          tree_sizememloc.left:=0;
+          tree_sizememloc.right:=0;
+          tree_memlocation.left:=0;
+          tree_memlocation.right:=0;
+        end;
+      insert_sizememloc(free_block,tree_sizememloc);
+      insert_memlocation(free_block,tree_memlocation);
+    end;
+end;
+
+function pfreemem_suballoc_page(page:Ppage_direct;p:pointer):ptrint;
+
+var free_block,neighbour:Pfree_block;
+    headerp:Psuballoc_header;
+    asize:ptruint;
+
+begin
+{$Ifdef debug}
+  write('-------Freemem------- ');
+{$endif}
+  headerp:=Psuballoc_header(ptrint(p)-sizeof(Tsuballoc_header));
+  asize:=headerp^.alloc_size;
+{$ifdef debug}
+  writeln(hexstr(ptruint(page),8),' ',asize);
+{$endif}
+  free_block:=Pfree_block(headerp);
+  {Search neighbour to coalesce with above block.}
+  neighbour:=get_block_by_memlocation(ptruint(free_block)+asize);
+  if neighbour<>nil then
+    inc(asize,neighbour^.size);
+  {Search neighbour to coalesce with below block.}
+  neighbour:=get_smaller_neighbour(ptruint(free_block));
+  if neighbour<>nil then
+    begin
+      inc(asize,neighbour^.size);
+      free_block:=neighbour;
+    end;
+  {Page empty??}
+  if (ptruint(free_block) and page_mask=sizeof(Tpage_suballocation)) and
+     (asize=page_size-sizeof(Tpage_suballocation)) then
+    sack_pages(pointer(ptruint(free_block) and not page_mask),1)
+  else
+    begin
+      with free_block^ do
+        begin
+          size:=asize;
+          tree_sizememloc.left:=0;
+          tree_sizememloc.right:=0;
+          tree_memlocation.left:=0;
+          tree_memlocation.right:=0;
+        end;
+      insert_sizememloc(free_block,tree_sizememloc);
+      insert_memlocation(free_block,tree_memlocation);
+    end;
+end;
+
+function pgetmem(size:ptrint):pointer;
+
+begin
+  if size<=8 then
+    pgetmem:=pgetmem_8byte_with_bitmap
+  else
+    pgetmem:=pgetmem_suballocpage(size);
+end;
+
+function pallocmem(size:ptrint):pointer;
+
+begin
+  if size<=8 then
+    begin
+      pallocmem:=pgetmem_8byte_with_bitmap;
+      fillchar(Pbyte(pallocmem)^,8,0);
+    end
+  else
+    {Freshly allocated pages are allways already cleared.}
+{    pgallocmem:=pgallocmem_directpage(size)};
+end;
+
+
+function pfreemem(p:pointer):ptrint;
+
+var page:pointer;
+
+begin
+  page:=pointer(ptrint(p) and not page_mask);
+  case Ppage_type(page)^ of
+    pt_8byte_with_bitmap:
+      pfreemem:=pfreemem_8byte_with_bitmap(page,p);
+    pt_suballocation:
+      pfreemem:=pfreemem_suballoc_page(page,p);
+  else
+    runerror(204);
+  end;
+end;
+
+function pfreememsize(p:pointer;size:ptrint):ptrint;
+
+begin
+{  runerror(204);}
+  pfreemem(p);
+end;
+
+function preallocmem(var p:pointer;size:ptrint):pointer;
+
+begin
+  runerror(204);
+end;
+
+function pmemsize(p:pointer):ptrint;
+
+begin
+  runerror(204);
+end;
+
+const page_memory_manager:Tmemorymanager=
+    (
+      needlock:false;
+      getmem:@pgetmem;
+      freemem:@pfreemem;
+      freememsize:@pfreememsize;
+      allocmem:@pallocmem;
+      reallocmem:@preallocmem;
+      memsize:@pmemsize;
+{      memavail:@pmemavail;}
+{      maxavail:@pmaxavail;}
+{      heapsize:@pheapsize;}
+    );
+
+var oldmemman:Tmemorymanager;
+
+initialization
+  getmemorymanager(oldmemman);
+  setmemorymanager(page_memory_manager);
+finalization
+  setmemorymanager(oldmemman);
+end.
+
+{
+ $Log: $
+}