The DWin Graphical User Interface Code

432 lines (395 with data), 9.3 kB

unit memmgr;

interface

function dGetMem(size: integer): pointer;
function dFreeMem(p: pointer): integer;
function dReallocMem(p: pointer; size: integer): pointer;
procedure dBalance;
procedure dPtree;

procedure p;

var alloc: cardinal;

implementation

uses Libc, util;

const minSize = 32;
const hashSize = 32;

type
  block = ^rblock;
  rblock = record
    size: cardinal;
    ptr: pointer;
    lhs: block;
    rhs: block;
    free: boolean;
  end;
  //blockFind = ^rblockFind;
  blockFind = record
    c, prev: block;
  end;


var heap, base: pointer;
  memSize: cardinal;
  oldMemMgr: TMemoryManager;
  head: block;
  used: array[0..hashSize] of block;
  times: array[0..16] of integer;
var
  blockStruct: record
    fFree: cardinal;
    max: cardinal;
    data: array of rblock;
  end;
  
function bGetMem(size: cardinal): block; forward;
function bFreeMem(p: blockFind): integer; forward;
function bReallocMem(p: blockFind; size: cardinal): block; forward
function bFindUsed(p: pointer): blockFind; forward;
function bFindFree(p: pointer): blockFind; forward;
procedure bCondense(node: blockFind); forward;
procedure bNeighbors(node: blockFind; out lneighbor: block; out rneighbor: block); forward;
procedure bBalance; forward;
function aBlock: pointer; forward;
procedure fBlock(p: pointer); forward;

function dGetMem(size: integer): pointer;
var b: block;
begin
//  writeln('dGetMem');
  result := nil;
  b := bGetMem(size);
  if b <> nil then
  begin
    result := b.ptr;
    inc(alloc);
  end;
end;

function dFreeMem(p: pointer): integer;
begin
//  writeln('dFreeMem');
  result := bFreeMem(bFindUsed(p));
  // bFreeMem can return 1 to indicate that it didn't free anything for us,
  //  but we should still return 0 for those calling us;
  if result = 0 then
    dec(alloc);
  if result = 1 then
    result := 0;
end;

function dReallocMem(p: pointer; size: integer): pointer;
var b: block;
var timer: array [0..16] of timespec;
  s: blockFind;
begin
//  writeln('dReallocMem');
  result := nil;
  s := bFindUsed(p);
  b := bReallocMem(s, size);
  if b <> nil then
    result := b.ptr;
end;

procedure dBalance;
begin
  bBalance;
end;

function hash(p: pointer): cardinal;
var i: cardinal;
begin
  result := 0;
  i := cardinal(p);
  while i <> 0 do
  begin
    result := result + (i mod hashSize);
    i := i shr 4;
  end;
  result := result mod hashSize;
end;

{ The nitty gritty }

function bGetMem(size: cardinal): block;
var prev, c, n, nprev: block;
  i: cardinal;
  function search(node: block): block;
  begin
    result := nil;
    if node = nil then exit;
    result := search(node.lhs);
    if result <> nil then
    begin
      if prev = nil then prev := node;
      exit;
    end;
    if node.size >= size then
    begin
      result := node;
      exit;
    end;
    result := search(node.rhs);
    if result <> nil then
    begin
      if prev = nil then prev := node;
      exit;
    end;
  end;
  
begin
  if size MOD minSize <> 0 then
    size := size + (minSize - (size mod minSize));
  // Search the freetree for a usable node.
  prev := nil; result := nil;
  c := search(head);
  if c = nil then exit;
  // Shall we split it?
  if c.size > size then
  begin
    n := aBlock;
    n.size := c.size - size; 
    n.lhs := c.lhs; n.rhs := c.rhs;
    n.ptr := pointer(cardinal(c.ptr) + size);
    n.free := true;
    c.size := size;
    if prev <> nil then
    begin
      if prev.rhs = c then
        prev.rhs := n
      else if prev.lhs = c then
        prev.lhs := n;
    end else
      head := n;
  end else  // Remove the node from the free tree.
  begin
    
  end;
  // Make the node into a used node.
  i := hash(c.ptr);
  c.rhs := used[i];
  c.lhs := nil;
  used[i] := c;
  c.free := false;
  result := c;
end;

function bFreeMem(p: blockFind): integer;
var //c: block;
  n: blockFind;
  found: boolean;
begin
  if p.prev = nil then
    used[hash(p.c.ptr)] := p.c.rhs
  else
    p.prev.rhs := p.c.rhs;
  // Re-add the node to the freetree
  n := bFindFree(p.c.ptr);
  p.c.rhs := nil; p.c.lhs := nil;
  p.c.free := true;

  if cardinal(p.c.ptr) > cardinal(n.c.ptr) then
    n.c.rhs := p.c
  else
    n.c.lhs := p.c;

  // Condense the node with its neighbors.
  p.prev := n.c;
  bCondense(p);
end;

function bReallocMem(p: blockFind; size: cardinal): block;
var n: block;
var timer: array [0..16] of timespec;
  i: cardinal;
begin
end;

function bFindUsed(p: pointer): blockFind;
var i: cardinal;
begin
  i := hash(p);
  result.c := used[i];
  result.prev := nil;
  while result.c <> nil do
  begin
    if result.c.ptr = p then
      break;
    result.prev := result.c;
    result.c := result.c.rhs;
  end;
end;

function bFindFree(p: pointer): blockFind;
var found: boolean;
begin
  result.c := head; result.prev := nil;
  found := false;
  while found = false do
  begin
    if cardinal(p) > cardinal(result.c.ptr) then
    begin
      if result.c.rhs = nil then
        found := true
      else
      begin
        result.prev := result.c;
        result.c := result.c.rhs;
      end;
    end else if cardinal(p) < cardinal(result.c.ptr) then
    begin
      if result.c.lhs = nil then
        found := true
      else
      begin
        result.prev := result.c;
        result.c := result.c.lhs;
      end;
    end;
    if p = result.c.ptr then found := true;
  end;
end;

procedure bCondense(node: blockFind);
var rn, ln: block;
begin
  bNeighbors(node, ln, rn);
  if (ln <> nil) and (cardinal(ln.ptr)+ln.size = cardinal(node.c.ptr)) then
  begin
    writeln('ln condense');
    ln.size := ln.size+node.c.size;
    if node.prev.rhs = node.c then
      node.prev.rhs := nil
    else
      node.prev.lhs := nil;
    fBlock(node.c);
//    node.c := ln;
  end;
  if (rn <> nil) and (cardinal(node.c.ptr)+node.c.size = cardinal(rn.ptr)) then
  begin
    writeln('rn condense');
    rn.ptr := node.c.ptr;
    rn.size := rn.size+node.c.size;
    if node.prev.rhs = node.c then
      node.prev.rhs := nil
    else
      node.prev.lhs := nil;
    fBlock(node.c);
  end;
end;

procedure bNeighbors(node: blockFind; out lneighbor: block; out rneighbor: block);
begin
  { Find Left neighbor. }
  if node.c.lhs = nil then
  begin
    if (node.prev <> nil) and (node.prev.rhs = node.c) then
      lneighbor := node.prev
    else
      lneighbor := nil;
  end else
  begin
    lneighbor := node.c.lhs;
    while lneighbor.rhs <> nil do
      lneighbor := lneighbor.rhs;
  end;
  { Find Right neighbor. }
  if node.c.rhs = nil then
  begin
    if (node.prev <> nil) and (node.prev.lhs = node.c) then
      rneighbor := node.prev
    else
      rneighbor := nil;
  end else
  begin
    rneighbor := node.c.rhs;
    while rneighbor.lhs <> nil do
      rneighbor := rneighbor.lhs;
  end;
end;

procedure bBalance;
var n, m: cardinal;

begin
  n := 0; m := 1;
end;

function aBlock: pointer;
begin
  with blockStruct do
  begin
    result := @data[fFree];
    inc(fFree);
    if fFree >= max then
    begin
      inc(max, 1024);
      realloc(data, max*sizeof(rblock));
      writeln('!!!');
    end;
    while data[fFree].ptr <> nil do
    begin
      if fFree >= max then
      begin
        inc(max, 1024);
        realloc(data, max*sizeof(rblock));
      end;
      inc(fFree);
    end;
  end;
end;

procedure fBlock(p: pointer);
var i: cardinal;
begin
  i := (cardinal(p)-cardinal(blockStruct.data)) DIV sizeof(rblock);
  blockStruct.data[i].ptr := nil;
//  if i < blockStruct.fFree then
//    blockStruct.fFree := i;
end;

procedure p;
begin
//  times[0] := 0;
  writeln(times[0]);
  {write(times[1]); write(' : '); }writeln(times[1]-times[0]);
  {write(times[2]); write(' : '); }writeln(times[2]-times[1]);
  {write(times[3]); write(' : '); }writeln(times[3]-times[2]);
  {write(times[4]); write(' : '); }writeln(times[4]-times[3]);
  {write(times[5]); write(' : '); }writeln(times[5]-times[4]);
  {write(times[6]); write(' : '); }writeln(times[6]-times[5]);
end;

procedure dPtree();
  procedure node(n: block; tab: string);
  begin
    if n = nil then exit;
    if assigned(n.rhs) then
      node(n.rhs, tab+' |');
    writeln(tab+'<-'+parseAsHex(cardinal(n.ptr))+' : '
      +parseAsHex(cardinal(n.free), 2)+' : '+parseAsHex(n.size, 4));
    if assigned(n.lhs) then
      node(n.lhs, tab+'  ');
  end;
  
var cmm: TMemoryManager;
var i: cardinal;
  n: block;
begin
  GetMemoryManager(cmm);
  SetMemoryManager(oldMemMgr);
  writeln('');
  node(head, '');
  writeln('');
  for i := 0 to hashSize do
  begin
    n := used[i];
    if n <> nil then
      writeln(i);
    while n <> nil do
    begin
      writeln(' +'+parseAsHex(cardinal(n.ptr))+' : '
        +parseAsHex(cardinal(n.free), 2)+' : '+parseAsHex(n.size, 4));
      n := n.rhs;
    end;
  end;
  SetMemoryManager(cmm);
end;

const
  dMemMgr: TMemoryManager = (
    GetMem: dGetMem;
    FreeMem: dFreeMem;
    ReallocMem: dReallocMem);
var i: cardinal;
begin
  memSize := 8*1024*1024;
  heap := malloc(memSize);
  base := heap;
  blockStruct.fFree := 1;
  blockStruct.max := 1023;
  blockStruct.data := malloc(blockStruct.max * sizeof(rblock));
  head := @blockStruct.data[0];
  with head^ do
  begin
    size := memSize;
    ptr := base;
    lhs := nil;
    rhs := nil;
    free := true;
  end;
  for i := 0 to hashSize do
    used[i] := nil;
  GetMemoryManager(oldMemMgr);
  //SetMemoryManager(dMemMgr);
  times[0] := 0;
end.