{ Heap management routines

  Copyright (C) 1991-2002 Free Software Foundation, Inc.

  Authors: Jukka Virtanen <jtv@hut.fi>
           Frank Heckenbach <frank@pascal.gnu.de>

  This file is part of GNU Pascal.

  GNU Pascal is free software; you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published
  by the Free Software Foundation; either version 2, or (at your
  option) any later version.

  GNU Pascal is distributed in the hope that it will be useful, but
  WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with GNU Pascal; see the file COPYING. If not, write to the
  Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
  02111-1307, USA.

  As a special exception, if you link this file with files compiled
  with a GNU compiler to produce an executable, this does not cause
  the resulting executable to be covered by the GNU General Public
  License. This exception does not however invalidate any other
  reasons why the executable file might be covered by the GNU
  General Public License. }

{$gnu-pascal,I-}

unit Heap; asmname 'GPC';

interface

uses RTSC, Error;

{ GPC implements both Mark/Release and Dispose. Both can be mixed
  freely in the same program. Dispose should be preferred, since
  it's faster. }

{ C heap management routines. NOTE: if Release is used anywhere in
  the program, CFreeMem and CReAllocMem may not be used for pointers
  that were not allocated with CGetMem. }
function  CGetMem     (Size: SizeType): Pointer;                       asmname 'malloc';
procedure CFreeMem    (aPointer: Pointer);                             asmname 'free';
function  CReAllocMem (aPointer: Pointer; NewSize: SizeType): Pointer; asmname 'realloc';

type
  GetMemType     = ^function (Size: SizeType): Pointer;
  FreeMemType    = ^procedure (aPointer: Pointer);
  ReAllocMemType = ^function (aPointer: Pointer; NewSize: SizeType): Pointer;

{ These variables can be set to user-defined routines for memory
  allocation/deallocation. GetMemPtr may return nil when
  insufficient memory is available. GetMem/New will produce a
  runtime error then. }
var
  GetMemPtr    : GetMemType     = @CGetMem;     asmname '_p_getmem_ptr';
  FreeMemPtr   : FreeMemType    = @CFreeMem;    asmname '_p_freemem_ptr';
  ReAllocMemPtr: ReAllocMemType = @CReAllocMem; asmname '_p_reallocmem_ptr';

  { Points to the lowest byte of heap used }
  HeapBegin: Pointer = nil; asmname '_p_heap_begin';

  { Points to the highest byte of heap used }
  HeapHigh : Pointer = nil; asmname '_p_heap_high';

const
  UndocumentedReturnNil = Pointer (-1);

{@internal}
procedure GPC_Mark     (var aMark: Pointer);       asmname '_p_mark';
procedure GPC_Release  (aMark: Pointer);           asmname '_p_release';

{ GPC_New, GPC_Dispose and ReAllocMem call the actual routines
  through GetMemPtr, FreeMemPtr and ReAllocMemPtr, and do the stuff
  necessary for Mark and Release. New, GetMem and Dispose, FreeMem
  in a Pascal program will call GPC_New and GPC_Dispose,
  respectively, internally. }
function  GPC_New      (Size: SizeType): Pointer;  asmname '_p_new';
procedure GPC_Dispose  (aPointer: Pointer);        asmname '_p_dispose';
{@endinternal}

{ Calls the procedure Proc for each block that would be released
  with `Release (aMark)'. aMark must have been marked with Mark. For
  an example of its usage, see the HeapMon unit. }
procedure ForEachMarkedBlock (aMark: Pointer; procedure Proc (aPointer: Pointer; aSize: SizeType; aCaller: Pointer)); asmname '_p_foreachmarkedblock';

procedure ReAllocMem (var aPointer: Pointer; NewSize: SizeType); asmname '_p_reallocmem';

implementation

type
  PMarkList = ^TMarkList;
  TMarkList = record
    Next, Prev  : PMarkList;
    Marked      : Boolean;
    MaxIndexUsed,
    PointersUsed: Integer;
    Entries     : array [0 .. 255] of record
      Ptr   : Pointer;
      PSize : SizeType;
      Caller: Pointer
    end
  end;

var
  CurrentMarkList: PMarkList = nil;

procedure GPC_Mark (var aMark: Pointer);
var Temp: PMarkList;
begin
  SetReturnAddress (ReturnAddress (0));
  Temp := GetMemPtr^ (SizeOf (Temp^));  { don't use `New' here! }
  if (Temp = nil) or (Temp = UndocumentedReturnNil) then
    RuntimeErrorInteger (853, SizeOf (Temp^));  { out of heap when allocating %d bytes }
  RestoreReturnAddress;
  Temp^.Next := CurrentMarkList;
  Temp^.Prev := nil;
  if CurrentMarkList <> nil then CurrentMarkList^.Prev := Temp;
  Temp^.MaxIndexUsed := 0;
  Temp^.PointersUsed := 0;
  Temp^.Marked := @aMark <> nil;
  CurrentMarkList := Temp;
  if @aMark <> nil then aMark := Temp  { GPC_New calls GPC_Mark (Null) }
end;

procedure GPC_Release (aMark: Pointer);
var
  Temp: PMarkList;
  i: Integer;
begin
  Temp := CurrentMarkList;
  while (Temp <> nil) and (Temp <> aMark) do Temp := Temp^.Next;
  if Temp = nil then
    begin
      SetReturnAddress (ReturnAddress (0));
      RuntimeErrorInteger (852, PtrCard (aMark));  { address % is not valid for `Release' }
      RestoreReturnAddress
    end;
  repeat
    for i := CurrentMarkList^.MaxIndexUsed - 1 downto 0 do
      if CurrentMarkList^.Entries[i].Ptr <> nil then
        FreeMemPtr^ (CurrentMarkList^.Entries[i].Ptr);
    Temp := CurrentMarkList;
    CurrentMarkList := CurrentMarkList^.Next;
    FreeMemPtr^ (Temp)
  until Temp = aMark;
  if CurrentMarkList <> nil then CurrentMarkList^.Prev := nil
end;

procedure ForEachMarkedBlock (aMark: Pointer; procedure Proc (aPointer: Pointer; aSize: SizeType; aCaller: Pointer));
var
  Temp, Last: PMarkList;
  i: Integer;
begin
  Temp := CurrentMarkList;
  Last := nil;
  while (Temp <> nil) and (Last <> aMark) do
    begin
      for i := Temp^.MaxIndexUsed - 1 downto 0 do
        with Temp^.Entries[i] do
          if (Ptr <> nil) and (Caller <> DummyReturnAddress) then Proc (Ptr, PSize, Caller);
      Last := Temp;
      Temp := Temp^.Next
    end
end;

procedure SetHeapHigh (p: Pointer; Size: SizeType);
type
  PBytes = ^TBytes;
  TBytes = array [0 .. MaxVarSize div SizeOf (Byte)] of Byte;
var
  pEnd: Pointer;
begin
  pEnd := @PBytes (p)^[Size - 1];
  if PtrCard (pEnd) > PtrCard (HeapHigh) then HeapHigh := pEnd;
end;

procedure AddToMarkList (p: Pointer; Size: SizeType; aCaller: Pointer);
begin
  if CurrentMarkList^.MaxIndexUsed > High (CurrentMarkList^.Entries) then
    GPC_Mark (Null);  { this creates a new TMarkList item }
  with CurrentMarkList^.Entries[CurrentMarkList^.MaxIndexUsed] do
    begin
      Ptr := p;
      PSize := Size;
      Caller := aCaller
    end;
  Inc (CurrentMarkList^.MaxIndexUsed);
  Inc (CurrentMarkList^.PointersUsed)
end;

procedure RemoveFromMarkList (aPointer: Pointer);
var
  p: PMarkList;
  Found: Boolean;
  i: Integer;
begin
  if aPointer = nil then Exit;
  Found := False;
  p := CurrentMarkList;
  while (p <> nil) and not Found do
    begin
      if p^.MaxIndexUsed <> 0 then
        for i := p^.MaxIndexUsed - 1 downto 0 do
          if p^.Entries[i].Ptr = aPointer then
            begin
              p^.Entries[i].Ptr := nil;
              Dec (p^.PointersUsed);
              if (p^.PointersUsed = 0) and not p^.Marked then
                begin
                  if CurrentMarkList = p then CurrentMarkList := p^.Next;
                  if p^.Prev <> nil then p^.Prev^.Next := p^.Next;
                  if p^.Next <> nil then p^.Next^.Prev := p^.Prev;
                  FreeMemPtr^ (p)
                end
              else if i = p^.MaxIndexUsed - 1 then
                Dec (p^.MaxIndexUsed);
              Found := True;
              Break
            end;
      p := p^.Next
    end
end;

function GPC_New (Size: SizeType) = p: Pointer;
begin
  p := GetMemPtr^ (Size);
  if (p = nil) and (Size <> 0) then
    begin
      SetReturnAddress (ReturnAddress (0));
      RuntimeErrorInteger (853, Size);  { out of heap when allocating %d bytes }
      RestoreReturnAddress
    end;
  if p = UndocumentedReturnNil then Return nil;
  SetHeapHigh (p, Size);
  if CurrentMarkList <> nil then
    begin
      SetReturnAddress (ReturnAddress (0));
      if CurrentReturnAddr <> nil
        then AddToMarkList (p, Size, CurrentReturnAddr)
        else AddToMarkList (p, Size, ReturnAddress (0));
      RestoreReturnAddress
    end
end;

procedure GPC_Dispose (aPointer: Pointer);
begin
  RemoveFromMarkList (aPointer);
  if aPointer <> nil then FreeMemPtr^ (aPointer)
end;

procedure ReAllocMem (var aPointer: Pointer; NewSize: SizeType);
begin
  RemoveFromMarkList (aPointer);
  aPointer := ReallocMemPtr^ (aPointer, NewSize);
  if (aPointer = nil) or (aPointer = UndocumentedReturnNil) then
    begin
      SetReturnAddress (ReturnAddress (0));
      RuntimeErrorInteger (854, NewSize);  { out of heap when reallocating %ld bytes }
      RestoreReturnAddress
    end;
  SetHeapHigh (aPointer, NewSize);
  if CurrentMarkList <> nil then
    begin
      SetReturnAddress (ReturnAddress (0));
      if CurrentReturnAddr <> nil
        then AddToMarkList (aPointer, NewSize, CurrentReturnAddr)
        else AddToMarkList (aPointer, NewSize, ReturnAddress (0));
      RestoreReturnAddress
    end
end;

begin
  InitMalloc (HeapWarning);
  HeapBegin := GPC_New (1);
  HeapHigh := HeapBegin
end.
