paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-15 20:29:17 +02:00
Code Issues Packages Projects Releases Wiki Activity

* cmem moved to rtl

Browse Source 
* longint replaced with ptrint in heapmanagers
This commit is contained in:
peter 2004-03-15 21:48:26 +00:00
parent afe7a7b69c
commit abfc396c40
12 changed files with 415 additions and 173 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
rtl/darwin/Makefile
View File

@ -1,5 +1,5 @@
# #
# Don't edit, this file is generated by FPCMake Version 1.1 [2004/01/05] # Don't edit, this file is generated by FPCMake Version 1.1 [2004/03/15]
# #
default: all default: all
MAKEFILETARGETS=linux go32v2 win32 os2 freebsd beos netbsd amiga atari sunos qnx netware openbsd wdosx palmos macos darwin emx watcom MAKEFILETARGETS=linux go32v2 win32 os2 freebsd beos netbsd amiga atari sunos qnx netware openbsd wdosx palmos macos darwin emx watcom
@ -185,11 +185,14 @@ override FPCDIR:=$(FPCDIR)/..
ifeq ($(wildcard $(addprefix $(FPCDIR)/,rtl units)),) ifeq ($(wildcard $(addprefix $(FPCDIR)/,rtl units)),)
override FPCDIR:=$(FPCDIR)/.. override FPCDIR:=$(FPCDIR)/..
ifeq ($(wildcard $(addprefix $(FPCDIR)/,rtl units)),) ifeq ($(wildcard $(addprefix $(FPCDIR)/,rtl units)),)
override FPCDIR:=$(BASEDIR)
ifeq ($(wildcard $(addprefix $(FPCDIR)/,rtl units)),)
override FPCDIR=c:/pp override FPCDIR=c:/pp
endif endif
endif endif
endif endif
endif endif
endif
ifndef CROSSDIR ifndef CROSSDIR
CROSSDIR:=$(FPCDIR)/cross/$(FULL_TARGET) CROSSDIR:=$(FPCDIR)/cross/$(FULL_TARGET)
endif endif
@ -229,7 +232,7 @@ GRAPHDIR=$(INC)/graph
ifndef USELIBGGI ifndef USELIBGGI
USELIBGGI=NO USELIBGGI=NO
endif endif
override TARGET_UNITS+=$(SYSTEMUNIT) objpas strings sysctl baseunix unixtype unixutil unix initc dos dl objects printer sysutils typinfo systhrds classes math varutils charset ucomplex getopts heaptrc lineinfo errors terminfo termio video crt mouse keyboard console variants types sysctl dateutils sysconst cthreads strutils rtlconst override TARGET_UNITS+=$(SYSTEMUNIT) objpas strings sysctl baseunix unixtype unixutil unix initc cmem dos dl objects printer sysutils typinfo systhrds classes math varutils charset ucomplex getopts heaptrc lineinfo errors terminfo termio video crt mouse keyboard console variants types sysctl dateutils sysconst cthreads strutils rtlconst
override TARGET_RSTS+=math varutils typinfo classes variants dateutils systhrds sysconst rtlconst override TARGET_RSTS+=math varutils typinfo classes variants dateutils systhrds sysconst rtlconst
override INSTALL_FPCPACKAGE=y override INSTALL_FPCPACKAGE=y
override COMPILER_INCLUDEDIR+=$(INC) $(PROCINC) $(UNIXINC) $(BSDINC) $(BSDPROCINC) $(OSPROCINC) override COMPILER_INCLUDEDIR+=$(INC) $(PROCINC) $(UNIXINC) $(BSDINC) $(BSDPROCINC) $(OSPROCINC)
@ -544,7 +547,8 @@ ZIPSUFFIX=nw
endif endif
ifeq ($(OS_TARGET),macos) ifeq ($(OS_TARGET),macos)
EXEEXT= EXEEXT=
FPCMADE=fpcmade.mcc FPCMADE=fpcmade.macos
ZIPSUFFIX=macos
endif endif
ifeq ($(OS_TARGET),darwin) ifeq ($(OS_TARGET),darwin)
EXEEXT= EXEEXT=
@ -843,9 +847,11 @@ ARNAME=$(BINUTILSPREFIX)ar
RCNAME=$(BINUTILSPREFIX)rc RCNAME=$(BINUTILSPREFIX)rc
ifneq ($(findstring 1.0.,$(FPC_VERSION)),) ifneq ($(findstring 1.0.,$(FPC_VERSION)),)
ifeq ($(OS_TARGET),win32) ifeq ($(OS_TARGET),win32)
ASNAME=as ifeq ($(CROSSBINDIR),)
LDNAME=ld ASNAME=asw
ARNAME=ar LDNAME=ldw
ARNAME=arw
endif
endif endif
endif endif
ifndef ASPROG ifndef ASPROG
@ -1393,5 +1399,6 @@ errors$(PPUEXT) : $(UNIXINC)/errors.pp strings$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
ipc$(PPUEXT) : $(UNIXINC)/ipc.pp unix$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT) ipc$(PPUEXT) : $(UNIXINC)/ipc.pp unix$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
terminfo$(PPUEXT) : terminfo.pp unix$(PPUEXT) terminfo$(PPUEXT) : terminfo.pp unix$(PPUEXT)
callspec$(PPUEXT) : $(INC)/callspec.pp $(SYSTEMUNIT)$(PPUEXT) callspec$(PPUEXT) : $(INC)/callspec.pp $(SYSTEMUNIT)$(PPUEXT)
cmem$(PPUEXT) : $(INC)/cmem.pp $(SYSTEMUNIT)$(PPUEXT)
sysctl$(PPUEXT) : $(BSDINC)/sysctl.pp $(SYSTEMUNIT)$(PPUEXT) sysctl$(PPUEXT) : $(BSDINC)/sysctl.pp $(SYSTEMUNIT)$(PPUEXT)
cthreads$(PPUEXT) : $(UNIXINC)/cthreads.pp systhrds$(PPUEXT) cthreads$(PPUEXT) : $(UNIXINC)/cthreads.pp systhrds$(PPUEXT)

3
rtl/darwin/Makefile.fpc
View File

@ -9,7 +9,7 @@ main=rtl
[target] [target]
loaders= loaders=
units=$(SYSTEMUNIT) objpas strings sysctl baseunix unixtype unixutil \ units=$(SYSTEMUNIT) objpas strings sysctl baseunix unixtype unixutil \
unix initc \ unix initc cmem \
dos dl objects printer \ dos dl objects printer \
sysutils typinfo systhrds classes math varutils \ sysutils typinfo systhrds classes math varutils \
charset ucomplex getopts heaptrc lineinfo \ charset ucomplex getopts heaptrc lineinfo \
@ -230,6 +230,7 @@ terminfo$(PPUEXT) : terminfo.pp unix$(PPUEXT)
callspec$(PPUEXT) : $(INC)/callspec.pp $(SYSTEMUNIT)$(PPUEXT) callspec$(PPUEXT) : $(INC)/callspec.pp $(SYSTEMUNIT)$(PPUEXT)
cmem$(PPUEXT) : $(INC)/cmem.pp $(SYSTEMUNIT)$(PPUEXT)
sysctl$(PPUEXT) : $(BSDINC)/sysctl.pp $(SYSTEMUNIT)$(PPUEXT) sysctl$(PPUEXT) : $(BSDINC)/sysctl.pp $(SYSTEMUNIT)$(PPUEXT)

19
rtl/freebsd/Makefile
View File

@ -1,5 +1,5 @@
# #
# Don't edit, this file is generated by FPCMake Version 1.1 [2004/01/05] # Don't edit, this file is generated by FPCMake Version 1.1 [2004/03/15]
# #
default: all default: all
MAKEFILETARGETS=linux go32v2 win32 os2 freebsd beos netbsd amiga atari sunos qnx netware openbsd wdosx palmos macos darwin emx watcom MAKEFILETARGETS=linux go32v2 win32 os2 freebsd beos netbsd amiga atari sunos qnx netware openbsd wdosx palmos macos darwin emx watcom
@ -185,11 +185,14 @@ override FPCDIR:=$(FPCDIR)/..
ifeq ($(wildcard $(addprefix $(FPCDIR)/,rtl units)),) ifeq ($(wildcard $(addprefix $(FPCDIR)/,rtl units)),)
override FPCDIR:=$(FPCDIR)/.. override FPCDIR:=$(FPCDIR)/..
ifeq ($(wildcard $(addprefix $(FPCDIR)/,rtl units)),) ifeq ($(wildcard $(addprefix $(FPCDIR)/,rtl units)),)
override FPCDIR:=$(BASEDIR)
ifeq ($(wildcard $(addprefix $(FPCDIR)/,rtl units)),)
override FPCDIR=c:/pp override FPCDIR=c:/pp
endif endif
endif endif
endif endif
endif endif
endif
ifndef CROSSDIR ifndef CROSSDIR
CROSSDIR:=$(FPCDIR)/cross/$(FULL_TARGET) CROSSDIR:=$(FPCDIR)/cross/$(FULL_TARGET)
endif endif
@ -232,7 +235,7 @@ GRAPHDIR=$(INC)/graph
ifndef USELIBGGI ifndef USELIBGGI
USELIBGGI=NO USELIBGGI=NO
endif endif
override TARGET_UNITS+=$(SYSTEMUNIT) objpas strings syscall sysctl unixtype baseunix unixutil unix rtlconst initc dos dl termio objects printer sysutils typinfo systhrds types classes math varutils cpu mmx charset ucomplex crt getopts heaptrc lineinfo errors sockets gpm ipc terminfo video mouse keyboard console serial variants sysctl dateutils sysconst cthreads override TARGET_UNITS+=$(SYSTEMUNIT) objpas strings syscall sysctl unixtype baseunix unixutil unix rtlconst initc cmem dos dl termio objects printer sysutils typinfo systhrds types classes math varutils cpu mmx charset ucomplex crt getopts heaptrc lineinfo errors sockets gpm ipc terminfo video mouse keyboard console serial variants sysctl dateutils sysconst cthreads
override TARGET_LOADERS+=prt0 cprt0 gprt0 override TARGET_LOADERS+=prt0 cprt0 gprt0
override TARGET_RSTS+=math varutils typinfo classes variants dateutils sysconst override TARGET_RSTS+=math varutils typinfo classes variants dateutils sysconst
override INSTALL_FPCPACKAGE=y y override INSTALL_FPCPACKAGE=y y
@ -548,7 +551,8 @@ ZIPSUFFIX=nw
endif endif
ifeq ($(OS_TARGET),macos) ifeq ($(OS_TARGET),macos)
EXEEXT= EXEEXT=
FPCMADE=fpcmade.mcc FPCMADE=fpcmade.macos
ZIPSUFFIX=macos
endif endif
ifeq ($(OS_TARGET),darwin) ifeq ($(OS_TARGET),darwin)
EXEEXT= EXEEXT=
@ -847,9 +851,11 @@ ARNAME=$(BINUTILSPREFIX)ar
RCNAME=$(BINUTILSPREFIX)rc RCNAME=$(BINUTILSPREFIX)rc
ifneq ($(findstring 1.0.,$(FPC_VERSION)),) ifneq ($(findstring 1.0.,$(FPC_VERSION)),)
ifeq ($(OS_TARGET),win32) ifeq ($(OS_TARGET),win32)
ASNAME=as ifeq ($(CROSSBINDIR),)
LDNAME=ld ASNAME=asw
ARNAME=ar LDNAME=ldw
ARNAME=arw
endif
endif endif
endif endif
ifndef ASPROG ifndef ASPROG
@ -1415,5 +1421,6 @@ errors$(PPUEXT) : $(UNIXINC)/errors.pp strings$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
ipc$(PPUEXT) : $(UNIXINC)/ipc.pp unix$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT) ipc$(PPUEXT) : $(UNIXINC)/ipc.pp unix$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
terminfo$(PPUEXT) : terminfo.pp unix$(PPUEXT) terminfo$(PPUEXT) : terminfo.pp unix$(PPUEXT)
callspec$(PPUEXT) : $(INC)/callspec.pp $(SYSTEMUNIT)$(PPUEXT) callspec$(PPUEXT) : $(INC)/callspec.pp $(SYSTEMUNIT)$(PPUEXT)
cmem$(PPUEXT) : $(INC)/cmem.pp $(SYSTEMUNIT)$(PPUEXT)
sysctl$(PPUEXT) : $(BSDINC)/sysctl.pp $(SYSTEMUNIT)$(PPUEXT) sysctl$(PPUEXT) : $(BSDINC)/sysctl.pp $(SYSTEMUNIT)$(PPUEXT)
cthreads$(PPUEXT) : $(UNIXINC)/cthreads.pp systhrds$(PPUEXT) cthreads$(PPUEXT) : $(UNIXINC)/cthreads.pp systhrds$(PPUEXT)

3
rtl/freebsd/Makefile.fpc
View File

@ -11,7 +11,7 @@ fpcpackage=y
[target] [target]
loaders=prt0 cprt0 gprt0 loaders=prt0 cprt0 gprt0
units=$(SYSTEMUNIT) objpas strings syscall sysctl unixtype baseunix unixutil \ units=$(SYSTEMUNIT) objpas strings syscall sysctl unixtype baseunix unixutil \
unix rtlconst initc \ unix rtlconst initc cmem \
dos dl termio objects printer \ dos dl termio objects printer \
sysutils typinfo systhrds types classes math varutils \ sysutils typinfo systhrds types classes math varutils \
cpu mmx charset ucomplex crt getopts heaptrc lineinfo \ cpu mmx charset ucomplex crt getopts heaptrc lineinfo \
@ -241,6 +241,7 @@ terminfo$(PPUEXT) : terminfo.pp unix$(PPUEXT)
callspec$(PPUEXT) : $(INC)/callspec.pp $(SYSTEMUNIT)$(PPUEXT) callspec$(PPUEXT) : $(INC)/callspec.pp $(SYSTEMUNIT)$(PPUEXT)
cmem$(PPUEXT) : $(INC)/cmem.pp $(SYSTEMUNIT)$(PPUEXT)
sysctl$(PPUEXT) : $(BSDINC)/sysctl.pp $(SYSTEMUNIT)$(PPUEXT) sysctl$(PPUEXT) : $(BSDINC)/sysctl.pp $(SYSTEMUNIT)$(PPUEXT)

202
rtl/inc/cmem.pp Normal file
View File

@ -0,0 +1,202 @@
{
$Id$
This file is part of the Free Pascal run time library.
Copyright (c) 1999 by Michael Van Canneyt, member of the
Free Pascal development team
Implements a memory manager that uses the C memory management.
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program 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.
**********************************************************************}
unit cmem;
{$mode objfpc}
interface
Const
{$ifndef win32}
{$ifdef netware}
LibName = 'clib';
{$else}
LibName = 'c';
{$endif}
{$else}
LibName = 'msvcrt';
{$endif}
Function Malloc (Size : ptrint) : Pointer; {$ifdef win32}stdcall{$else}cdecl{$endif}; external LibName name 'malloc';
Procedure Free (P : pointer); {$ifdef win32}stdcall{$else}cdecl{$endif}; external LibName name 'free';
function ReAlloc (P : Pointer; Size : ptrint) : pointer; {$ifdef win32}stdcall{$else}cdecl{$endif}; external LibName name 'realloc';
Function CAlloc (unitSize,UnitCount : ptrint) : pointer; {$ifdef win32}stdcall{$else}cdecl{$endif}; external LibName name 'calloc';
implementation
type
pptrint = ^ptrint;
Function CGetMem (Size : ptrint) : Pointer;
begin
result:=Malloc(Size+sizeof(ptrint));
if (result <> nil) then
begin
pptrint(result)^ := size;
inc(result,sizeof(ptrint));
end;
end;
Function CFreeMem ({$ifdef VER1_0}var{$endif} P : pointer) : ptrint;
begin
if (p <> nil) then
dec(p,sizeof(ptrint));
Free(P);
Result:=0;
end;
Function CFreeMemSize({$ifdef VER1_0}var{$endif} p:pointer;Size:ptrint):ptrint;
begin
if (p <> nil) then
begin
if (size <> pptrint(p-sizeof(ptrint))^) then
runerror(204);
end;
Result:=CFreeMem(P);
end;
Function CAllocMem(Size : ptrint) : Pointer;
begin
Result:=calloc(Size+sizeof(ptrint),1);
if (result <> nil) then
begin
pptrint(result)^ := size;
inc(result,sizeof(ptrint));
end;
end;
Function CReAllocMem (var p:pointer;Size:ptrint):Pointer;
begin
if size=0 then
begin
if p<>nil then
begin
free(p);
p:=nil;
end;
end
else
begin
inc(size,sizeof(ptrint));
if p=nil then
p:=calloc(Size,1)
else
begin
dec(p,sizeof(ptrint));
p:=realloc(p,size);
end;
if (p <> nil) then
begin
pptrint(p)^ := size-sizeof(ptrint);
inc(p,sizeof(ptrint));
end;
end;
Result:=p;
end;
Function CMemSize (p:pointer): ptrint;
begin
Result:=pptrint(p-sizeof(ptrint))^;
end;
Function CMemAvail : ptrint;
begin
Result:=0;
end;
Function CMaxAvail: ptrint;
begin
Result:=0;
end;
Function CHeapSize : ptrint;
begin
Result:=0;
end;
Const
CMemoryManager : TMemoryManager =
(
{$ifndef VER1_0}
NeedLock : false;
{$endif VER1_0}
GetMem : {$ifdef fpc}@{$endif}CGetmem;
FreeMem : {$ifdef fpc}@{$endif}CFreeMem;
FreememSize : {$ifdef fpc}@{$endif}CFreememSize;
AllocMem : {$ifdef fpc}@{$endif}CAllocMem;
ReallocMem : {$ifdef fpc}@{$endif}CReAllocMem;
MemSize : {$ifdef fpc}@{$endif}CMemSize;
MemAvail : {$ifdef fpc}@{$endif fpc}CMemAvail;
MaxAvail : {$ifdef fpc}@{$endif}MaxAvail;
HeapSize : {$ifdef fpc}@{$endif}CHeapSize;
);
Var
OldMemoryManager : TMemoryManager;
Initialization
GetMemoryManager (OldMemoryManager);
SetMemoryManager (CmemoryManager);
Finalization
SetMemoryManager (OldMemoryManager);
end.
{
$Log$
Revision 1.1 2004-03-15 21:48:26 peter
* cmem moved to rtl
* longint replaced with ptrint in heapmanagers
Revision 1.9 2004/03/12 13:08:08 jonas
+ added memsize() support (needed to use cmem with the compiler)
Revision 1.8 2003/03/17 15:40:05 armin
+ LibName for netware
Revision 1.7 2002/11/01 17:56:39 peter
* needlock field added for 1.1
Revision 1.6 2002/09/08 15:43:47 michael
+ Fixed calling conventions
Revision 1.5 2002/09/07 15:42:54 peter
* old logs removed and tabs fixed
Revision 1.4 2002/07/01 16:24:04 peter
* updates for 1.0 compiler
Revision 1.3 2002/06/13 05:01:44 michael
+ Added windows msvcrt support
Revision 1.2 2002/06/13 04:54:47 michael
+ Fixed parameter type mismatch
Revision 1.1 2002/01/29 17:54:59 peter
* splitted to base and extra
}

86
rtl/inc/heap.inc
View File

@ -86,7 +86,7 @@ type
ppfreerecord = ^pfreerecord; ppfreerecord = ^pfreerecord;
pfreerecord = ^tfreerecord; pfreerecord = ^tfreerecord;
tfreerecord = record tfreerecord = record
size : longint; size : ptrint;
next, next,
prev : pfreerecord; prev : pfreerecord;
end; { 12 bytes } end; { 12 bytes }
@ -94,7 +94,7 @@ type
pheaprecord = ^theaprecord; pheaprecord = ^theaprecord;
theaprecord = record theaprecord = record
{ this should overlap with tfreerecord } { this should overlap with tfreerecord }
size : longint; size : ptrint;
end; { 4 bytes } end; { 4 bytes }
tfreelists = array[0..maxblock] of pfreerecord; tfreelists = array[0..maxblock] of pfreerecord;
@ -104,8 +104,8 @@ type
pfreelists = ^tfreelists; pfreelists = ^tfreelists;
var var
internal_memavail : longint; internal_memavail : ptrint;
internal_heapsize : longint; internal_heapsize : ptrint;
freelists : tfreelists; freelists : tfreelists;
before_heapend_block : pfreerecord; before_heapend_block : pfreerecord;
{$ifdef SYSTEMDEBUG} {$ifdef SYSTEMDEBUG}
@ -189,7 +189,7 @@ begin
end; end;
procedure GetMem(Var p:pointer;Size:Longint); procedure GetMem(Var p:pointer;Size:ptrint);
begin begin
if IsMultiThread and MemoryManager.NeedLock then if IsMultiThread and MemoryManager.NeedLock then
begin begin
@ -206,12 +206,12 @@ begin
end; end;
end; end;
procedure GetMemory(Var p:pointer;Size:Longint); procedure GetMemory(Var p:pointer;Size:ptrint);
begin begin
GetMem(p,size); GetMem(p,size);
end; end;
procedure FreeMem(p:pointer;Size:Longint); procedure FreeMem(p:pointer;Size:ptrint);
begin begin
if IsMultiThread and MemoryManager.NeedLock then if IsMultiThread and MemoryManager.NeedLock then
begin begin
@ -228,12 +228,12 @@ begin
end; end;
end; end;
procedure FreeMemory(p:pointer;Size:Longint); procedure FreeMemory(p:pointer;Size:ptrint);
begin begin
FreeMem(p,size); FreeMem(p,size);
end; end;
function MaxAvail:Longint; function MaxAvail:ptrint;
begin begin
if IsMultiThread and MemoryManager.NeedLock then if IsMultiThread and MemoryManager.NeedLock then
begin begin
@ -251,7 +251,7 @@ begin
end; end;
function MemAvail:Longint; function MemAvail:ptrint;
begin begin
if IsMultiThread and MemoryManager.NeedLock then if IsMultiThread and MemoryManager.NeedLock then
begin begin
@ -270,7 +270,7 @@ end;
{ FPC Additions } { FPC Additions }
function HeapSize:Longint; function HeapSize:ptrint;
begin begin
if IsMultiThread and MemoryManager.NeedLock then if IsMultiThread and MemoryManager.NeedLock then
begin begin
@ -288,7 +288,7 @@ begin
end; end;
function MemSize(p:pointer):Longint; function MemSize(p:pointer):ptrint;
begin begin
if IsMultiThread and MemoryManager.NeedLock then if IsMultiThread and MemoryManager.NeedLock then
begin begin
@ -307,7 +307,7 @@ end;
{ Delphi style } { Delphi style }
function FreeMem(p:pointer):Longint; function FreeMem(p:pointer):ptrint;
begin begin
if IsMultiThread and MemoryManager.NeedLock then if IsMultiThread and MemoryManager.NeedLock then
begin begin
@ -324,13 +324,13 @@ begin
end; end;
end; end;
function FreeMemory(p:pointer):Longint; function FreeMemory(p:pointer):ptrint;
begin begin
FreeMemory:=FreeMem(p); FreeMemory:=FreeMem(p);
end; end;
function GetMem(size:longint):pointer; function GetMem(size:ptrint):pointer;
begin begin
if IsMultiThread and MemoryManager.NeedLock then if IsMultiThread and MemoryManager.NeedLock then
begin begin
@ -347,13 +347,13 @@ begin
end; end;
end; end;
function GetMemory(size:longint):pointer; function GetMemory(size:ptrint):pointer;
begin begin
GetMemory:=Getmem(size); GetMemory:=Getmem(size);
end; end;
function AllocMem(Size:Longint):pointer; function AllocMem(Size:ptrint):pointer;
begin begin
if IsMultiThread and MemoryManager.NeedLock then if IsMultiThread and MemoryManager.NeedLock then
begin begin
@ -371,7 +371,7 @@ begin
end; end;
function ReAllocMem(var p:pointer;Size:Longint):pointer; function ReAllocMem(var p:pointer;Size:ptrint):pointer;
begin begin
if IsMultiThread and MemoryManager.NeedLock then if IsMultiThread and MemoryManager.NeedLock then
begin begin
@ -389,7 +389,7 @@ begin
end; end;
function ReAllocMemory(var p:pointer;Size:Longint):pointer; function ReAllocMemory(var p:pointer;Size:ptrint):pointer;
begin begin
ReAllocMemory:=ReAllocMem(p,size); ReAllocMemory:=ReAllocMem(p,size);
@ -398,7 +398,7 @@ end;
{$ifdef ValueGetmem} {$ifdef ValueGetmem}
{ Needed for calls from Assembler } { Needed for calls from Assembler }
function fpc_getmem(size:longint):pointer;compilerproc;[public,alias:'FPC_GETMEM']; function fpc_getmem(size:ptrint):pointer;compilerproc;[public,alias:'FPC_GETMEM'];
begin begin
if IsMultiThread and MemoryManager.NeedLock then if IsMultiThread and MemoryManager.NeedLock then
begin begin
@ -418,7 +418,7 @@ end;
{$else ValueGetmem} {$else ValueGetmem}
{ Needed for calls from Assembler } { Needed for calls from Assembler }
procedure AsmGetMem(var p:pointer;size:longint);[public,alias:'FPC_GETMEM']; procedure AsmGetMem(var p:pointer;size:ptrint);[public,alias:'FPC_GETMEM'];
begin begin
p:=MemoryManager.GetMem(size); p:=MemoryManager.GetMem(size);
end; end;
@ -461,19 +461,19 @@ end;
Heapsize,Memavail,MaxAvail Heapsize,Memavail,MaxAvail
*****************************************************************************} *****************************************************************************}
function SysHeapsize : longint; function SysHeapsize : ptrint;
begin begin
Sysheapsize:=internal_heapsize; Sysheapsize:=internal_heapsize;
end; end;
function SysMemavail : longint; function SysMemavail : ptrint;
begin begin
Sysmemavail:=internal_memavail; Sysmemavail:=internal_memavail;
end; end;
function SysMaxavail : longint; function SysMaxavail : ptrint;
var var
hp : pfreerecord; hp : pfreerecord;
begin begin
@ -491,7 +491,7 @@ end;
{$ifdef DUMPBLOCKS} {$ifdef DUMPBLOCKS}
procedure DumpBlocks; procedure DumpBlocks;
var var
s,i,j : longint; s,i,j : ptrint;
hp : pfreerecord; hp : pfreerecord;
begin begin
for i:=1 to maxblock do for i:=1 to maxblock do
@ -524,7 +524,7 @@ end;
{$ifdef TestFreeLists} {$ifdef TestFreeLists}
procedure TestFreeLists; procedure TestFreeLists;
var var
i,j : longint; i,j : ptrint;
hp : pfreerecord; hp : pfreerecord;
begin begin
for i:=0 to maxblock do for i:=0 to maxblock do
@ -553,7 +553,7 @@ end;
procedure TryConcatFreeRecord(pcurr:pfreerecord); procedure TryConcatFreeRecord(pcurr:pfreerecord);
var var
hp : pfreerecord; hp : pfreerecord;
pcurrsize,s1 : longint; pcurrsize,s1 : ptrint;
begin begin
pcurrsize:=pcurr^.size and sizemask; pcurrsize:=pcurr^.size and sizemask;
hp:=pcurr; hp:=pcurr;
@ -621,14 +621,14 @@ end;
SysGetMem SysGetMem
*****************************************************************************} *****************************************************************************}
function SysGetMem(size : longint):pointer; function SysGetMem(size : ptrint):pointer;
type type
heaperrorproc=function(size:longint):integer; heaperrorproc=function(size:ptrint):integer;
var var
proc : heaperrorproc; proc : heaperrorproc;
pcurr : pfreerecord; pcurr : pfreerecord;
s,s1,maxs1, s,s1,maxs1,
sizeleft : longint; sizeleft : ptrint;
again : boolean; again : boolean;
{$ifdef BESTMATCH} {$ifdef BESTMATCH}
pbest : pfreerecord; pbest : pfreerecord;
@ -867,9 +867,9 @@ end;
SysFreeMem SysFreeMem
*****************************************************************************} *****************************************************************************}
Function SysFreeMem(p : pointer):Longint; Function SysFreeMem(p : pointer):ptrint;
var var
pcurrsize,s : longint; pcurrsize,s : ptrint;
pcurr : pfreerecord; pcurr : pfreerecord;
begin begin
if p=nil then if p=nil then
@ -903,9 +903,9 @@ end;
SysFreeMemSize SysFreeMemSize
*****************************************************************************} *****************************************************************************}
Function SysFreeMemSize(p : pointer;size : longint):longint; Function SysFreeMemSize(p : pointer;size : ptrint):ptrint;
var var
pcurrsize,s : longint; pcurrsize,s : ptrint;
pcurr : pfreerecord; pcurr : pfreerecord;
begin begin
SysFreeMemSize:=0; SysFreeMemSize:=0;
@ -951,7 +951,7 @@ end;
SysMemSize SysMemSize
*****************************************************************************} *****************************************************************************}
function SysMemSize(p:pointer):longint; function SysMemSize(p:pointer):ptrint;
begin begin
SysMemSize:=(pheaprecord(pointer(p)-sizeof(theaprecord))^.size and sizemask)-sizeof(theaprecord); SysMemSize:=(pheaprecord(pointer(p)-sizeof(theaprecord))^.size and sizemask)-sizeof(theaprecord);
end; end;
@ -961,7 +961,7 @@ end;
SysAllocMem SysAllocMem
*****************************************************************************} *****************************************************************************}
function SysAllocMem(size : longint):pointer; function SysAllocMem(size : ptrint):pointer;
begin begin
sysallocmem:=MemoryManager.GetMem(size); sysallocmem:=MemoryManager.GetMem(size);
if sysallocmem<>nil then if sysallocmem<>nil then
@ -973,13 +973,13 @@ end;
SysResizeMem SysResizeMem
*****************************************************************************} *****************************************************************************}
function SysTryResizeMem(var p:pointer;size : longint):boolean; function SysTryResizeMem(var p:pointer;size : ptrint):boolean;
var var
oldsize, oldsize,
currsize, currsize,
foundsize, foundsize,
sizeleft, sizeleft,
s : longint; s : ptrint;
wasbeforeheapend : boolean; wasbeforeheapend : boolean;
hp, hp,
pnew, pnew,
@ -1135,9 +1135,9 @@ end;
SysResizeMem SysResizeMem
*****************************************************************************} *****************************************************************************}
function SysReAllocMem(var p:pointer;size : longint):pointer; function SysReAllocMem(var p:pointer;size : ptrint):pointer;
var var
oldsize : longint; oldsize : ptrint;
p2 : pointer; p2 : pointer;
begin begin
{ Free block? } { Free block? }
@ -1334,7 +1334,11 @@ end;
{ {
$Log$ $Log$
Revision 1.27 2004-03-15 20:42:39 peter Revision 1.28 2004-03-15 21:48:26 peter
* cmem moved to rtl
* longint replaced with ptrint in heapmanagers
Revision 1.27 2004/03/15 20:42:39 peter
* exit with rte 204 instead of looping infinite when a heap record * exit with rte 204 instead of looping infinite when a heap record
size is overwritten with 0 size is overwritten with 0

80
rtl/inc/heaph.inc
View File

@ -19,15 +19,15 @@ type
PMemoryManager = ^TMemoryManager; PMemoryManager = ^TMemoryManager;
TMemoryManager = record TMemoryManager = record
NeedLock : boolean; NeedLock : boolean;
Getmem : Function(Size:Longint):Pointer; Getmem : Function(Size:ptrint):Pointer;
Freemem : Function(p:pointer):Longint; Freemem : Function(p:pointer):ptrint;
FreememSize : Function(p:pointer;Size:Longint):Longint; FreememSize : Function(p:pointer;Size:ptrint):ptrint;
AllocMem : Function(Size:longint):Pointer; AllocMem : Function(Size:ptrint):Pointer;
ReAllocMem : Function(var p:pointer;Size:longint):Pointer; ReAllocMem : Function(var p:pointer;Size:ptrint):Pointer;
MemSize : function(p:pointer):Longint; MemSize : function(p:pointer):ptrint;
MemAvail : Function:Longint; MemAvail : Function:ptrint;
MaxAvail : Function:Longint; MaxAvail : Function:ptrint;
HeapSize : Function:Longint; HeapSize : Function:ptrint;
end; end;
TMemoryMutexManager = record TMemoryMutexManager = record
MutexInit : procedure; MutexInit : procedure;
@ -42,44 +42,44 @@ procedure SetMemoryMutexManager(var MutexMgr: TMemoryMutexManager);
{ Variables } { Variables }
const const
growheapsize1 : longint=256*1024; { < 256k will grow with 256k } growheapsize1 : ptrint=256*1024; { < 256k will grow with 256k }
growheapsize2 : longint=1024*1024; { > 256k will grow with 1m } growheapsize2 : ptrint=1024*1024; { > 256k will grow with 1m }
ReturnNilIfGrowHeapFails : boolean = false; ReturnNilIfGrowHeapFails : boolean = false;
var var
heaporg,heapptr,heapend,heaperror,freelist : pointer; heaporg,heapptr,heapend,heaperror,freelist : pointer;
{ Default MemoryManager functions } { Default MemoryManager functions }
Function SysGetmem(Size:Longint):Pointer; Function SysGetmem(Size:ptrint):Pointer;
Function SysFreemem(p:pointer):Longint; Function SysFreemem(p:pointer):ptrint;
Function SysFreememSize(p:pointer;Size:Longint):Longint; Function SysFreememSize(p:pointer;Size:ptrint):ptrint;
Function SysMemSize(p:pointer):Longint; Function SysMemSize(p:pointer):ptrint;
Function SysAllocMem(size:longint):Pointer; Function SysAllocMem(size:ptrint):Pointer;
function SysTryResizeMem(var p:pointer;size : longint):boolean; function SysTryResizeMem(var p:pointer;size : ptrint):boolean;
Function SysReAllocMem(var p:pointer;size:longint):Pointer; Function SysReAllocMem(var p:pointer;size:ptrint):Pointer;
Function Sysmemavail:Longint; Function Sysmemavail:ptrint;
Function Sysmaxavail:Longint; Function Sysmaxavail:ptrint;
Function Sysheapsize:longint; Function Sysheapsize:ptrint;
{ Tp7 functions } { Tp7 functions }
Procedure Getmem(Var p:pointer;Size:Longint); Procedure Getmem(Var p:pointer;Size:ptrint);
Procedure Getmemory(Var p:pointer;Size:Longint); Procedure Getmemory(Var p:pointer;Size:ptrint);
Procedure Freemem(p:pointer;Size:Longint); Procedure Freemem(p:pointer;Size:ptrint);
Procedure Freememory(p:pointer;Size:Longint); Procedure Freememory(p:pointer;Size:ptrint);
Function memavail:Longint; Function memavail:ptrint;
Function maxavail:Longint; Function maxavail:ptrint;
{ FPC additions } { FPC additions }
Function MemSize(p:pointer):Longint; Function MemSize(p:pointer):ptrint;
Function heapsize:longint; Function heapsize:ptrint;
{ Delphi functions } { Delphi functions }
function GetMem(size:longint):pointer; function GetMem(size:ptrint):pointer;
function GetMemory(size:longint):pointer; function GetMemory(size:ptrint):pointer;
function Freemem(p:pointer):longint; function Freemem(p:pointer):ptrint;
function Freememory(p:pointer):longint; function Freememory(p:pointer):ptrint;
function AllocMem(Size:Longint):pointer; function AllocMem(Size:ptrint):pointer;
function ReAllocMem(var p:pointer;Size:Longint):pointer; function ReAllocMem(var p:pointer;Size:ptrint):pointer;
function ReAllocMemory(var p:pointer;Size:Longint):pointer; function ReAllocMemory(var p:pointer;Size:ptrint):pointer;
{ Do nothing functions, are only here for tp7 compat } { Do nothing functions, are only here for tp7 compat }
Procedure mark(var p : pointer); Procedure mark(var p : pointer);
@ -87,7 +87,7 @@ Procedure release(var p : pointer);
{$ifndef ValueGetmem} {$ifndef ValueGetmem}
{ Needed to solve overloading problem with call from assembler (PFV) } { Needed to solve overloading problem with call from assembler (PFV) }
Procedure AsmGetmem(var p:pointer;size:Longint); Procedure AsmGetmem(var p:pointer;size:ptrint);
{$endif ValueGetmem} {$endif ValueGetmem}
{$ifndef ValueFreemem} {$ifndef ValueFreemem}
Procedure AsmFreemem(var p:pointer); Procedure AsmFreemem(var p:pointer);
@ -95,7 +95,11 @@ Procedure AsmFreemem(var p:pointer);
{ {
$Log$ $Log$
Revision 1.7 2003-10-02 14:03:24 marco Revision 1.8 2004-03-15 21:48:26 peter
* cmem moved to rtl
* longint replaced with ptrint in heapmanagers
Revision 1.7 2003/10/02 14:03:24 marco
* *memORY overloads * *memORY overloads
Revision 1.6 2002/10/30 20:39:13 peter Revision 1.6 2002/10/30 20:39:13 peter

136
rtl/inc/heaptrc.pp
View File

@ -38,7 +38,7 @@ type
{ Allows to add info pre memory block, see ppheap.pas of the compiler { Allows to add info pre memory block, see ppheap.pas of the compiler
for example source } for example source }
procedure SetHeapExtraInfo( size : longint;fillproc : tfillextrainfoproc;displayproc : tdisplayextrainfoproc); procedure SetHeapExtraInfo( size : ptrint;fillproc : tfillextrainfoproc;displayproc : tdisplayextrainfoproc);
{ Redirection of the output to a file } { Redirection of the output to a file }
procedure SetHeapTraceOutput(const name : string); procedure SetHeapTraceOutput(const name : string);
@ -75,14 +75,14 @@ const
implementation implementation
type type
plongint = ^longint; pptrint = ^ptrint;
const const
{ allows to add custom info in heap_mem_info, this is the size that will { allows to add custom info in heap_mem_info, this is the size that will
be allocated for this information } be allocated for this information }
extra_info_size : longint = 0; extra_info_size : ptrint = 0;
exact_info_size : longint = 0; exact_info_size : ptrint = 0;
EntryMemUsed : longint = 0; EntryMemUsed : ptrint = 0;
{ function to fill this info up } { function to fill this info up }
fill_extra_info_proc : TFillExtraInfoProc = nil; fill_extra_info_proc : TFillExtraInfoProc = nil;
display_extra_info_proc : TDisplayExtraInfoProc = nil; display_extra_info_proc : TDisplayExtraInfoProc = nil;
@ -112,7 +112,7 @@ type
theap_mem_info = record theap_mem_info = record
previous, previous,
next : pheap_mem_info; next : pheap_mem_info;
size : longint; size : ptrint;
sig : longword; sig : longword;
{$ifdef EXTRA} {$ifdef EXTRA}
release_sig : longword; release_sig : longword;
@ -134,11 +134,11 @@ var
{$endif EXTRA} {$endif EXTRA}
heap_mem_root : pheap_mem_info; heap_mem_root : pheap_mem_info;
getmem_cnt, getmem_cnt,
freemem_cnt : longint; freemem_cnt : ptrint;
getmem_size, getmem_size,
freemem_size : longint; freemem_size : ptrint;
getmem8_size, getmem8_size,
freemem8_size : longint; freemem8_size : ptrint;
{***************************************************************************** {*****************************************************************************
@ -166,9 +166,9 @@ begin
end; end;
Function UpdateCrc32(InitCrc:longword;var InBuf;InLen:Longint):longword; Function UpdateCrc32(InitCrc:longword;var InBuf;InLen:ptrint):longword;
var var
i : longint; i : ptrint;
p : pchar; p : pchar;
begin begin
p:=@InBuf; p:=@InBuf;
@ -183,18 +183,18 @@ end;
Function calculate_sig(p : pheap_mem_info) : longword; Function calculate_sig(p : pheap_mem_info) : longword;
var var
crc : longword; crc : longword;
pl : plongint; pl : pptrint;
begin begin
crc:=cardinal($ffffffff); crc:=cardinal($ffffffff);
crc:=UpdateCrc32(crc,p^.size,sizeof(longint)); crc:=UpdateCrc32(crc,p^.size,sizeof(ptrint));
crc:=UpdateCrc32(crc,p^.calls,tracesize*sizeof(longint)); crc:=UpdateCrc32(crc,p^.calls,tracesize*sizeof(ptrint));
if p^.extra_info_size>0 then if p^.extra_info_size>0 then
crc:=UpdateCrc32(crc,p^.extra_info^,p^.exact_info_size); crc:=UpdateCrc32(crc,p^.extra_info^,p^.exact_info_size);
if add_tail then if add_tail then
begin begin
{ Check also 4 bytes just after allocation !! } { Check also 4 bytes just after allocation !! }
pl:=pointer(p)+p^.extra_info_size+sizeof(theap_mem_info)+p^.size; pl:=pointer(p)+p^.extra_info_size+sizeof(theap_mem_info)+p^.size;
crc:=UpdateCrc32(crc,pl^,sizeof(longint)); crc:=UpdateCrc32(crc,pl^,sizeof(ptrint));
end; end;
calculate_sig:=crc; calculate_sig:=crc;
end; end;
@ -203,11 +203,11 @@ end;
Function calculate_release_sig(p : pheap_mem_info) : longword; Function calculate_release_sig(p : pheap_mem_info) : longword;
var var
crc : longword; crc : longword;
pl : plongint; pl : pptrint;
begin begin
crc:=$ffffffff; crc:=$ffffffff;
crc:=UpdateCrc32(crc,p^.size,sizeof(longint)); crc:=UpdateCrc32(crc,p^.size,sizeof(ptrint));
crc:=UpdateCrc32(crc,p^.calls,tracesize*sizeof(longint)); crc:=UpdateCrc32(crc,p^.calls,tracesize*sizeof(ptrint));
if p^.extra_info_size>0 then if p^.extra_info_size>0 then
crc:=UpdateCrc32(crc,p^.extra_info^,p^.exact_info_size); crc:=UpdateCrc32(crc,p^.extra_info^,p^.exact_info_size);
{ Check the whole of the whole allocation } { Check the whole of the whole allocation }
@ -218,7 +218,7 @@ begin
begin begin
{ Check also 4 bytes just after allocation !! } { Check also 4 bytes just after allocation !! }
pl:=pointer(p)+p^.extra_info_size+sizeof(theap_mem_info)+p^.size; pl:=pointer(p)+p^.extra_info_size+sizeof(theap_mem_info)+p^.size;
crc:=UpdateCrc32(crc,pl^,sizeof(longint)); crc:=UpdateCrc32(crc,pl^,sizeof(ptrint));
end; end;
calculate_release_sig:=crc; calculate_release_sig:=crc;
end; end;
@ -231,9 +231,9 @@ end;
procedure call_stack(pp : pheap_mem_info;var ptext : text); procedure call_stack(pp : pheap_mem_info;var ptext : text);
var var
i : longint; i : ptrint;
begin begin
writeln(ptext,'Call trace for block $',hexstr(longint(pointer(pp)+sizeof(theap_mem_info)),8),' size ',pp^.size); writeln(ptext,'Call trace for block $',hexstr(ptrint(pointer(pp)+sizeof(theap_mem_info)),8),' size ',pp^.size);
for i:=1 to tracesize do for i:=1 to tracesize do
if pp^.calls[i]<>nil then if pp^.calls[i]<>nil then
writeln(ptext,BackTraceStrFunc(pp^.calls[i])); writeln(ptext,BackTraceStrFunc(pp^.calls[i]));
@ -247,9 +247,9 @@ end;
procedure call_free_stack(pp : pheap_mem_info;var ptext : text); procedure call_free_stack(pp : pheap_mem_info;var ptext : text);
var var
i : longint; i : ptrint;
begin begin
writeln(ptext,'Call trace for block at $',hexstr(longint(pointer(pp)+sizeof(theap_mem_info)),8),' size ',pp^.size); writeln(ptext,'Call trace for block at $',hexstr(ptrint(pointer(pp)+sizeof(theap_mem_info)),8),' size ',pp^.size);
for i:=1 to tracesize div 2 do for i:=1 to tracesize div 2 do
if pp^.calls[i]<>nil then if pp^.calls[i]<>nil then
writeln(ptext,BackTraceStrFunc(pp^.calls[i])); writeln(ptext,BackTraceStrFunc(pp^.calls[i]));
@ -267,7 +267,7 @@ end;
procedure dump_already_free(p : pheap_mem_info;var ptext : text); procedure dump_already_free(p : pheap_mem_info;var ptext : text);
begin begin
Writeln(ptext,'Marked memory at $',HexStr(longint(pointer(p)+sizeof(theap_mem_info)),8),' released'); Writeln(ptext,'Marked memory at $',HexStr(ptrint(pointer(p)+sizeof(theap_mem_info)),8),' released');
call_free_stack(p,ptext); call_free_stack(p,ptext);
Writeln(ptext,'freed again at'); Writeln(ptext,'freed again at');
dump_stack(ptext,get_caller_frame(get_frame)); dump_stack(ptext,get_caller_frame(get_frame));
@ -275,7 +275,7 @@ end;
procedure dump_error(p : pheap_mem_info;var ptext : text); procedure dump_error(p : pheap_mem_info;var ptext : text);
begin begin
Writeln(ptext,'Marked memory at $',HexStr(longint(pointer(p)+sizeof(theap_mem_info)),8),' invalid'); Writeln(ptext,'Marked memory at $',HexStr(ptrint(pointer(p)+sizeof(theap_mem_info)),8),' invalid');
Writeln(ptext,'Wrong signature $',hexstr(p^.sig,8),' instead of ',hexstr(calculate_sig(p),8)); Writeln(ptext,'Wrong signature $',hexstr(p^.sig,8),' instead of ',hexstr(calculate_sig(p),8));
dump_stack(ptext,get_caller_frame(get_frame)); dump_stack(ptext,get_caller_frame(get_frame));
end; end;
@ -283,9 +283,9 @@ end;
{$ifdef EXTRA} {$ifdef EXTRA}
procedure dump_change_after(p : pheap_mem_info;var ptext : text); procedure dump_change_after(p : pheap_mem_info;var ptext : text);
var pp : pchar; var pp : pchar;
i : longint; i : ptrint;
begin begin
Writeln(ptext,'Marked memory at $',HexStr(longint(pointer(p)+sizeof(theap_mem_info)),8),' invalid'); Writeln(ptext,'Marked memory at $',HexStr(ptrint(pointer(p)+sizeof(theap_mem_info)),8),' invalid');
Writeln(ptext,'Wrong release CRC $',hexstr(p^.release_sig,8),' instead of ',hexstr(calculate_release_sig(p),8)); Writeln(ptext,'Wrong release CRC $',hexstr(p^.release_sig,8),' instead of ',hexstr(calculate_release_sig(p),8));
Writeln(ptext,'This memory was changed after call to freemem !'); Writeln(ptext,'This memory was changed after call to freemem !');
call_free_stack(p,ptext); call_free_stack(p,ptext);
@ -296,9 +296,9 @@ begin
end; end;
{$endif EXTRA} {$endif EXTRA}
procedure dump_wrong_size(p : pheap_mem_info;size : longint;var ptext : text); procedure dump_wrong_size(p : pheap_mem_info;size : ptrint;var ptext : text);
begin begin
Writeln(ptext,'Marked memory at $',HexStr(longint(pointer(p)+sizeof(theap_mem_info)),8),' invalid'); Writeln(ptext,'Marked memory at $',HexStr(ptrint(pointer(p)+sizeof(theap_mem_info)),8),' invalid');
Writeln(ptext,'Wrong size : ',p^.size,' allocated ',size,' freed'); Writeln(ptext,'Wrong size : ',p^.size,' allocated ',size,' freed');
dump_stack(ptext,get_caller_frame(get_frame)); dump_stack(ptext,get_caller_frame(get_frame));
{ the check is done to be sure that the procvar is not overwritten } { the check is done to be sure that the procvar is not overwritten }
@ -312,7 +312,7 @@ end;
function is_in_getmem_list (p : pheap_mem_info) : boolean; function is_in_getmem_list (p : pheap_mem_info) : boolean;
var var
i : longint; i : ptrint;
pp : pheap_mem_info; pp : pheap_mem_info;
begin begin
is_in_getmem_list:=false; is_in_getmem_list:=false;
@ -341,9 +341,9 @@ end;
TraceGetMem TraceGetMem
*****************************************************************************} *****************************************************************************}
Function TraceGetMem(size:longint):pointer; Function TraceGetMem(size:ptrint):pointer;
var var
allocsize,i : longint; allocsize,i : ptrint;
oldbp, oldbp,
bp : pointer; bp : pointer;
pl : pdword; pl : pdword;
@ -355,7 +355,7 @@ begin
{ Do the real GetMem, but alloc also for the info block } { Do the real GetMem, but alloc also for the info block }
allocsize:=size+sizeof(theap_mem_info)+extra_info_size; allocsize:=size+sizeof(theap_mem_info)+extra_info_size;
if add_tail then if add_tail then
inc(allocsize,sizeof(longint)); inc(allocsize,sizeof(ptrint));
p:=SysGetMem(allocsize); p:=SysGetMem(allocsize);
pp:=pheap_mem_info(p); pp:=pheap_mem_info(p);
inc(p,sizeof(theap_mem_info)); inc(p,sizeof(theap_mem_info));
@ -387,7 +387,7 @@ begin
pp^.extra_info:=nil; pp^.extra_info:=nil;
if add_tail then if add_tail then
begin begin
pl:=pointer(pp)+allocsize-pp^.extra_info_size-sizeof(longint); pl:=pointer(pp)+allocsize-pp^.extra_info_size-sizeof(ptrint);
pl^:=$DEADBEEF; pl^:=$DEADBEEF;
end; end;
{ clear the memory } { clear the memory }
@ -429,22 +429,22 @@ end;
TraceFreeMem TraceFreeMem
*****************************************************************************} *****************************************************************************}
function TraceFreeMemSize(p:pointer;size:longint):longint; function TraceFreeMemSize(p:pointer;size:ptrint):ptrint;
var var
i,ppsize : longint; i,ppsize : ptrint;
bp : pointer; bp : pointer;
pp : pheap_mem_info; pp : pheap_mem_info;
{$ifdef EXTRA} {$ifdef EXTRA}
pp2 : pheap_mem_info; pp2 : pheap_mem_info;
{$endif} {$endif}
extra_size : longint; extra_size : ptrint;
begin begin
inc(freemem_size,size); inc(freemem_size,size);
inc(freemem8_size,((size+7) div 8)*8); inc(freemem8_size,((size+7) div 8)*8);
pp:=pheap_mem_info(p-sizeof(theap_mem_info)); pp:=pheap_mem_info(p-sizeof(theap_mem_info));
ppsize:= size + sizeof(theap_mem_info)+pp^.extra_info_size; ppsize:= size + sizeof(theap_mem_info)+pp^.extra_info_size;
if add_tail then if add_tail then
inc(ppsize,sizeof(longint)); inc(ppsize,sizeof(ptrint));
if not quicktrace then if not quicktrace then
begin begin
if not(is_in_getmem_list(pp)) then if not(is_in_getmem_list(pp)) then
@ -541,28 +541,28 @@ begin
{ return the correct size } { return the correct size }
dec(i,sizeof(theap_mem_info)+extra_size); dec(i,sizeof(theap_mem_info)+extra_size);
if add_tail then if add_tail then
dec(i,sizeof(longint)); dec(i,sizeof(ptrint));
TraceFreeMemSize:=i; TraceFreeMemSize:=i;
end; end;
function TraceMemSize(p:pointer):Longint; function TraceMemSize(p:pointer):ptrint;
var var
l : longint; l : ptrint;
pp : pheap_mem_info; pp : pheap_mem_info;
begin begin
pp:=pheap_mem_info(p-sizeof(theap_mem_info)); pp:=pheap_mem_info(p-sizeof(theap_mem_info));
l:=SysMemSize(pp); l:=SysMemSize(pp);
dec(l,sizeof(theap_mem_info)+pp^.extra_info_size); dec(l,sizeof(theap_mem_info)+pp^.extra_info_size);
if add_tail then if add_tail then
dec(l,sizeof(longint)); dec(l,sizeof(ptrint));
TraceMemSize:=l; TraceMemSize:=l;
end; end;
function TraceFreeMem(p:pointer):longint; function TraceFreeMem(p:pointer):ptrint;
var var
size : longint; size : ptrint;
pp : pheap_mem_info; pp : pheap_mem_info;
begin begin
pp:=pheap_mem_info(p-sizeof(theap_mem_info)); pp:=pheap_mem_info(p-sizeof(theap_mem_info));
@ -583,17 +583,17 @@ end;
ReAllocMem ReAllocMem
*****************************************************************************} *****************************************************************************}
function TraceReAllocMem(var p:pointer;size:longint):Pointer; function TraceReAllocMem(var p:pointer;size:ptrint):Pointer;
var var
newP: pointer; newP: pointer;
oldsize, oldsize,
allocsize, allocsize,
i : longint; i : ptrint;
bp : pointer; bp : pointer;
pl : pdword; pl : pdword;
pp : pheap_mem_info; pp : pheap_mem_info;
oldextrasize, oldextrasize,
oldexactsize : longint; oldexactsize : ptrint;
old_fill_extra_info_proc : tfillextrainfoproc; old_fill_extra_info_proc : tfillextrainfoproc;
old_display_extra_info_proc : tdisplayextrainfoproc; old_display_extra_info_proc : tdisplayextrainfoproc;
begin begin
@ -639,7 +639,7 @@ begin
{ Do the real ReAllocMem, but alloc also for the info block } { Do the real ReAllocMem, but alloc also for the info block }
allocsize:=size+sizeof(theap_mem_info)+pp^.extra_info_size; allocsize:=size+sizeof(theap_mem_info)+pp^.extra_info_size;
if add_tail then if add_tail then
inc(allocsize,sizeof(longint)); inc(allocsize,sizeof(ptrint));
{ Try to resize the block, if not possible we need to do a { Try to resize the block, if not possible we need to do a
getmem, move data, freemem } getmem, move data, freemem }
if not SysTryResizeMem(pp,allocsize) then if not SysTryResizeMem(pp,allocsize) then
@ -683,7 +683,7 @@ begin
pp^.extra_info:=nil; pp^.extra_info:=nil;
if add_tail then if add_tail then
begin begin
pl:=pointer(pp)+allocsize-pp^.extra_info_size-sizeof(longint); pl:=pointer(pp)+allocsize-pp^.extra_info_size-sizeof(ptrint);
pl^:=$DEADBEEF; pl^:=$DEADBEEF;
end; end;
{ generate new backtrace } { generate new backtrace }
@ -731,7 +731,7 @@ var
procedure CheckPointer(p : pointer);[saveregisters,public, alias : 'FPC_CHECKPOINTER']; procedure CheckPointer(p : pointer);[saveregisters,public, alias : 'FPC_CHECKPOINTER'];
var var
i : longint; i : ptrint;
pp : pheap_mem_info; pp : pheap_mem_info;
get_ebp,stack_top : longword; get_ebp,stack_top : longword;
data_end : longword; data_end : longword;
@ -825,7 +825,7 @@ begin
goto _exit goto _exit
else else
begin begin
writeln(ptext^,'pointer $',hexstr(longint(p),8),' points into invalid memory block'); writeln(ptext^,'pointer $',hexstr(ptrint(p),8),' points into invalid memory block');
dump_error(pp,ptext^); dump_error(pp,ptext^);
runerror(204); runerror(204);
end; end;
@ -837,7 +837,7 @@ begin
halt(1); halt(1);
end; end;
end; end;
writeln(ptext^,'pointer $',hexstr(longint(p),8),' does not point to valid memory block'); writeln(ptext^,'pointer $',hexstr(ptrint(p),8),' does not point to valid memory block');
runerror(204); runerror(204);
_exit: _exit:
end; end;
@ -849,8 +849,8 @@ end;
procedure dumpheap; procedure dumpheap;
var var
pp : pheap_mem_info; pp : pheap_mem_info;
i : longint; i : ptrint;
ExpectedMemAvail : longint; ExpectedMemAvail : ptrint;
begin begin
pp:=heap_mem_root; pp:=heap_mem_root;
Writeln(ptext^,'Heap dump by heaptrc unit'); Writeln(ptext^,'Heap dump by heaptrc unit');
@ -923,7 +923,7 @@ end;
AllocMem AllocMem
*****************************************************************************} *****************************************************************************}
function TraceAllocMem(size:longint):Pointer; function TraceAllocMem(size:ptrint):Pointer;
begin begin
TraceAllocMem:=SysAllocMem(size); TraceAllocMem:=SysAllocMem(size);
end; end;
@ -933,17 +933,17 @@ end;
No specific tracing calls No specific tracing calls
*****************************************************************************} *****************************************************************************}
function TraceMemAvail:longint; function TraceMemAvail:ptrint;
begin begin
TraceMemAvail:=SysMemAvail; TraceMemAvail:=SysMemAvail;
end; end;
function TraceMaxAvail:longint; function TraceMaxAvail:ptrint;
begin begin
TraceMaxAvail:=SysMaxAvail; TraceMaxAvail:=SysMaxAvail;
end; end;
function TraceHeapSize:longint; function TraceHeapSize:ptrint;
begin begin
TraceHeapSize:=SysHeapSize; TraceHeapSize:=SysHeapSize;
end; end;
@ -954,7 +954,7 @@ end;
*****************************************************************************} *****************************************************************************}
Procedure SetHeapTraceOutput(const name : string); Procedure SetHeapTraceOutput(const name : string);
var i : longint; var i : ptrint;
begin begin
if ptext<>@stderr then if ptext<>@stderr then
begin begin
@ -973,7 +973,7 @@ begin
writeln(ptext^); writeln(ptext^);
end; end;
procedure SetHeapExtraInfo( size : longint;fillproc : tfillextrainfoproc;displayproc : tdisplayextrainfoproc); procedure SetHeapExtraInfo( size : ptrint;fillproc : tfillextrainfoproc;displayproc : tdisplayextrainfoproc);
begin begin
{ the total size must stay multiple of 8, also allocate 2 pointers for { the total size must stay multiple of 8, also allocate 2 pointers for
the fill and display procvars } the fill and display procvars }
@ -1064,7 +1064,7 @@ end;
Function GetEnv(envvar: string): string; Function GetEnv(envvar: string): string;
var var
s : string; s : string;
i : longint; i : ptrint;
hp,p : pchar; hp,p : pchar;
begin begin
getenv:=''; getenv:='';
@ -1093,7 +1093,7 @@ Function GetEnv(P:string):Pchar;
} }
var var
ep : ppchar; ep : ppchar;
i : longint; i : ptrint;
found : boolean; found : boolean;
Begin Begin
p:=p+'='; {Else HOST will also find HOSTNAME, etc} p:=p+'='; {Else HOST will also find HOSTNAME, etc}
@ -1123,7 +1123,7 @@ end;
procedure LoadEnvironment; procedure LoadEnvironment;
var var
i,j : longint; i,j : ptrint;
s : string; s : string;
begin begin
s:=Getenv('HEAPTRC'); s:=Getenv('HEAPTRC');
@ -1156,7 +1156,11 @@ finalization
end. end.
{ {
$Log$ $Log$
Revision 1.26 2004-03-15 14:22:39 michael Revision 1.27 2004-03-15 21:48:26 peter
* cmem moved to rtl
* longint replaced with ptrint in heapmanagers
Revision 1.26 2004/03/15 14:22:39 michael
+ Fix from peter for win32 SIGTRAp signal + Fix from peter for win32 SIGTRAp signal
Revision 1.25 2004/02/06 20:17:12 daniel Revision 1.25 2004/02/06 20:17:12 daniel
@ -1168,7 +1172,7 @@ end.
Revision 1.23 2003/03/17 14:30:11 peter Revision 1.23 2003/03/17 14:30:11 peter
* changed address parameter/return values to pointer instead * changed address parameter/return values to pointer instead
of longint of ptrint
Revision 1.22 2002/12/26 10:46:54 peter Revision 1.22 2002/12/26 10:46:54 peter
* set p to nil when 0 is passed to reallocmem * set p to nil when 0 is passed to reallocmem
@ -1185,7 +1189,7 @@ end.
Revision 1.18 2002/09/09 15:45:49 jonas Revision 1.18 2002/09/09 15:45:49 jonas
* made result type of calculate_release_sig() a longword instead of a * made result type of calculate_release_sig() a longword instead of a
longint ptrint
Revision 1.17 2002/09/07 15:07:45 peter Revision 1.17 2002/09/07 15:07:45 peter
* old logs removed and tabs fixed * old logs removed and tabs fixed

16
rtl/linux/Makefile
View File

@ -1,5 +1,5 @@
# #
# Don't edit, this file is generated by FPCMake Version 1.1 [2004/02/03] # Don't edit, this file is generated by FPCMake Version 1.1 [2004/03/15]
# #
default: all default: all
MAKEFILETARGETS=linux go32v2 win32 os2 freebsd beos netbsd amiga atari sunos qnx netware openbsd wdosx palmos macos darwin emx watcom MAKEFILETARGETS=linux go32v2 win32 os2 freebsd beos netbsd amiga atari sunos qnx netware openbsd wdosx palmos macos darwin emx watcom
@ -243,7 +243,7 @@ GRAPHDIR=$(INC)/graph
ifndef USELIBGGI ifndef USELIBGGI
USELIBGGI=NO USELIBGGI=NO
endif endif
override TARGET_UNITS+=$(SYSTEMUNIT) unixtype baseunix strings systhrds objpas syscall unixutil heaptrc lineinfo $(LINUXUNIT1) termio unix $(LINUXUNIT2) initc $(CPU_UNITS) dos crt objects printer ggigraph sysutils typinfo math varutils charset ucomplex getopts errors sockets gpm ipc serial terminfo dl dynlibs video mouse keyboard variants types dateutils sysconst cthreads classes strutils rtlconst override TARGET_UNITS+=$(SYSTEMUNIT) unixtype baseunix strings systhrds objpas syscall unixutil heaptrc lineinfo $(LINUXUNIT1) termio unix $(LINUXUNIT2) initc cmem $(CPU_UNITS) dos crt objects printer ggigraph sysutils typinfo math varutils charset ucomplex getopts errors sockets gpm ipc serial terminfo dl dynlibs video mouse keyboard variants types dateutils sysconst cthreads classes strutils rtlconst
override TARGET_LOADERS+=prt0 dllprt0 cprt0 gprt0 $(CRT21) override TARGET_LOADERS+=prt0 dllprt0 cprt0 gprt0 $(CRT21)
override TARGET_RSTS+=math varutils typinfo variants systhrds sysconst rtlconst override TARGET_RSTS+=math varutils typinfo variants systhrds sysconst rtlconst
override CLEAN_UNITS+=syslinux linux override CLEAN_UNITS+=syslinux linux
@ -560,7 +560,8 @@ ZIPSUFFIX=nw
endif endif
ifeq ($(OS_TARGET),macos) ifeq ($(OS_TARGET),macos)
EXEEXT= EXEEXT=
FPCMADE=fpcmade.mcc FPCMADE=fpcmade.macos
ZIPSUFFIX=macos
endif endif
ifeq ($(OS_TARGET),darwin) ifeq ($(OS_TARGET),darwin)
EXEEXT= EXEEXT=
@ -859,9 +860,11 @@ ARNAME=$(BINUTILSPREFIX)ar
RCNAME=$(BINUTILSPREFIX)rc RCNAME=$(BINUTILSPREFIX)rc
ifneq ($(findstring 1.0.,$(FPC_VERSION)),) ifneq ($(findstring 1.0.,$(FPC_VERSION)),)
ifeq ($(OS_TARGET),win32) ifeq ($(OS_TARGET),win32)
ASNAME=as ifeq ($(CROSSBINDIR),)
LDNAME=ld ASNAME=asw
ARNAME=ar LDNAME=ldw
ARNAME=arw
endif
endif endif
endif endif
ifndef ASPROG ifndef ASPROG
@ -1447,4 +1450,5 @@ errors$(PPUEXT) : errors.pp strings$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
ipc$(PPUEXT) : ipc.pp unix$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT) ipc$(PPUEXT) : ipc.pp unix$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
terminfo$(PPUEXT) : terminfo.pp unix$(PPUEXT) terminfo$(PPUEXT) : terminfo.pp unix$(PPUEXT)
callspec$(PPUEXT) : $(INC)/callspec.pp $(SYSTEMUNIT)$(PPUEXT) callspec$(PPUEXT) : $(INC)/callspec.pp $(SYSTEMUNIT)$(PPUEXT)
cmem$(PPUEXT) : $(INC)/cmem.pp $(SYSTEMUNIT)$(PPUEXT)
cthreads$(PPUEXT) : $(UNIXINC)/cthreads.pp $(SYSTEMUNIT)$(PPUEXT) systhrds$(PPUEXT) cthreads$(PPUEXT) : $(UNIXINC)/cthreads.pp $(SYSTEMUNIT)$(PPUEXT) systhrds$(PPUEXT)

4
rtl/linux/Makefile.fpc
View File

@ -9,7 +9,7 @@ main=rtl
loaders=prt0 dllprt0 cprt0 gprt0 $(CRT21) loaders=prt0 dllprt0 cprt0 gprt0 $(CRT21)
units=$(SYSTEMUNIT) unixtype baseunix strings systhrds objpas syscall unixutil \ units=$(SYSTEMUNIT) unixtype baseunix strings systhrds objpas syscall unixutil \
heaptrc lineinfo \ heaptrc lineinfo \
$(LINUXUNIT1) termio unix $(LINUXUNIT2) initc $(CPU_UNITS) \ $(LINUXUNIT1) termio unix $(LINUXUNIT2) initc cmem $(CPU_UNITS) \
dos crt objects printer ggigraph \ dos crt objects printer ggigraph \
sysutils typinfo math varutils \ sysutils typinfo math varutils \
charset ucomplex getopts \ charset ucomplex getopts \
@ -278,4 +278,6 @@ terminfo$(PPUEXT) : terminfo.pp unix$(PPUEXT)
callspec$(PPUEXT) : $(INC)/callspec.pp $(SYSTEMUNIT)$(PPUEXT) callspec$(PPUEXT) : $(INC)/callspec.pp $(SYSTEMUNIT)$(PPUEXT)
cmem$(PPUEXT) : $(INC)/cmem.pp $(SYSTEMUNIT)$(PPUEXT)
cthreads$(PPUEXT) : $(UNIXINC)/cthreads.pp $(SYSTEMUNIT)$(PPUEXT) systhrds$(PPUEXT) cthreads$(PPUEXT) : $(UNIXINC)/cthreads.pp $(SYSTEMUNIT)$(PPUEXT) systhrds$(PPUEXT)

16
rtl/win32/Makefile
View File

@ -1,5 +1,5 @@
# #
# Don't edit, this file is generated by FPCMake Version 1.1 [2004/02/22] # Don't edit, this file is generated by FPCMake Version 1.1 [2004/03/15]
# #
default: all default: all
MAKEFILETARGETS=linux go32v2 win32 os2 freebsd beos netbsd amiga atari sunos qnx netware openbsd wdosx palmos macos darwin emx watcom MAKEFILETARGETS=linux go32v2 win32 os2 freebsd beos netbsd amiga atari sunos qnx netware openbsd wdosx palmos macos darwin emx watcom
@ -229,7 +229,7 @@ OBJPASDIR=$(RTL)/objpas
GRAPHDIR=$(INC)/graph GRAPHDIR=$(INC)/graph
include $(WININC)/makefile.inc include $(WININC)/makefile.inc
WINDOWS_SOURCE_FILES=$(addprefix $(WININC)/,$(addsuffix .inc,$(WINDOWS_FILES))) WINDOWS_SOURCE_FILES=$(addprefix $(WININC)/,$(addsuffix .inc,$(WINDOWS_FILES)))
override TARGET_UNITS+=$(SYSTEMUNIT) systhrds objpas strings lineinfo heaptrc windows ole2 activex winsock initc dos crt objects graph messages sysutils classes typinfo math varutils variants cpu mmx charset ucomplex getopts wincrt winmouse winevent sockets printer dynlibs video mouse keyboard types comobj dateutils rtlconst sysconst winsysut override TARGET_UNITS+=$(SYSTEMUNIT) systhrds objpas strings lineinfo heaptrc windows ole2 activex winsock initc cmem dos crt objects graph messages sysutils classes typinfo math varutils variants cpu mmx charset ucomplex getopts wincrt winmouse winevent sockets printer dynlibs video mouse keyboard types comobj dateutils rtlconst sysconst winsysut
override TARGET_LOADERS+=wprt0 wdllprt0 gprt0 override TARGET_LOADERS+=wprt0 wdllprt0 gprt0
override TARGET_RSTS+=math varutils typinfo variants classes dateutils sysconst override TARGET_RSTS+=math varutils typinfo variants classes dateutils sysconst
override INSTALL_FPCPACKAGE=y override INSTALL_FPCPACKAGE=y
@ -545,7 +545,8 @@ ZIPSUFFIX=nw
endif endif
ifeq ($(OS_TARGET),macos) ifeq ($(OS_TARGET),macos)
EXEEXT= EXEEXT=
FPCMADE=fpcmade.mcc FPCMADE=fpcmade.macos
ZIPSUFFIX=macos
endif endif
ifeq ($(OS_TARGET),darwin) ifeq ($(OS_TARGET),darwin)
EXEEXT= EXEEXT=
@ -844,9 +845,11 @@ ARNAME=$(BINUTILSPREFIX)ar
RCNAME=$(BINUTILSPREFIX)rc RCNAME=$(BINUTILSPREFIX)rc
ifneq ($(findstring 1.0.,$(FPC_VERSION)),) ifneq ($(findstring 1.0.,$(FPC_VERSION)),)
ifeq ($(OS_TARGET),win32) ifeq ($(OS_TARGET),win32)
ASNAME=as ifeq ($(CROSSBINDIR),)
LDNAME=ld ASNAME=asw
ARNAME=ar LDNAME=ldw
ARNAME=arw
endif
endif endif
endif endif
ifndef ASPROG ifndef ASPROG
@ -1416,5 +1419,6 @@ heaptrc$(PPUEXT) : $(INC)/heaptrc.pp $(SYSTEMUNIT)$(PPUEXT)
$(COMPILER) -Sg $(INC)/heaptrc.pp $(COMPILER) -Sg $(INC)/heaptrc.pp
lineinfo$(PPUEXT) : $(INC)/lineinfo.pp $(SYSTEMUNIT)$(PPUEXT) lineinfo$(PPUEXT) : $(INC)/lineinfo.pp $(SYSTEMUNIT)$(PPUEXT)
charset$(PPUEXT) : $(INC)/charset.pp $(SYSTEMUNIT)$(PPUEXT) charset$(PPUEXT) : $(INC)/charset.pp $(SYSTEMUNIT)$(PPUEXT)
cmem$(PPUEXT) : $(INC)/cmem.pp $(SYSTEMUNIT)$(PPUEXT)
ucomplex$(PPUEXT) : $(INC)/ucomplex.pp math$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT) ucomplex$(PPUEXT) : $(INC)/ucomplex.pp math$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
callspec$(PPUEXT) : $(INC)/callspec.pp $(SYSTEMUNIT)$(PPUEXT) callspec$(PPUEXT) : $(INC)/callspec.pp $(SYSTEMUNIT)$(PPUEXT)

4
rtl/win32/Makefile.fpc
View File

@ -9,7 +9,7 @@ main=rtl
loaders=wprt0 wdllprt0 gprt0 loaders=wprt0 wdllprt0 gprt0
units=$(SYSTEMUNIT) systhrds objpas strings \ units=$(SYSTEMUNIT) systhrds objpas strings \
lineinfo heaptrc \ lineinfo heaptrc \
windows ole2 activex winsock initc \ windows ole2 activex winsock initc cmem \
dos crt objects graph messages \ dos crt objects graph messages \
sysutils classes typinfo math varutils variants \ sysutils classes typinfo math varutils variants \
cpu mmx charset ucomplex getopts \ cpu mmx charset ucomplex getopts \
@ -226,6 +226,8 @@ lineinfo$(PPUEXT) : $(INC)/lineinfo.pp $(SYSTEMUNIT)$(PPUEXT)
charset$(PPUEXT) : $(INC)/charset.pp $(SYSTEMUNIT)$(PPUEXT) charset$(PPUEXT) : $(INC)/charset.pp $(SYSTEMUNIT)$(PPUEXT)
cmem$(PPUEXT) : $(INC)/cmem.pp $(SYSTEMUNIT)$(PPUEXT)
ucomplex$(PPUEXT) : $(INC)/ucomplex.pp math$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT) ucomplex$(PPUEXT) : $(INC)/ucomplex.pp math$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
# #