vmem.pas

Turbo Pascal 6.0编译器源码

unit VMem;

{$O+,F+,S-,X+}

interface

uses Objects;

const

  VMemPageSize  = 4096;
  VMemPageShift = 12;

type

  HMem = ^Word;

procedure InitVMem(Segment: Word; NumBlocks: Integer);
procedure AddStream(AStream: PStream; APages: Word);
procedure DoneVMem;
function  GetVMem(Size: Word): HMem;
procedure FreeVMem(H: HMem);
procedure ReallocVMem(H: HMem; Size: Word);
procedure UnlockHandle(H: HMem);
procedure LockHandle(H: HMem);
function  UseHandle(H: HMem): Pointer;
function  MAlloc(Size: Word): Pointer;
procedure MFree(P: Pointer; Size: Word);
procedure ToggleMAlloc;

implementation

uses Memory;

const

  MaxPages = 1024;
  MaxBuckets = 64;
  MaxStreams = 8;

  FreePages: Integer = MaxPages;
  MapPtr: Integer = 0;
  BucketCount: Integer = MaxBuckets;
  ListHead: Byte = $FF;
  ListTail: Byte = $FF;
  StreamCount: Integer = 0;
  TotalPages: Word = 0;
  Buffer: Pointer = nil;

var

  PageMap: array[0..MaxPages] of Word;
  FreeMap: array[0..MaxPages div 16 - 1] of Word;
  Buckets: array[0..MaxBuckets - 1] of Word;
  UsedList: array[0..MaxBuckets - 1] of Word;
  VMemOrg: Word;
  VMemSize: Word;
  Streams: array[0..MaxStreams - 1] of record
    Stream: PStream;
    Size: Word;
  end;

function ChangePage(Page: Word; Save: Boolean): Word; forward;

function Seg2VMem(Segment: Word): Word; assembler;
asm
	MOV     AX,Segment
	SUB     AX,VMemOrg
	MOV     CX,VMemPageShift-4
	SHR     AX,CL
end;

function VMem2Seg(I: Word): Word; assembler;
asm
	MOV     AX,I
	MOV     CX,VMemPageShift-4
	SHL     AX,CL
	ADD     AX,VMemOrg
end;

function SegInVMem(Segment: Word): Boolean; assembler;
asm
        XOR     AX,AX
	MOV     BX,Segment
        SUB     BX,VMemOrg
        JB      @@1
        SUB     BX,VMemSize
        JAE     @@1
        INC     AX
@@1:
end;

function NewHandle: HMem; assembler;
asm
        MOV     AX,MapPtr
        MOV     BX,AX
        LEA     DI,PageMap
        MOV     BX,[DI+BX]
	MOV     MapPtr,BX
	ADD     AX,DI
	MOV     DX,DS
end;

procedure DisposeHandle(H: HMem); assembler;
asm
        MOV     BX,H.Word[0]
        MOV     AX,MapPtr
        MOV     [BX],AX
        SUB     BX,offset PageMap
        MOV     MapPtr,BX
end;

function GetFreePage: Word; assembler;
asm
        LEA     DI,FreeMap
        PUSH    DS
        POP     ES
        MOV     AX,-1
        CLD
	MOV     CX,MaxPages SHR 4
	REPE    SCASW
	JE      @@2
	MOV     AX,MaxPages SHR 4
	SUB     AX,CX
	DEC     AX
	MOV     CX,4
	SHL     AX,CL
	DEC     DI
	DEC     DI
	MOV     DX,ES:[DI]
	XOR     CX,CX
	DEC     CX
@@1:    INC     CX
	SHR     DX,1
	JC      @@1
	MOV     DX,1
	SHL     DX,CL
	OR      ES:[DI],DX
        ADD     AX,CX
        CMP     AX,TotalPages
        JB      @@3
@@2:    MOV     AX,0FFFFH
@@3:
end;

procedure ToggleFree(Page: Word); assembler;
asm
        MOV     AX,Page
        MOV     BX,AX
        MOV     CX,4
        SHR     BX,CL
        SHL     BX,1
        MOV     CX,AX
        AND     CX,0FH
        MOV     DX,1
        SHL     DX,CL
        XOR     FreeMap.Word[BX],DX
end;

procedure FindStream(Page: Word; var SIndex: Integer; var SPage: Word);
var
  I: Integer;
  Count: Longint;
begin
  I := 0;
  Count := Streams[I].Size;
  while Count <= Page do
  begin
    Inc(I);
    Inc(Count, Streams[I].Size);
  end;
  SIndex := I;
  SPage := Page - (Count - Streams[I].Size);
end;

function WritePage(SIndex: Integer; SPage: Word; Buf: Pointer): Boolean;
begin
  WritePage := True;
  with Streams[SIndex].Stream^ do
  begin
    Seek(Longint(SPage) * VMemPageSize);
    Write(Buf^, VMemPageSize);
    if Status <> stOk then
    begin
      WritePage := False;
      Status := stOk;
    end;
  end;
end;

procedure ReadPage(SIndex: Integer; SPage: Word; Buf: Pointer);
begin
  with Streams[SIndex].Stream^ do
  begin
    Seek(Longint(SPage) * VMemPageSize);
    Read(Buf^, VMemPageSize);
  end;
end;

procedure CheckPage(Page: Word; var Save: Boolean; H: HMem); assembler;
asm
	LEA     DI,Buckets
        PUSH    DS
        POP     ES
        XOR     AX,AX
	CLD
	MOV     CX,BucketCount
        REPNZ   SCASW
        JNZ     @@1
	MOV     AX,BucketCount
        SUB     AX,CX
        DEC     AX
	LES     DI,Save
        MOV     ES:[DI].Byte,0
        JMP     @@2
@@1:    PUSH    Page
	LES     DI,Save
        PUSH    ES:[DI].Word
	CALL    ChangePage
        CMP     AX,0FFFFH
        JE      @@3
@@2:    MOV     BX,AX
        SHL     BX,1
        MOV     CX,H.Word[0]
	MOV     Buckets.Word[BX],CX
        PUSH    AX
        CALL    VMem2Seg
@@3:    LES     DI,H
        STOSW
end;

procedure LoadHandle(H: HMem);
var
  Save: Boolean;
  Buf: Pointer;
  Page, SPage: Word;
  SIndex: Integer;
begin
  Page := H^;
  FindStream(Page, SIndex, SPage);
  Save := True;
  CheckPage(Page, Save, H);
  Buf := Ptr(H^, 0);
  ReadPage(SIndex, SPage, Buf);
  if Save then
    WritePage(SIndex, SPage, Buffer)
  else
    ToggleFree(Page);
end;

function CreatePage: HMem;
var
  Save: Boolean;
  H: HMem;
begin
  CreatePage := nil;
  H := NewHandle;
  if H^ <> $FFFF then
  begin
    Save := False;
    CheckPage(0, Save, H);
    if H^ <> $FFFF then
      CreatePage := H
    else
      DisposeHandle(H);
  end;
end;

procedure DeleteFromList(I: Word); assembler;
asm
        MOV     AX,I
        LEA     BX,UsedList
        MOV     DI,AX
        SHL     DI,1
        PUSH    DI
        CMP     AL,ListTail
	JNE     @@1
        MOV     CL,[BX+DI+1]
        MOV     ListTail,CL
@@1:    CMP     AL,ListHead
        JNE     @@2
        MOV     CL,[BX+DI]
        MOV     ListHead,CL
@@2:    MOV     CL,[BX+DI]
        MOV     AL,[BX+DI+1]
        CMP     CL,0FFH
        JE      @@3
        XOR     CH,CH
        MOV     SI,CX
	SHL     SI,1
        MOV     [BX+SI+1],AL
@@3:    CMP     AL,0FFH
	JE      @@4
        MOV     DI,AX
        SHL     DI,1
        MOV     [BX+DI],CL
@@4:    POP     DI
        MOV     [BX+DI].Word,0FFFFH
end;

procedure InsertToList(I: Word); assembler;
asm
	MOV     AX,I
        MOV     CX,AX
        XCHG    AL,ListHead
	CMP     AL,0FFH
        JNE     @@1
        MOV     ListTail,CL
        JMP     @@2
@@1:    LEA     BX,UsedList
        MOV     DI,CX
        SHL     DI,1
        MOV     SI,AX
        SHL     SI,1
        MOV     [BX+SI+1],CL
	MOV     [BX+DI],AL
@@2:
end;

function UseHandle(H: HMem): Pointer; assembler;
var
  Segment: Word;
asm
        MOV     SI,H.Word[0]
        LODSW
        CMP     AX,MaxPages
        JA      @@1
        PUSH    H.Word[2]
	PUSH    H.Word[0]
	CALL    LoadHandle
        MOV     SI,H.Word[0]
	LODSW
@@1:    MOV     Segment,AX
        PUSH    AX
        CALL    SegInVMem
        OR      AX,AX
        JZ      @@2
        PUSH    Segment
        CALL    Seg2VMem
        CMP     AL,ListHead
        JE      @@2
	PUSH    AX
        PUSH    AX
        CALL    DeleteFromList
	CALL    InsertToList
@@2:    XOR     AX,AX
        MOV     DX,Segment
end;

procedure DiscardHandle(H: HMem); assembler;
asm
        MOV     SI,H.Word[0]
        LODSW
        CMP     AX,MaxPages
	JA      @@1
        PUSH    AX
        CALL    ToggleFree
	JMP     @@2
@@1:    PUSH    AX
        CALL    Seg2VMem
        MOV     BX,AX
        SHL     BX,1
	MOV     Buckets.Word[BX],0
        PUSH    AX
        CALL    DeleteFromList
@@2:
end;

procedure CalcTotalPages;
var
  I: Integer;
begin
  TotalPages := 0;
  for I := 0 to StreamCount - 1 do
    with Streams[I] do
      if Longint(TotalPages) + Size > MaxPages then
      begin
        TotalPages := MaxPages;
        Exit;
      end else
        Inc(TotalPages, Size);
end;

function NewPage(I: Word): Word;
var
  H: HMem;
  Buf: Pointer;
  SIndex: Integer;
  Page, SPage: Word;
  Found: Boolean;

function LoadedPageI: HMem;
inline($8B/$7E/<I/
       $D1/$E7/
       $8B/$85/>Buckets/
       $8C/$DA);

begin
  repeat
    Found := True;
    Page := GetFreePage;
    if Page = $FFFF then
      NewPage := $FFFF
    else
    begin
      FindStream(Page, SIndex, SPage);
      Buf := Ptr(VMem2Seg(I), 0);
      if not WritePage(SIndex, SPage, Buf) then
	if SIndex + 1 = StreamCount then
          NewPage := $FFFF
        else
	begin
	  Streams[SIndex].Size := SPage;
	  CalcTotalPages;
	  Found := False;
        end
      else
      begin
        NewPage := I;
	H := LoadedPageI;
        DiscardHandle(H);
        H^ := Page;
      end;
    end;
  until Found;
end;

function SwapPage(Page: Word; I: Word): Word;
var
  H: HMem;

function LoadedPageI: HMem;
inline($8B/$7E/<I/
       $D1/$E7/
       $8B/$85/>Buckets/
       $8C/$DA);

begin
  H := LoadedPageI;
  DiscardHandle(H);
  H^ := Page;
  asm
        PUSH    I
        CALL    VMem2Seg
        PUSH    DS
        LES     DI,Buffer
        MOV     DS,AX
        XOR     SI,SI
        MOV     CX,VMemPageSize SHR 1
        CLD
        REP     MOVSW
        POP     DS
  end;
  SwapPage := I;
end;

function ChangePage(Page: Word; Save: Boolean): Word;
var
  I: Word;
begin
  I := ListTail;
  if I = $FF then
    ChangePage := $FFFF
  else if Save then
    ChangePage := SwapPage(Page, I)
  else
    ChangePage := NewPage(I);
end;

procedure InitVMem(Segment: Word; NumBlocks: Integer); assembler;
asm
        MOV     AX,Segment
        MOV     Buffer.Word[2],AX
        ADD     Segment,VMemPageSize SHR 4
        DEC     NumBlocks
        MOV     AX,NumBlocks
	CMP     AX,BucketCount
        JA      @@1
	MOV     BucketCount,AX
@@1:    LEA     DI,PageMap
        PUSH    DS
        POP     ES
        XOR     AX,AX
        CLD
        MOV     CX,MaxPages
@@2:    INC     AX
        INC     AX
        STOSW
        LOOP    @@2
        MOV     AX,0FFFFH
        MOV     [DI],AX
        XOR     AX,AX
        LEA     DI,FreeMap
        MOV     CX,MaxPages SHR 4
        REP     STOSW
	LEA     DI,Buckets
	MOV     CX,BucketCount
        REP     STOSW
        LEA     DI,UsedList
        DEC     AX
	MOV     CX,BucketCount
        REP     STOSW
        MOV     AX,Segment
        MOV     VMemOrg,AX
        MOV     AX,NumBlocks
        MOV     CL,8
        SHL     AX,CL
        MOV     VMemSize,AX
end;

procedure AddStream(AStream: PStream; APages: Word);
begin
  if (StreamCount <= MaxStreams - 1) and (APages <> 0) then
    with Streams[StreamCount] do
    begin
      Stream := AStream;
      Size := APages;
      if Longint(TotalPages) + APages >= MaxPages then
	TotalPages := MaxPages
      else
        Inc(TotalPages, APages);
      Inc(StreamCount);
    end
  else Dispose(AStream, Done);
end;

procedure DoneVMem;
var
  I:Integer;
begin
  for I := 0 to StreamCount - 1 do
    Dispose(Streams[I].Stream, Done);
end;

function GetVMem(Size: Word): HMem;
var
  I: Integer;
  H: HMem;
begin
  if FreePages <> 0 then
  begin
    if Size <> VMemPageSize then
      GetVMem := nil
    else
    begin
      H := CreatePage;
      GetVMem := H;
      if H <> nil then
      begin
	UseHandle(H);
	Dec(FreePages);
      end;
    end;
  end else GetVMem := nil;
end;

procedure FreeVMem(H: HMem);
begin
  DiscardHandle(H);
  DisposeHandle(H);
  Inc(FreePages);
end;

procedure ReallocVMem(H: HMem; Size: Word); assembler;
asm
        INT 3
end;

procedure UnlockHandle(H: HMem);
begin
  if H^ > MaxPages then
    UseHandle(H);
end;

procedure LockHandle(H: HMem);
begin
  UseHandle(H);
  DeleteFromList(Seg2VMem(H^));
end;

function MAlloc(Size: Word): Pointer;
begin
  MAlloc := MemAlloc(Size);
end;

procedure MFree(P: Pointer; Size: Word);
begin
  if P <> nil then
    FreeMem(P, Size);
end;

procedure ToggleMAlloc; assembler;
asm
end;

end.