{$A-} unit VHEAPLow; {*********************************************************} {* VHEAPLOW.PAS 7.0 *} {* Writen by HNV 1991,92. *} {* Low level support for virtual heap. *} {*********************************************************} interface uses Classes, Dialogs, OpStrDev, SysUtils; const MaxFree = 256; {- size of free list -} type VirtualPtr = Real; VirtualPtrRec = record Len : LongWord; Addr : LongWord; end; Base = array[ 0..11 ] of VirtualPtr; UserBasesType = ( User01, User02, User03, User04, User05, User06, User07, User08, User09, User10 ); VHeapStatus = { Virtual Heap Status } ( NewVHeap, OldVHeap ); const UseKeyAccess : Boolean = false; { True if use key access } ShowHeapStatus : Boolean = false; { True if need show statistics } MaxHeapSpace : LongWord = 0; { Disk Free } } SaveVHeap : Boolean = False; { true if need saving v-heap } VHeapOk : Boolean = true; { VHeap Error flag } BaseAddr : Base = ( 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ); VHeapCacheProc : Pointer = nil; { Addres of function VirtualToPtr } VHeapErrorProc : Pointer = nil; { Addres of VHeap error routine } {- Virtual Heap File Caching -} MaxCacheSize : LongWord = 0; {- Maximum size of cache -} CacheHeapRatio : Real = 0.5; {- CacheSize / HeapSize -} BytesInCache : LongWord = 0; {- Cache use -} MinCacheLevel : Byte = 8; {- Min number of caching records -} CacheLevel : LongWord = 0; {- Current number of caching records -} CacheRead : LongWord = 0; {- Number of reading records -} CacheWrite : LongWord = 0; {- Number of swaping records -} CacheHits : LongWord = 0; {- Number of cache hits -} CacheEff : Real = 0; {- Caching effect -} CacheSearch : LongWord = 0; {- Cache routine calls -} var VHBases : array[ UserBasesType ] of VirtualPtr Absolute BaseAddr; VHStatus : VHeapStatus; {- Virtual Heap status -} type StringPtr = ^string; VString = object VAddr : VirtualPtr; {- Virtual heap Address -} function Addr : StringPtr; procedure Init; procedure Free; end; procedure InitVHeap( FName : string; Save : Boolean ); {- Initiator of Virtual Heap -} function GetVMem( L : Word ) : VirtualPtr; {- Allocate virtual space -} procedure FreeVMem( V : VirtualPtr ); {- Deallocate virtual space -} function VirtualToPtr( V : VirtualPtr ) : Pointer; {- Converted a virtual pointer to real pointer -} function StrVPtr( V : VirtualPtr ) : StringPtr; {- Converted a virtual pointer to real pointer -} procedure SetCaching( TF : Boolean ); {- Turn Caching OFF if TF is false. -} function StructToVHeap( var S; L : Word ) : VirtualPtr; {- Allocate space for S and return virtual pointer -} procedure StructFromVHeap( var S; V : VirtualPtr ); {- Return S at virtual pointer V -} function StringToVHeap( S : string ) : VirtualPtr; {- Allocate space for S and return virtual pointer -} function StringFromVHeap( V : VirtualPtr ) : string; {- Return S at virtual pointer V -} procedure Statistics( ST : TStrings ); {- Show virtual heap staistics on the screen. -} implementation type FreeListA = array[ 1..MaxFree ] of VirtualPtrRec; FreeListV = array[ 1..MaxFree ] of VirtualPtr; FreeListVHeap = record NFree : LongWord; case Byte of 1 : ( FreeL : FreeListA ); 2 : ( FreeV : FreeListV ); end; FreeListPtrV = ^FreeListVHeap; type CacheAddr = ^CacheRec; CacheRec = record Next : CacheAddr; RecA : Pointer; case byte of 1 : ( HAddr : VirtualPtr ); 2 : ( VRec : VirtualPtrRec ); end; const MaxHeapAddr : LongWord = $7FFFFFFF; MaxHeapBlock : LongWord = $7FFFFFFF; MinHeapBlock : LongWord = 1; HeaderVHeap : string = 'HNV(C)VIRTUAL HEAP FILE V 1.0'; HeaderVFree : string = 'FREE BLOCKS LIST'; Init : Boolean = False; StructRPtr : Pointer = nil; StructVPtr : VirtualPtr = 0; UseFactor : LongWord = 0; DelFreeArea : LongWord = 0; VHeapOrg : LongWord = 0; {- begin of virtual heap -} VHeapPtr : LongWord = 0; {- end of heap -} Caching : Boolean = True; Cache : CacheAddr = nil; var OldExit : Pointer; FreeListArea : FreeListPtrV; F : file; FileName : string; function VString.Addr : StringPtr; begin if VAddr <> 0 then Addr := VirtualToPtr( VAddr ) else begin VAddr := GetVMem( Succ( SizeOf( string ) ) ); Addr := VirtualToPtr( VAddr ); end; end; procedure VString.Init; begin VAddr := 0; end; procedure VString.Free; begin FreeVMem( VAddr ); end; procedure VHeapError( S : string ); begin ShowMessage( S ); Halt( 1 ); end; procedure Abort( S : string ); begin {Inline( $FF/$1E/>VHeapErrorProc );} VHeapError( S ) end; function AllocateFreeList : Pointer; var i : Word; P : Pointer; begin GetMem( P, SizeOf( FreeListVHeap ) ); with FreeListPtrV( P )^ do begin NFree := 0; for i := 1 to MaxFree do begin FreeL[ i ].Len := 0; FreeL[ i ].Addr := 0; end; end; AllocateFreeList := P; end; procedure Store( var S; V : VirtualPtr ); var i : LongWord; VR : VirtualPtrRec Absolute V; begin Inc( CacheWrite ); VHeapOk := True; Seek( F, VR.Addr ); BlockWrite( F, S, VR.Len, i ); VHeapOk := i = VR.Len; end; procedure Load( var S; V : VirtualPtr ); var i : LongWord; VR : VirtualPtrRec Absolute V; begin Inc( CacheRead ); VHeapOk := True; Seek( F, VR.Addr ); BlockRead( F, S, VR.Len, i ); VHeapOk := i = VR.Len; end; procedure LoSwapProc( var P : Pointer; V1, V2 : VirtualPtr ); var VR1 : VirtualPtrRec Absolute V1; VR2 : VirtualPtrRec Absolute V2; begin if P <> nil then begin Store( P^, V1 ); FreeMem( P, VR1.Len ); end; if not VHeapOk then exit; GetMem( P, VR2.Len ); Load( P^, V2 ); end; function LoCacheProc( V : VirtualPtr ) : Pointer; begin VHeapOk := True; if StructVPtr <> V then begin LoSwapProc( StructRPtr, StructVPtr, V ); LoCacheProc := StructRPtr; end else LoCacheProc := StructRPtr; end; procedure CacheNormalizing( L : LongWord ); {--------------------------------------} { Normalizing of Cache size to L value } {--------------------------------------} var P, T : CacheAddr; Done : Boolean; begin repeat P := Cache; T := P; Done := True; while ( BytesInCache + L > MaxCacheSize ) and ( P <> nil ) do with P^ do if Next = nil then begin Store( RecA^, HAddr ); Dec( BytesInCache, VRec.Len ); { Decrement Cache length } if CacheLevel 'INSSUFICIENT MEMORY FOR CACHING.' ); WriteLn( 'PROGRAM TERMINATED.' ); Abort( '$16 CRITICAL ERROR.' ); end; Dec( CacheLevel ); { Decrement Cache level } FreeMem( RecA, VRec.Len ); { Dispose structure } if T <> P then T^.Next := nil { goto next Cache record } else Cache := nil; FreeMem( P, SizeOf( CacheRec ) ); { dispose Cache record } P := nil; Done := False; end else begin T := P; P := Next; end; until Done; end; function AddRecToCache( V : VirtualPtr ) : Pointer; { addition new Cache record to Cache structure } var P : CacheAddr; VR : VirtualPtrRec Absolute V; begin GetMem( P, SizeOf( CacheRec ) ); with P^ do begin Next := Cache; Cache := P; GetMem( RecA, VR.Len ); Inc( CacheLevel ); {- -} Load( RecA^, V ); Inc( BytesInCache, VR.Len ); HAddr := V; AddRecToCache := RecA; end; end; procedure DelCacheRec( V : VirtualPtr ); { deleting Cache record from Cache structure. uses in FreeVmem } var P, T : CacheAddr; begin if not Caching then { exit if Caching is not active } exit; { search a virtual heap pointer in Cache structure } P := Cache; T := P; while P <> nil do with P^ do if HAddr = V then begin Dec( BytesInCache, VRec.Len ); { Decrement Cache length } FreeMem( RecA, VRec.Len ); { Dispose this structure } if T <> P then T^.Next := P^.Next { go to next Cache record } else Cache := P^.Next; { go to next Cache record } FreeMem( P, SizeOf( CacheRec ) ); { dispose Cache record } exit; end else begin T := P; P := Next; end; end; {-------------------------------------------------------} { Center function of VHeapLow unit } { converted a virtual heap pointer to real heap pointer } {-------------------------------------------------------} function VirtualToPtr( V : VirtualPtr ) : Pointer; var P, T : CacheAddr; VR : VirtualPtrRec Absolute V; begin Inc( CacheSearch ); if ( VR.Addr < VHeapOrg ) or ( VR.Addr + VR.Len > VHeapPtr ) then Abort( '$46 Invalid virtual pointer.' ); P := Cache; T := P; while P <> nil do if P^.HAddr = V then begin {- Set top of cache -} if T <> P then begin T^.Next := P^.Next; P^.Next := Cache; Cache := P; end; VirtualToPtr := P^.RecA; Inc( CacheHits ); exit; end else begin T := P; P := P^.Next; end; CacheNormalizing( VR.Len ); VirtualToPtr := AddRecToCache( V ); end; function StrVPtr( V : VirtualPtr ) : StringPtr; {- Converted a virtual pointer to string pointer -} begin StrVptr := VirtualToPtr( V ); end; procedure FlushOldRec; begin if StructRPtr <> nil then Store( StructRPtr^, StructVPtr ); end; procedure SetCaching( TF : Boolean ); {- turn Caching OFF if TF is false -} begin end; function ReadLongWord( var F : file ) : LongWord; var L : LongWord; i : LongWord; begin VHeapOk := True; BlockRead( F, L, SizeOf( LongWord ), i ); if i <> SizeOf( LongWord ) then Abort( '$0B initialization error.' ); ReadLongWord := L; end; function ReadString( var F : file ) : string; var i : LongWord; S : string; begin VHeapOK := True; ReadString := ''; i := ReadLongWord( F ); ShowMessage( intToStr( i ) ); SetLength( S, i ); BlockRead( F, S[ 1 ], i, i ); if i <> Length( S ) then Abort( '$0A Initialization Error.' ); ReadString := S; end; function ReadVirtualPtr( var F : file ) : VirtualPtr; var L : VirtualPtr; i : LongWord; begin VHeapOk := True; BlockRead( F, L, SizeOf( VirtualPtr ), i ); if i <> SizeOf( VirtualPtr ) then Abort( '$13 initialization error.' ); ReadVirtualPtr := L; end; function ReadBoolean( var F : file ) : Boolean; var L : Boolean; i : LongWord; begin VHeapOk := True; BlockRead( F, L, SizeOf( Boolean ), i ); if i <> SizeOf( Boolean ) then Abort( '$0D initialization error.' ); ReadBoolean := L; end; procedure WriteLongWord( var F : file; L : LongWord ); var i : LongWord; begin VHeapOk := True; BlockWrite( F, L, SizeOf( LongWord ), i ); if i <> SizeOf( LongWord ) then Abort( '$10 initialization error.' ); end; procedure WriteString( var F : file; S : string ); var i : LongWord; begin VHeapOK := True; WriteLongWord( F, Length( S ) ); BlockWrite( F, S[ 1 ], Length( S ), i ); if i <> Length( S ) then Abort( '$0F Initialization Error.' ); end; procedure WriteVirtualPtr( var F : file; L : VirtualPtr ); var i : LongWord; begin VHeapOk := True; BlockWrite( F, L, SizeOf( VirtualPtr ), i ); if i <> SizeOf( VirtualPtr ) then Abort( '$12 initialization error.' ); end; procedure WriteBoolean( var F : file; L : Boolean ); var i : LongWord; begin VHeapOk := True; BlockWrite( F, L, SizeOf( Boolean ), i ); if i <> SizeOf( Boolean ) then Abort( '$11 initialization error.' ); end; procedure StoreHeader; begin Seek( F, 0 ); WriteString( F, HeaderVHeap ); WriteLongWord( F, UseFactor ); WriteLongWord( F, DelFreeArea ); WriteLongWord( F, VHeapOrg ); WriteLongWord( F, VHeapPtr ); end; procedure StoreBase; var i : Word; begin for i := 0 to 11 do WriteVirtualPtr( F, BaseAddr[ i ] ); end; procedure StoreFreeList; var i : Word; begin WriteString( F, HeaderVFree ); WriteLongWord( F, FreeListArea^.NFree ); for i := 1 to MaxFree do WriteVirtualPtr( F, FreeListArea^.FreeV[ i ] ); end; procedure LoadHeader; begin Seek( F, 0 ); HeaderVHeap := ReadString( F ); UseFactor := ReadLongWord( F ); DelFreeArea := ReadLongWord( F ); VHeapOrg := ReadLongWord( F ); VHeapPtr := ReadLongWord( F ); end; procedure LoadBase; var i : Word; begin for i := 0 to 11 do BaseAddr[ i ] := ReadVirtualPtr( F ); end; procedure LoadFreeList; var i : Word; begin if ReadString( F ) <> HeaderVFree then Abort( '$32 file is not Virtual Heap' ); FreeListArea^.NFree := ReadLongWord( F ); for i := 1 to MaxFree do FreeListArea^.FreeV[ i ] := ReadVirtualPtr( F ); end; function HasExtension( Name : string; var DotPos : Word ) : Boolean; {-Return whether and position of extension separator dot in a pathname} var I : Word; begin DotPos := 0; for I := Length( Name ) downto 1 do if ( Name[ I ] = '.' ) and ( DotPos = 0 ) then DotPos := I; HasExtension := ( DotPos > 0 ) and ( Pos( '\', Copy( Name, Succ( DotPos ), 64 ) ) = 0 ); end; function ForceExtension( Name, Ext : string ) : string; {-Return a pathname with the specified extension attached} var DotPos : Word; begin if HasExtension( Name, DotPos ) then ForceExtension := Copy( Name, 1, DotPos ) + Ext else ForceExtension := Name + '.' + Ext; end; procedure MakeNewVHeap; var i : Word; begin StoreHeader; for i := 0 to 11 do begin BaseAddr[ i ] := 0; end; StoreBase; FreeListArea^.NFree := 0; StoreFreeList; VHeapOrg := FilePos( F ); VHeapPtr := VHeapOrg; StoreHeader; end; procedure VHeapExit; begin if SaveVHeap then begin if Caching then begin CacheNormalizing( MaxCacheSize ); if Cache <> nil then WriteLn( ' Cache ERROR.' ); end else FlushOldRec; StoreHeader; StoreBase; StoreFreeList; Seek( F, VHeapPtr ); Truncate( F ); Close( F ); end else begin Close( F ); Erase( F ); end; end; { --------------------------- GetVmem --------------------------------} function GetVmemPrim( L : Word ) : VirtualPtr; var V : VirtualPtr; VR : VirtualPtrRec Absolute V; j : Word; K : LongWord; procedure SetVHeapPtr; begin VR.Len := L; VR.Addr := VHeapPtr; Inc( VHeapPtr, L ); end; function Hole : Word; var i : Word; begin Hole := 0; with FreeListArea^ do begin K := MaxHeapBlock; for i := 1 to NFree do if ( FreeL[ i ].Len >= L ) and ( ( FreeL[ i ].Len - L ) < K ) then begin K := FreeL[ i ].Len - L; Hole := i; end; end; end; begin with FreeListArea^ do if NFree = 0 then begin SetVHeapPtr; GetVmemPrim := V; exit; end else begin { Search of Minimum Heap Hole } j := Hole; if j <> 0 then begin VR.Len := L; VR.Addr := FreeL[ j ].Addr; Dec( FreeL[ j ].Len, L ); Inc( FreeL[ j ].Addr, L ); if FreeL[ j ].Len = 0 then begin FreeV[ j ] := FreeV[ NFree ]; Dec( NFree ); end; GetVmemPrim := V; exit; end; SetVHeapPtr; GetVmemPrim := V; end; end; function GetVmem( L : Word ) : VirtualPtr; var V : VirtualPtr; P : ^Byte; begin VHeapOk := True; V := GetVmemPrim( L ); GetMem( P, L ); Store( P^, V ); Freemem( P ); if not VHeapOk then GetVmem := VHeapPtr else GetVmem := V; Dec( MaxHeapSpace, L ); end; { --------------------------- GetVmem --------------------------------} { --------------------------- FreeVmem --------------------------------} procedure SortFreeListByAddress; procedure Sort( l, r : Word ); var i, j : Word; x : LongWord; y : VirtualPtr; begin with FreeListArea^ do begin i := l; j := r; x := FreeL[ ( l + r ) div 2 ].Addr; repeat while FreeL[ i ].Addr < x do i := i + 1; while x < FreeL[ j ].Addr do j := j - 1; if i j; if l < j then sort( l, j ); if i < r then sort( i, r ); end; end; begin {quicksort} ; sort( 1, FreeListArea^.NFree ); end; function ReorgFreeList : Boolean; var Q : LongWord; i : Word; begin ReorgFreeList := False; with FreeListArea^ do begin if NFree MaxHeapBlock then exit; Inc( FreeL[ i ].Len, FreeL[ i + 1 ].Len ); FreeV[ i + 1 ] := FreeV[ NFree ]; Dec( NFree ); ReorgFreeList := True; exit; end; end; end; procedure FreeVmem( V : VirtualPtr ); { Erased a virtual heap pointer } var VR : VirtualPtrRec Absolute V; i : Word; K, j : Word; begin DelCacheRec( V ); { free real heap space if Caching is active } with FreeListArea^ do begin if ( VR.Addr + VR.Len ) <> VHeapPtr then begin if ( NFree + 1 ) > MaxFree then begin K := MaxHeapBlock; j := 1; for i := 1 to MaxFree do if FreeL[ i ].Len < K then begin K := FreeL[ i ].Len; j := i; end; FreeV[ j ] := V; end else begin Inc( NFree ); FreeV[ NFree ] := V; end; end else Dec( VHeapPtr, VR.Len ); repeat if NFree > 1 then SortFreeListByAddress; until not ReorgFreeList; end; end; function StructToVHeap( var S; L : Word ) : VirtualPtr; var V : VirtualPtr; begin StructToVHeap := 0; VHeapOk := True; V := GetVMemPrim( L ); if not VHeapOk then exit; Store( S, V ); StructToVHeap := V; end; procedure StructFromVHeap( var S; V : VirtualPtr ); begin VHeapOk := True; Load( S, V ); end; function StringToVHeap( S : string ) : VirtualPtr; var V : VirtualPtr; begin StringToVHeap := 0; VHeapOk := True; V := GetVMemPrim( Length( S ) ); if not VHeapOk then exit; Store( S, V ); StringToVHeap := V; end; function StringFromVHeap( V : VirtualPtr ) : string; begin VHeapOk := True; StringFromVHeap := StringPtr( VirtualToPtr( V ) )^; end; procedure Statistics( ST : TStrings ); var i : Word; begin with FreeListArea^ do begin UseFactor := 0; if NFree > 0 then for i := 1 to NFree do UseFactor := UseFactor + FreeL[ i ].Len; end; Write( TPStr, '------------ VIRTUAL HEAP STATISTICS ---------------' ); ST.Add( ReturnStr ); Write( TPStr, 'і --- Heap --- і' ); ST.Add( ReturnStr ); Write( TPStr, 'і Bytes in Heap......................: ', VHeapPtr - VHeapOrg : 10, ' і' ); ST.Add( ReturnStr ); Write( TPStr, 'і Start Virtual Heap Address.........: ', VHeapOrg : 10, ' і' ); ST.Add( ReturnStr ); Write( TPStr, 'і Bytes available to Virtual Heap....: ', MaxHeapSpace : 10, ' і' ); ST.Add( ReturnStr ); Write( TPStr, 'і і' ); ST.Add( ReturnStr ); Write( TPStr, '----------------------------------------------------' ); ST.Add( ReturnStr ); Write( TPStr, 'і --- Holes --- і' ); ST.Add( ReturnStr ); Write( TPStr, 'і Number of Heap Holes...............: ', FreeListArea^.NFree : 10, ' і' ); ST.Add( ReturnStr ); Write( TPStr, 'і Bytes in accessible Heap Holes.....: ', UseFactor : 10, ' і' ); ST.Add( ReturnStr ); Write( TPStr, 'і Bytes in not accessible Heap Holes.: ', DelFreeArea : 10, ' і' ); ST.Add( ReturnStr ); if ( VHeapPtr - VHeapOrg ) <> 0 then Write( TPStr, 'і Percent Holes in Heap..............: ', ( UseFactor + DelFreeArea ) / ( VHeapPtr - VHeapOrg + UseFactor ) * 100 : 8 : 4, ' % і' ); ST.Add( ReturnStr ); Write( TPStr, 'і --- Cache --- і' ); ST.Add( ReturnStr ); Write( TPStr, 'і Bytes in Cache.....................: ', BytesInCache : 10, ' і' ); ST.Add( ReturnStr ); Write( TPStr, 'і General Cache Space................: ', MaxCacheSize : 10, ' і' ); ST.Add( ReturnStr ); Write( TPStr, 'і Cache Level........................: ', CacheLevel : 10, ' і' ); ST.Add( ReturnStr ); Write( TPStr, 'і Disk Input : ', CacheRead : 10, '; Output : ', CacheWrite : 10, ' і' ); ST.Add( ReturnStr ); if CacheSearch <> 0 then Write( TPStr, 'і Cache Hits : ', CacheHits : 10, '; Eff [%] : ', CacheHits / CacheSearch * 100 : 10 : 3, ' і' ); ST.Add( ReturnStr ); Write( TPStr, 'і і' ); ST.Add( ReturnStr ); Write( TPStr, '----------------------------------------------------' ); ST.Add( ReturnStr ); end; procedure CalcDiskSize( FName : string ); begin if Pos( ':', FName ) <> 0 then MaxHeapSpace := DiskFree( Pos( UpCase( FName[ 1 ] ), 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' ) ) else MaxHeapSpace := DiskFree( 0 ); end; procedure InitVHeap( FName : string; Save : Boolean ); begin if Init then Abort( '$25 Double Initialization.' ); FileName := FName; SaveVHeap := Save; FreeListArea := AllocateFreeList; if CacheHeapRatio > 0.8 then CacheHeapRatio := 0.8; MaxCacheSize := Trunc( MaxHeapAddr * CacheHeapRatio ); Assign( F, FName ); if not FileExists( FName ) then begin Rewrite( F, 1 ); MakeNewVHeap; VHStatus := NewVHeap; CalcDiskSize( FName ); end else begin Reset( F, 1 ); VHStatus := OldVHeap; if ReadString( F ) <> HeaderVHeap then Abort( 'file is not Virtual Heap.' ); LoadHeader; LoadBase; LoadFreeList; Init := True; CalcDiskSize( FName ); end; end; initialization finalization VHeapExit; end. |