[Back to MEMORY SWAG index] [Back to Main SWAG index] [Original]

    {$A-,B-,D-,E-,F-,G-,I-,L-,N-,O-,R-,S+,V-,X-}

    Unit UMB_Heap;

    {----------------------------------------------------------------------------}

    interface

      Procedure Extend_Heap;        { Use Upper Memory Blocks (UMB) to extend    }
                                    { the Turbo Pascal 6.0 heap.  This procedure }
                                    { should be called as soon as possible in    }
                                    { your code.                                 }
      var
        UMB_Heap_Debug : Boolean;   { If true, releases UMBs immediately to make }
                                    { sure they're available for the next run    }
                                    { without rebooting.  Used when debugging in }
                                    { the IDE.  If not used then, the UMBs may   }
                                    { not get freed between executions.          }

    {----------------------------------------------------------------------------}

    implementation

    const
      Max_Blocks = 4;              { It's not likely more than 4 UMBs are needed }

    type
      PFreeRec = ^TFreeRec;      {  From pg. 216 of the TP6 programmer's guide.  }
      TFreeRec = record          {  It's used for traversing the free blocks of  }
        Next : PFreeRec;         {  the heap.                                    }
        Size : Pointer;
      end;

    var
      XMS_Driver : Pointer;      {  Pointer to the XMS driver.  }
      Num_Blocks : Word;
      Block_Address,
      Block_Size : Array[1..Max_Blocks+1] of Pointer;
      SaveExitProc : Pointer;

    {----------------------------------------------------------------------------}

    {  Swap to pointers.  Needed when sorting the UMB addresses.  }

    Procedure Pointer_Swap(var A,B : Pointer);
      var
        Temp : Pointer;
      Begin
        Temp := A;
        A := B;
        B := Temp;
      End;

    {----------------------------------------------------------------------------}

    Function XMS_Driver_Present : Boolean;  { XMS software present? }
      var
        Result : Boolean;
      Begin
        Result := False;      { Assume no XMS driver }
        asm
          @Begin:
            mov ax,4300h
            int 2Fh
            cmp al,80h
            jne @Fail
            mov ax,4310h
            int 2Fh
            mov word ptr XMS_Driver+2,es       { Get the XMS driver entry point }
            mov word ptr XMS_Driver,bx
            mov Result,1
            jmp @End
          @Fail:
            mov Result,0
          @End:
        end;
        XMS_Driver_Present := Result;
      End;

    {----------------------------------------------------------------------------}

    Procedure Allocate_UMB_Heap;         { Add the four largest UMBs to the heap }
      var
        i,j : Word;
        UMB_Strategy,
        DOS_Strategy,
        Segment,Size : Word;
        Get_Direct : Boolean;   { Get UMB direct from XMS if TRUE, else from DOS }
      Begin
        Num_Blocks := 0;

        for i := 1 to Max_Blocks do
          begin
            Block_Address[i] := nil;
            Block_Size[i] := nil;
          end;

        asm
          mov ax,5800h
          int 21h                     { Get and save the DOS allocation strategy }
          mov [DOS_Strategy],ax
          mov ax,5802h
          int 21h                     { Get and save the UMB allocation strategy }
          mov [UMB_Strategy],ax
          mov ax,5801h
          mov bx,0000h
          int 21h                      { Set the DOS allocation strategy so that }
          mov ax,5803h                 { it uses only high memory                }

                                       { DON'T TRUST THIS FUNCTION.  DOS WILL GO }
                                       { AHEAD AND TRY TO ALLOCATE LOWER MEMORY  }
                                       { EVEN AFTER YOU TELL IT NOT TO!          }
          mov bx,0001h
          int 21h                      { Set the UMB allocation strategy so that }
        end;                           { UMBs are added to the DOS mem chain     }

        Get_Direct := True;            { Try to get UMBs directly from the XMS   }
                                       { if possible.                            }
        for i := 1 to Max_Blocks do
          begin
            Segment := 0;
            Size := 0;

            if Get_Direct then         { Get a UMB direct from the XMS driver.   }
              begin
                asm
                  @Begin:
                    mov ax,01000h
                    mov dx,0FFFFh         { Ask for the impossible to ...        }
                    push ds               { Get the size of the next largest UMB }
                    mov cx,ds
                    mov es,cx
                    call es:[XMS_Driver]
                    cmp dx,100h           { Don't bother with anything < 1K      }
                    jl @End
                    mov ax,01000h
                    call es:[XMS_Driver]  { Get the next largest UMB }
                    cmp ax,1
                    jne @End
                    cmp bx,0A000h         { It better be above 640K }
                    jl @End               { We can't trust DOS 5.00 }
                    mov [Segment],bx
                    mov [Size],dx
                  @End:
                    pop ds
                end;
                if ((i = 1) and (Size = 0)) then  { if we couldn't get the UMB  }
                  Get_Direct := False;            { from the XMS driver, don't  }
              end;                                { try again the next time.    }

            if (not Get_Direct) then   { Get a UMB via DOS }
              begin
                asm
                  @Begin:
                    mov ax,4800h
                    mov bx,0FFFFh         { Ask for the impossible to ...        }
                    int 21h               { Get the size of the next largest UMB }
                    cmp bx,100h           { Don't bother with anything < 1K      }
                    jl @End
                    mov ax,4800h
                    int 21h               { Get the next largest UMB }
                    jc @End
                    cmp ax,0A000h         { It better be above 640K }
                    jl @End               { We can't trust DOS 5.00 }
                    mov [Segment],ax
                    mov [Size],bx
                  @End:
                end;
              end;

            if (Segment > 0) then                      { Did it work? }
              begin
                Block_Address[i] := Ptr(Segment,0);
                Inc(Num_Blocks);
              end;
            Block_Size[i] := Ptr(Size,0);
          end;
        if (Num_Blocks > 0) then               { Sort the UMB addrs in ASC order }
          begin
            for i := 1 to Num_Blocks-1 do
              for j := i+1 to Num_Blocks do
                if (Seg(Block_Address[i]^) > Seg(Block_Address[j]^)) then
                  begin
                    Pointer_Swap(Block_Address[i],Block_Address[j]);
                    Pointer_Swap(Block_Size[i],Block_Size[j]);
                  end;
          end;
        asm
          mov ax,5803h
          mov bx,[UMB_Strategy]
          int 21h                          { Restore the UMB allocation strategy }
          mov ax,5801h
          mov bx,[DOS_Strategy]
          int 21h                          { Restore the DOS allocation strategy }
        end;
      End;

    {----------------------------------------------------------------------------}

    Procedure Release_UMB; far;                 { Exit procedure to release UMBs }
      var
        i : Word;
        Segment : Word;
      Begin
        ExitProc := SaveExitProc;
        if (Num_Blocks > 0) then
          begin
            asm
              mov ax,5803h
              mov bx,0000h
              int 21h                       { Set the UMB status to release UMBs }
            end;
            for i := 1 to Num_Blocks do
              begin
                Segment := Seg(Block_Address[i]^);
                if (Segment > 0) then
                  asm
                    mov ax,$4901
                    mov bx,[Segment]
                    mov es,bx
                    int 21h                                    { Release the UMB }
                  end;
              end;
          end;
      End;

    {----------------------------------------------------------------------------}

    Procedure Extend_Heap;
      var
        i : Word;
        Temp : PFreeRec;
      Begin
        if XMS_Driver_Present then
          begin
            Allocate_UMB_Heap;
            if UMB_Heap_Debug then
              Release_UMB;
            if (Num_Blocks > 0) then
              begin                             { Attach UMBs to the FreeList    }
                for i := 1 to Num_Blocks do
                  PFreeRec(Block_Address[i])^.Size := Block_Size[i];
                for i := 1 to Num_Blocks do
                  PFreeRec(Block_Address[i])^.Next := Block_Address[i+1];

                PFreeRec(Block_Address[Num_Blocks])^.Next := nil;

                if (FreeList = HeapPtr) then
                  with PFreeRec(FreeList)^ do
                    begin
                      Next := Block_Address[1];
                      Size := Ptr(Seg(HeapEnd^)-Seg(HeapPtr^),0);
                    end
                else
                  with PFreeRec(HeapPtr)^ do
                    begin
                      Next := Block_Address[1];
                      Size := Ptr(Seg(HeapEnd^)-Seg(HeapPtr^),0);
                    end;

                { HEAPPTR MUST BE IN THE LAST FREE BLOCK SO
                  THAT TP6 DOESN'T TRY TO USE ANY MEMORY BETWEEN
                  640K AND HEAPPTR }

                HeapPtr := Block_Address[Num_Blocks];
                HeapEnd := Ptr(Seg(Block_Address[Num_Blocks]^)+Seg(Block_Size[Num_Blocks]^),0);
              end;
          end;
      End;

    {----------------------------------------------------------------------------}

    BEGIN
      UMB_Heap_Debug := False;
      Num_Blocks := 0;
      SaveExitProc := ExitProc;
      ExitProc := @Release_UMB;
    END.

    {----------------------------------------------------------------------------}

[Back to MEMORY SWAG index] [Back to Main SWAG index] [Original]