* Boehm garbage collector memory manager

git-svn-id: trunk@35901 -

.gitattributes

@@ -5109,6 +5109,13 @@ packages/libgbafpc/src/gba/pcx.inc svneol=native#text/plain
 packages/libgbafpc/src/maxmod/inc/maxmod.inc svneol=native#text/plain
 packages/libgbafpc/src/maxmod/inc/mm_types.inc svneol=native#text/plain
 packages/libgbafpc/src/maxmod/maxmod.pp svneol=native#text/plain
+packages/libgc/Makefile svneol=native#text/plain
+packages/libgc/Makefile.fpc svneol=native#text/plain
+packages/libgc/examples/create_leak.pp svneol=native#text/plain
+packages/libgc/examples/testcmem.pp svneol=native#text/plain
+packages/libgc/examples/usage.txt svneol=native#text/plain
+packages/libgc/fpmake.pp svneol=native#text/plain
+packages/libgc/src/gcmem.pp svneol=native#text/plain
 packages/libgd/Makefile svneol=native#text/plain
 packages/libgd/Makefile.fpc svneol=native#text/plain
 packages/libgd/Makefile.fpc.fpcmake svneol=native#text/plain

packages/fpmake_add.inc

@@ -133,4 +133,5 @@
   add_fcl_pdf(ADirectory+IncludeTrailingPathDelimiter('fcl-pdf'));
   add_odata(ADirectory+IncludeTrailingPathDelimiter('odata'));
   add_pastojs(ADirectory+IncludeTrailingPathDelimiter('pastojs'));
+  add_libgc(ADirectory+IncludeTrailingPathDelimiter('libgc'));
   

packages/fpmake_proc.inc

@@ -758,3 +758,9 @@ begin
   with Installer do
 {$include pastojs/fpmake.pp}
 end;
+
+procedure add_libgc(const ADirectory: string);
+begin
+  with Installer do
+{$include libgc/fpmake.pp}
+end;

packages/libgc/Makefile.fpc

@@ -0,0 +1,102 @@
+#
+#   Makefile.fpc for running fpmake
+#
+
+[package]
+name=libgc
+version=3.1.1
+
+[require]
+packages=rtl fpmkunit
+
+[install]
+fpcpackage=y
+
+[default]
+fpcdir=../..
+
+[prerules]
+FPMAKE_BIN_CLEAN=$(wildcard ./fpmake$(SRCEXEEXT))
+ifdef OS_TARGET
+FPC_TARGETOPT+=--os=$(OS_TARGET)
+endif
+ifdef CPU_TARGET
+FPC_TARGETOPT+=--cpu=$(CPU_TARGET)
+endif
+LOCALFPMAKE=./fpmake$(SRCEXEEXT)
+
+[rules]
+# Do not pass the Makefile's unit and binary target locations. Fpmake uses it's own.
+override FPCOPT:=$(filter-out -FU%,$(FPCOPT))
+override FPCOPT:=$(filter-out -FE%,$(FPCOPT))
+# Do not pass the package-unitdirectories. Fpmake adds those and this way they don't apear in the .fpm
+override FPCOPT:=$(filter-out $(addprefix -Fu,$(COMPILER_UNITDIR)),$(FPCOPT))# Compose general fpmake-parameters
+# Compose general fpmake-parameters
+ifdef FPMAKEOPT
+FPMAKE_OPT+=$(FPMAKEOPT)
+endif
+FPMAKE_OPT+=--localunitdir=../..
+FPMAKE_OPT+=--globalunitdir=..
+FPMAKE_OPT+=$(FPC_TARGETOPT)
+FPMAKE_OPT+=$(addprefix -o ,$(FPCOPT))
+FPMAKE_OPT+=--compiler=$(FPC)
+FPMAKE_OPT+=-bu
+.NOTPARALLEL:
+
+fpmake$(SRCEXEEXT): fpmake.pp
+	$(FPCFPMAKE) fpmake.pp $(FPMAKE_SKIP_CONFIG) $(addprefix -Fu,$(COMPILER_FPMAKE_UNITDIR)) $(FPCMAKEOPT) $(OPT)
+all:	fpmake$(SRCEXEEXT)
+	$(LOCALFPMAKE) compile $(FPMAKE_OPT)
+smart:	fpmake$(SRCEXEEXT)
+	$(LOCALFPMAKE) compile $(FPMAKE_OPT) -o -XX -o -CX
+release:	fpmake$(SRCEXEEXT)
+	$(LOCALFPMAKE) compile $(FPMAKE_OPT) -o -dRELEASE
+debug:	fpmake$(SRCEXEEXT)
+	$(LOCALFPMAKE) compile $(FPMAKE_OPT) -o -dDEBUG
+# If no fpmake exists and (dist)clean is called, do not try to build fpmake, it will
+# most often fail because the dependencies are cleared.
+# In case of a clean, simply do nothing
+ifeq ($(FPMAKE_BIN_CLEAN),)
+clean:
+else
+clean:
+	$(FPMAKE_BIN_CLEAN) clean $(FPMAKE_OPT)
+endif
+# In case of a distclean, perform an 'old'-style distclean. This to avoid problems
+# when the package is compiled using fpcmake prior to running this clean using fpmake
+ifeq ($(FPMAKE_BIN_CLEAN),)
+distclean:	$(addsuffix _distclean,$(TARGET_DIRS)) fpc_cleanall
+else
+distclean:
+ifdef inUnix
+        { $(FPMAKE_BIN_CLEAN) distclean $(FPMAKE_OPT); if [ $$? != "0" ]; then { echo Something wrong with fpmake exectable. Remove the executable and call make recursively to recover.; $(DEL) $(FPMAKE_BIN_CLEAN); $(MAKE) fpc_cleanall; }; fi;  }
+else
+        $(FPMAKE_BIN_CLEAN) distclean $(FPMAKE_OPT)
+endif
+	-$(DEL) $(LOCALFPMAKE)
+endif
+cleanall: distclean
+install:	fpmake$(SRCEXEEXT)
+ifdef UNIXHier
+	$(LOCALFPMAKE) install $(FPMAKE_OPT) --prefix=$(INSTALL_PREFIX) --baseinstalldir=$(INSTALL_LIBDIR)/fpc/$(FPC_VERSION) --unitinstalldir=$(INSTALL_UNITDIR)
+else
+	$(LOCALFPMAKE) install $(FPMAKE_OPT) --prefix=$(INSTALL_BASEDIR) --baseinstalldir=$(INSTALL_BASEDIR) --unitinstalldir=$(INSTALL_UNITDIR)
+endif
+# distinstall also installs the example-sources and omits the location of the source-
+# files from the fpunits.cfg files.
+distinstall:	fpmake$(SRCEXEEXT)
+ifdef UNIXHier
+	$(LOCALFPMAKE) install $(FPMAKE_OPT) --prefix=$(INSTALL_PREFIX) --baseinstalldir=$(INSTALL_LIBDIR)/fpc/$(FPC_VERSION) --unitinstalldir=$(INSTALL_UNITDIR) -ie -fsp 0
+else
+	$(LOCALFPMAKE) install $(FPMAKE_OPT) --prefix=$(INSTALL_BASEDIR) --baseinstalldir=$(INSTALL_BASEDIR) --unitinstalldir=$(INSTALL_UNITDIR) -ie -fsp 0
+endif
+zipinstall:	fpmake$(SRCEXEEXT)
+	$(LOCALFPMAKE) zipinstall $(FPMAKE_OPT) --zipprefix=$(DIST_DESTDIR)/$(ZIPPREFIX)
+zipdistinstall:	fpmake$(SRCEXEEXT)
+	$(LOCALFPMAKE) zipinstall $(FPMAKE_OPT) --zipprefix=$(DIST_DESTDIR)/$(ZIPPREFIX) -ie -fsp 0
+zipsourceinstall:	fpmake$(SRCEXEEXT)
+ifdef UNIXHier
+	$(LOCALFPMAKE) archive $(FPMAKE_OPT) --zipprefix=$(DIST_DESTDIR)/$(ZIPPREFIX) --prefix=share/src/fpc-\$$\(PACKAGEVERSION\)/$(INSTALL_FPCSUBDIR)/\$$\(PACKAGEDIRECTORY\)
+else
+	$(LOCALFPMAKE) archive $(FPMAKE_OPT) --zipprefix=$(DIST_DESTDIR)/$(ZIPPREFIX) --prefix=source\\$(INSTALL_FPCSUBDIR)\\\$$\(PACKAGEDIRECTORY\)
+endif

packages/libgc/examples/create_leak.pp

@@ -0,0 +1,11 @@
+uses gcmem;  // use new Boehm GC collector and create leaks
+
+var p:^integer;
+    i:integer;
+    
+begin
+for i:=0 to 99 do
+  begin
+  new(p); //pointers created, never tidied up
+  end;
+end.

packages/libgc/examples/testcmem.pp

@@ -0,0 +1,28 @@
+program testmem;
+
+{$mode objfpc}
+
+uses gcmem;  //use gcmem istead of cmem
+
+Type
+  PLongint = ^Longint;
+
+Var P : PLongint;
+    i : longint;
+    err : boolean;
+begin
+  P:=GetMem(1000*SizeOf(Longint));
+  For I:=0 to 999 do
+    P[i]:=i;
+  P:=ReallocMem(P,500*SizeOf(Longint));
+  For I:=0 to 499 do
+    if P[i]<>i Then
+      begin
+        Writeln ('Oh-oh, ',i,'th index differs.');
+        err:=true;
+      end;
+  FreeMem(P);
+  Writeln (err);
+  if err then
+    halt(1);
+end.

packages/libgc/examples/usage.txt

@@ -0,0 +1,2 @@
+Boehm GC can act as a leak detector. In order to be used so, the library must be compiled in a special way and preloaded, see www.hboehm.info/gc/leak.html
+

packages/libgc/fpmake.pp

@@ -0,0 +1,32 @@
+{$ifndef ALLPACKAGES}
+{$mode objfpc}{$H+}
+program fpmake;
+
+uses fpmkunit;
+
+Var
+  P : TPackage;
+  T : TTarget;
+begin
+  With Installer do
+    begin
+{$endif ALLPACKAGES}
+
+    P:=AddPackage('libgc');
+    P.ShortName:='libgc';
+{$ifdef ALLPACKAGES}
+    P.Directory:=ADirectory;
+{$endif ALLPACKAGES}
+    P.Version:='3.1.1';
+    P.SourcePath.Add('src');
+    P.IncludePath.Add('src');
+    P.OSes := [linux];
+    T:=P.Targets.AddUnit('gcmem.pp');
+    P.ExamplePath.Add('examples');
+    P.Targets.AddExampleProgram('testcmem.pp');
+    P.Targets.AddExampleProgram('create_leak.pp');
+{$ifndef ALLPACKAGES}
+    Run;
+    end;
+end.
+{$endif ALLPACKAGES}

packages/libgc/src/gcmem.pp

@@ -0,0 +1,164 @@
+unit gcmem;
+
+interface
+
+{$IFDEF FPC}
+{$PACKRECORDS C}
+{$ENDIF}
+
+Const
+  LibName = 'gc';
+
+type
+    ptrdiff_t = longint;
+    size_t = dword;
+    wchar_t = longint;
+    GC_PTR = pointer;
+    GC_word = dword;
+    GC_signed_word = longint;
+
+// procedure GC_init;cdecl; external LibName name 'GC_init';
+// not needed
+Function Malloc(Size : size_t) : Pointer; cdecl; external LibName name 'GC_malloc';
+Procedure Free(P : pointer); cdecl; external LibName name 'GC_free';
+function ReAlloc(P : Pointer; Size : size_t) : pointer; cdecl; external LibName name 'GC_realloc';
+Function Calloc(unitSize,UnitCount : size_t) : pointer;
+
+
+implementation
+
+Function Calloc(unitSize,UnitCount : size_t) : pointer;
+var p:pointer;
+
+begin
+  p:=Malloc(unitSize*UnitCount);
+  if p<>nil then FillChar(p^, unitSize*UnitCount,0); //not needed
+  //GC_malloc seems to clear memory
+  Calloc:=p;
+end;
+
+
+Function CGetMem  (Size : ptruint) : Pointer;
+
+begin
+  CGetMem:=Malloc(size_t(Size+sizeof(ptruint)));
+  if (CGetMem <> nil) then
+    begin
+      Pptruint(CGetMem)^ := size;
+      inc(CGetMem,sizeof(ptruint));
+    end;
+end;
+
+Function CFreeMem (P : pointer) : ptruint;
+
+begin
+  if (p <> nil) then
+    dec(p,sizeof(ptruint));
+  Free(P);
+  CFreeMem:=0;
+end;
+
+Function CFreeMemSize(p:pointer;Size:ptruint):ptruint;
+
+begin
+  if size<=0 then
+    exit;
+  if (p <> nil) then
+    begin
+      if (size <> Pptruint(p-sizeof(ptruint))^) then
+        runerror(204);
+    end;
+  CFreeMemSize:=CFreeMem(P);
+end;
+
+Function CAllocMem(Size : ptruint) : Pointer;
+
+begin
+  CAllocMem:=calloc(size_t(Size+sizeof(ptruint)),size_t(1));
+  if (CAllocMem <> nil) then
+    begin
+      Pptruint(CAllocMem)^ := size;
+      inc(CAllocMem,sizeof(ptruint));
+    end;
+end;
+
+Function CReAllocMem (var p:pointer;Size:ptruint):Pointer;
+
+begin
+  if size=0 then
+    begin
+      if p<>nil then
+        begin
+          dec(p,sizeof(ptruint));
+          free(p);
+          p:=nil;
+        end;
+    end
+  else
+    begin
+      inc(size,sizeof(ptruint));
+      if p=nil then
+        p:=malloc(size_t(Size))
+      else
+        begin
+          dec(p,sizeof(ptruint));
+          p:=realloc(p,size_t(size));
+        end;
+      if (p <> nil) then
+        begin
+          Pptruint(p)^ := size-sizeof(ptruint);
+          inc(p,sizeof(ptruint));
+        end;
+    end;
+  CReAllocMem:=p;
+end;
+
+Function CMemSize (p:pointer): ptruint;
+
+begin
+  CMemSize:=Pptruint(p-sizeof(ptruint))^;
+end;
+
+function CGetHeapStatus:THeapStatus;
+
+var res: THeapStatus;
+
+begin
+  fillchar(res,sizeof(res),0);
+  CGetHeapStatus:=res;
+end;
+
+function CGetFPCHeapStatus:TFPCHeapStatus;
+
+begin
+  fillchar(CGetFPCHeapStatus,sizeof(CGetFPCHeapStatus),0);
+end;
+
+Const
+ CMemoryManager : TMemoryManager =
+    (
+      NeedLock : false;
+      GetMem : @CGetmem;
+      FreeMem : @CFreeMem;
+      FreememSize : @CFreememSize;
+      AllocMem : @CAllocMem;
+      ReallocMem : @CReAllocMem;
+      MemSize : @CMemSize;
+      InitThread : nil;
+      DoneThread : nil;
+      RelocateHeap : nil;
+      GetHeapStatus : @CGetHeapStatus;
+      GetFPCHeapStatus: @CGetFPCHeapStatus;
+    );
+
+Var
+  OldMemoryManager : TMemoryManager;
+
+Initialization
+  GetMemoryManager (OldMemoryManager);
+  SetMemoryManager (CmemoryManager);
+
+Finalization
+  SetMemoryManager (OldMemoryManager);
+end.
+