|
@@ -40,283 +40,11 @@ function zcalloc (opaque : pointer; items : cardinal; size : cardinal) : pointer
|
|
|
|
|
|
implementation
|
|
|
|
|
|
-{$ifdef ver80}
|
|
|
- {$define Delphi16}
|
|
|
-{$endif}
|
|
|
-{$ifdef ver70}
|
|
|
- {$define HugeMem}
|
|
|
-{$endif}
|
|
|
-{$ifdef ver60}
|
|
|
- {$define HugeMem}
|
|
|
-{$endif}
|
|
|
-
|
|
|
-{$IFDEF CALLDOS}
|
|
|
-uses
|
|
|
- WinDos;
|
|
|
-{$ENDIF}
|
|
|
-{$IFDEF Delphi16}
|
|
|
-uses
|
|
|
- WinTypes,
|
|
|
- WinProcs;
|
|
|
-{$ENDIF}
|
|
|
-{$IFNDEF FPC}
|
|
|
- {$IFDEF DPMI}
|
|
|
- uses
|
|
|
- WinAPI;
|
|
|
- {$ENDIF}
|
|
|
-{$ENDIF}
|
|
|
-
|
|
|
-{$IFDEF CALLDOS}
|
|
|
-{ reduce your application memory footprint with $M before using this }
|
|
|
-function dosAlloc (Size : Longint) : Pointer;
|
|
|
-var
|
|
|
- regs: TRegisters;
|
|
|
-begin
|
|
|
- regs.bx := (Size + 15) div 16; { number of 16-bytes-paragraphs }
|
|
|
- regs.ah := $48; { Allocate memory block }
|
|
|
- msdos(regs);
|
|
|
- if regs.Flags and FCarry <> 0 then
|
|
|
- DosAlloc := NIL
|
|
|
- else
|
|
|
- DosAlloc := Ptr(regs.ax, 0);
|
|
|
-end;
|
|
|
-
|
|
|
-
|
|
|
-function dosFree(P : pointer) : boolean;
|
|
|
-var
|
|
|
- regs: TRegisters;
|
|
|
-begin
|
|
|
- dosFree := FALSE;
|
|
|
- regs.bx := Seg(P^); { segment }
|
|
|
- if Ofs(P) <> 0 then
|
|
|
- exit;
|
|
|
- regs.ah := $49; { Free memory block }
|
|
|
- msdos(regs);
|
|
|
- dosFree := (regs.Flags and FCarry = 0);
|
|
|
-end;
|
|
|
-{$ENDIF}
|
|
|
-
|
|
|
type
|
|
|
LH = record
|
|
|
L, H : word;
|
|
|
end;
|
|
|
|
|
|
-{$IFDEF HugeMem}
|
|
|
- {$define HEAP_LIST}
|
|
|
-{$endif}
|
|
|
-
|
|
|
-{$IFDEF HEAP_LIST} {--- to avoid Mark and Release --- }
|
|
|
-const
|
|
|
- MaxAllocEntries = 50;
|
|
|
-type
|
|
|
- TMemRec = record
|
|
|
- orgvalue,
|
|
|
- value : pointer;
|
|
|
- size: longint;
|
|
|
- end;
|
|
|
-const
|
|
|
- allocatedCount : 0..MaxAllocEntries = 0;
|
|
|
-var
|
|
|
- allocatedList : array[0..MaxAllocEntries-1] of TMemRec;
|
|
|
-
|
|
|
- function NewAllocation(ptr0, ptr : pointer; memsize : longint) : boolean;
|
|
|
- begin
|
|
|
- if (allocatedCount < MaxAllocEntries) and (ptr0 <> NIL) then
|
|
|
- begin
|
|
|
- with allocatedList[allocatedCount] do
|
|
|
- begin
|
|
|
- orgvalue := ptr0;
|
|
|
- value := ptr;
|
|
|
- size := memsize;
|
|
|
- end;
|
|
|
- Inc(allocatedCount); { we don't check for duplicate }
|
|
|
- NewAllocation := TRUE;
|
|
|
- end
|
|
|
- else
|
|
|
- NewAllocation := FALSE;
|
|
|
- end;
|
|
|
-{$ENDIF}
|
|
|
-
|
|
|
-{$IFDEF HugeMem}
|
|
|
-
|
|
|
-{ The code below is extremely version specific to the TP 6/7 heap manager!!}
|
|
|
-type
|
|
|
- PFreeRec = ^TFreeRec;
|
|
|
- TFreeRec = record
|
|
|
- next: PFreeRec;
|
|
|
- size: Pointer;
|
|
|
- end;
|
|
|
-type
|
|
|
- HugePtr = pointer;
|
|
|
-
|
|
|
-
|
|
|
- procedure IncPtr(var p:pointer;count:word);
|
|
|
- { Increments pointer }
|
|
|
- begin
|
|
|
- inc(LH(p).L,count);
|
|
|
- if LH(p).L < count then
|
|
|
- inc(LH(p).H,SelectorInc); { $1000 }
|
|
|
- end;
|
|
|
-
|
|
|
- procedure DecPtr(var p:pointer;count:word);
|
|
|
- { decrements pointer }
|
|
|
- begin
|
|
|
- if count > LH(p).L then
|
|
|
- dec(LH(p).H,SelectorInc);
|
|
|
- dec(LH(p).L,Count);
|
|
|
- end;
|
|
|
-
|
|
|
- procedure IncPtrLong(var p:pointer;count:longint);
|
|
|
- { Increments pointer; assumes count > 0 }
|
|
|
- begin
|
|
|
- inc(LH(p).H,SelectorInc*LH(count).H);
|
|
|
- inc(LH(p).L,LH(Count).L);
|
|
|
- if LH(p).L < LH(count).L then
|
|
|
- inc(LH(p).H,SelectorInc);
|
|
|
- end;
|
|
|
-
|
|
|
- procedure DecPtrLong(var p:pointer;count:longint);
|
|
|
- { Decrements pointer; assumes count > 0 }
|
|
|
- begin
|
|
|
- if LH(count).L > LH(p).L then
|
|
|
- dec(LH(p).H,SelectorInc);
|
|
|
- dec(LH(p).L,LH(Count).L);
|
|
|
- dec(LH(p).H,SelectorInc*LH(Count).H);
|
|
|
- end;
|
|
|
- { The next section is for real mode only }
|
|
|
-
|
|
|
-function Normalized(p : pointer) : pointer;
|
|
|
-var
|
|
|
- count : word;
|
|
|
-begin
|
|
|
- count := LH(p).L and $FFF0;
|
|
|
- Normalized := Ptr(LH(p).H + (count shr 4), LH(p).L and $F);
|
|
|
-end;
|
|
|
-
|
|
|
-procedure FreeHuge(var p:HugePtr; size : longint);
|
|
|
-const
|
|
|
- blocksize = $FFF0;
|
|
|
-var
|
|
|
- block : word;
|
|
|
-begin
|
|
|
- while size > 0 do
|
|
|
- begin
|
|
|
- { block := minimum(size, blocksize); }
|
|
|
- if size > blocksize then
|
|
|
- block := blocksize
|
|
|
- else
|
|
|
- block := size;
|
|
|
-
|
|
|
- dec(size,block);
|
|
|
- freemem(p,block);
|
|
|
- IncPtr(p,block); { we may get ptr($xxxx, $fff8) and 31 bytes left }
|
|
|
- p := Normalized(p); { to free, so we must normalize }
|
|
|
- end;
|
|
|
-end;
|
|
|
-
|
|
|
-function FreeMemHuge(ptr : pointer) : boolean;
|
|
|
-var
|
|
|
- i : integer; { -1..MaxAllocEntries }
|
|
|
-begin
|
|
|
- FreeMemHuge := FALSE;
|
|
|
- i := allocatedCount - 1;
|
|
|
- while (i >= 0) do
|
|
|
- begin
|
|
|
- if (ptr = allocatedList[i].value) then
|
|
|
- begin
|
|
|
- with allocatedList[i] do
|
|
|
- FreeHuge(orgvalue, size);
|
|
|
-
|
|
|
- Move(allocatedList[i+1], allocatedList[i],
|
|
|
- SizeOf(TMemRec)*(allocatedCount - 1 - i));
|
|
|
- Dec(allocatedCount);
|
|
|
- FreeMemHuge := TRUE;
|
|
|
- break;
|
|
|
- end;
|
|
|
- Dec(i);
|
|
|
- end;
|
|
|
-end;
|
|
|
-
|
|
|
-procedure GetMemHuge(var p:HugePtr;memsize:longint);
|
|
|
-const
|
|
|
- blocksize = $FFF0;
|
|
|
-var
|
|
|
- size : longint;
|
|
|
- prev,free : PFreeRec;
|
|
|
- save,temp : pointer;
|
|
|
- block : word;
|
|
|
-begin
|
|
|
- p := NIL;
|
|
|
- { Handle the easy cases first }
|
|
|
- if memsize > maxavail then
|
|
|
- exit
|
|
|
- else
|
|
|
- if memsize <= blocksize then
|
|
|
- begin
|
|
|
- getmem(p, memsize);
|
|
|
- if not NewAllocation(p, p, memsize) then
|
|
|
- begin
|
|
|
- FreeMem(p, memsize);
|
|
|
- p := NIL;
|
|
|
- end;
|
|
|
- end
|
|
|
- else
|
|
|
- begin
|
|
|
- size := memsize + 15;
|
|
|
-
|
|
|
- { Find the block that has enough space }
|
|
|
- prev := PFreeRec(@freeList);
|
|
|
- free := prev^.next;
|
|
|
- while (free <> heapptr) and (ptr2int(free^.size) < size) do
|
|
|
- begin
|
|
|
- prev := free;
|
|
|
- free := prev^.next;
|
|
|
- end;
|
|
|
-
|
|
|
- { Now free points to a region with enough space; make it the first one and
|
|
|
- multiple allocations will be contiguous. }
|
|
|
-
|
|
|
- save := freelist;
|
|
|
- freelist := free;
|
|
|
- { In TP 6, this works; check against other heap managers }
|
|
|
- while size > 0 do
|
|
|
- begin
|
|
|
- { block := minimum(size, blocksize); }
|
|
|
- if size > blocksize then
|
|
|
- block := blocksize
|
|
|
- else
|
|
|
- block := size;
|
|
|
- dec(size,block);
|
|
|
- getmem(temp,block);
|
|
|
- end;
|
|
|
-
|
|
|
- { We've got what we want now; just sort things out and restore the
|
|
|
- free list to normal }
|
|
|
-
|
|
|
- p := free;
|
|
|
- if prev^.next <> freelist then
|
|
|
- begin
|
|
|
- prev^.next := freelist;
|
|
|
- freelist := save;
|
|
|
- end;
|
|
|
-
|
|
|
- if (p <> NIL) then
|
|
|
- begin
|
|
|
- { return pointer with 0 offset }
|
|
|
- temp := p;
|
|
|
- if Ofs(p^)<>0 Then
|
|
|
- p := Ptr(Seg(p^)+1,0); { hack }
|
|
|
- if not NewAllocation(temp, p, memsize + 15) then
|
|
|
- begin
|
|
|
- FreeHuge(temp, size);
|
|
|
- p := NIL;
|
|
|
- end;
|
|
|
- end;
|
|
|
-
|
|
|
- end;
|
|
|
-end;
|
|
|
-
|
|
|
-{$ENDIF}
|
|
|
|
|
|
function zmemcmp(s1p, s2p : Pbyte; len : cardinal) : integer;
|
|
|
var
|
|
@@ -340,133 +68,26 @@ begin
|
|
|
end;
|
|
|
|
|
|
procedure zcfree(opaque : pointer; ptr : pointer);
|
|
|
-{$ifdef Delphi16}
|
|
|
-var
|
|
|
- Handle : THandle;
|
|
|
-{$endif}
|
|
|
-{$IFDEF FPC}
|
|
|
+
|
|
|
var
|
|
|
memsize : cardinal;
|
|
|
-{$ENDIF}
|
|
|
+
|
|
|
begin
|
|
|
- {$IFDEF DPMI}
|
|
|
- {h :=} GlobalFreePtr(ptr);
|
|
|
- {$ELSE}
|
|
|
- {$IFDEF CALL_DOS}
|
|
|
- dosFree(ptr);
|
|
|
- {$ELSE}
|
|
|
- {$ifdef HugeMem}
|
|
|
- FreeMemHuge(ptr);
|
|
|
- {$else}
|
|
|
- {$ifdef Delphi16}
|
|
|
- Handle := GlobalHandle(LH(ptr).H); { HiWord(LongInt(ptr)) }
|
|
|
- GlobalUnLock(Handle);
|
|
|
- GlobalFree(Handle);
|
|
|
- {$else}
|
|
|
- {$IFDEF FPC}
|
|
|
- dec(Pcardinal(ptr));
|
|
|
- memsize := Pcardinal(ptr)^;
|
|
|
- FreeMem(ptr, memsize+SizeOf(cardinal));
|
|
|
- {$ELSE}
|
|
|
- FreeMem(ptr); { Delphi 2,3,4 }
|
|
|
- {$ENDIF}
|
|
|
- {$endif}
|
|
|
- {$endif}
|
|
|
- {$ENDIF}
|
|
|
- {$ENDIF}
|
|
|
+ dec(Pcardinal(ptr));
|
|
|
+ memsize := Pcardinal(ptr)^;
|
|
|
+ FreeMem(ptr, memsize+SizeOf(cardinal));
|
|
|
end;
|
|
|
|
|
|
function zcalloc (opaque : pointer; items : cardinal; size : cardinal) : pointer;
|
|
|
var
|
|
|
p : pointer;
|
|
|
memsize : cardinal;
|
|
|
-{$ifdef Delphi16}
|
|
|
- handle : THandle;
|
|
|
-{$endif}
|
|
|
begin
|
|
|
memsize := items * size;
|
|
|
- {$IFDEF DPMI}
|
|
|
- p := GlobalAllocPtr(gmem_moveable, memsize);
|
|
|
- {$ELSE}
|
|
|
- {$IFDEF CALLDOS}
|
|
|
- p := dosAlloc(memsize);
|
|
|
- {$ELSE}
|
|
|
- {$ifdef HugeMem}
|
|
|
- GetMemHuge(p, memsize);
|
|
|
- {$else}
|
|
|
- {$ifdef Delphi16}
|
|
|
- Handle := GlobalAlloc(HeapAllocFlags, memsize);
|
|
|
- p := GlobalLock(Handle);
|
|
|
- {$else}
|
|
|
- {$IFDEF FPC}
|
|
|
- getmem(p, memsize+sizeOf(cardinal));
|
|
|
- Pcardinal(p)^:= memsize;
|
|
|
- inc(Pcardinal(p));
|
|
|
- {$ELSE}
|
|
|
- GetMem(p, memsize); { Delphi: p := AllocMem(memsize); }
|
|
|
- {$ENDIF}
|
|
|
- {$endif}
|
|
|
- {$endif}
|
|
|
- {$ENDIF}
|
|
|
- {$ENDIF}
|
|
|
+ getmem(p, memsize+sizeOf(cardinal));
|
|
|
+ Pcardinal(p)^:= memsize;
|
|
|
+ inc(Pcardinal(p));
|
|
|
zcalloc := p;
|
|
|
end;
|
|
|
|
|
|
end.
|
|
|
-
|
|
|
-
|
|
|
-{ edited from a SWAG posting:
|
|
|
-
|
|
|
-In Turbo Pascal 6, the heap is the memory allocated when using the Procedures 'New' and
|
|
|
-'GetMem'. The heap starts at the address location pointed to by 'Heaporg' and
|
|
|
-grows to higher addresses as more memory is allocated. The top of the heap,
|
|
|
-the first address of allocatable memory space above the allocated memory
|
|
|
-space, is pointed to by 'HeapPtr'.
|
|
|
-
|
|
|
-Memory is deallocated by the Procedures 'Dispose' and 'FreeMem'. As memory
|
|
|
-blocks are deallocated more memory becomes available, but..... When a block
|
|
|
-of memory, which is not the top-most block in the heap is deallocated, a gap
|
|
|
-in the heap will appear. to keep track of these gaps Turbo Pascal maintains
|
|
|
-a so called free list.
|
|
|
-
|
|
|
-The Function 'MaxAvail' holds the size of the largest contiguous free block
|
|
|
-_in_ the heap. The Function 'MemAvail' holds the sum of all free blocks in
|
|
|
-the heap.
|
|
|
-
|
|
|
-TP6.0 keeps track of the free blocks by writing a 'free list Record' to the
|
|
|
-first eight Bytes of the freed memory block! A (TP6.0) free-list Record
|
|
|
-contains two four Byte Pointers of which the first one points to the next
|
|
|
-free memory block, the second Pointer is not a Real Pointer but contains the
|
|
|
-size of the memory block.
|
|
|
-
|
|
|
-Summary
|
|
|
-
|
|
|
-TP6.0 maintains a linked list with block sizes and Pointers to the _next_
|
|
|
-free block. An extra heap Variable 'Heapend' designate the end of the heap.
|
|
|
-When 'HeapPtr' and 'FreeList' have the same value, the free list is empty.
|
|
|
-
|
|
|
-
|
|
|
- TP6.0 Heapend
|
|
|
- +---------+ <----
|
|
|
- | |
|
|
|
- | |
|
|
|
- | |
|
|
|
- | |
|
|
|
- | |
|
|
|
- | |
|
|
|
- | |
|
|
|
- | | HeapPtr
|
|
|
- +->+---------+ <----
|
|
|
- | | |
|
|
|
- | +---------+
|
|
|
- +--| Free |
|
|
|
- +->+---------+
|
|
|
- | | |
|
|
|
- | +---------+
|
|
|
- +--| Free | FreeList
|
|
|
- +---------+ <----
|
|
|
- | | Heaporg
|
|
|
- +---------+ <----
|
|
|
-
|
|
|
-
|
|
|
-}
|