first take for atom garbage collector.

git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@513 b08c6af1-5177-4d33-ba66-4b1c6b8b522a

C/agc.c

@@ -0,0 +1,368 @@
+/*************************************************************************
+*									 *
+*	 YAP Prolog 							 *
+*									 *
+*	Yap Prolog was developed at NCCUP - Universidade do Porto	 *
+*									 *
+* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997	 *
+*									 *
+**************************************************************************
+*									 *
+* File:		agc.c							 *
+* Last rev:								 *
+* mods:									 *
+* comments:	reclaim unused atoms and functors			 *
+*									 *
+*************************************************************************/
+#ifdef SCCS
+static char     SccsId[] = "@(#)agc.c	1.3 3/15/90";
+#endif
+
+
+#include "absmi.h"
+#include "alloc.h"
+
+#ifdef DEBUG
+#include "yapio.h"
+/* #define DEBUG_RESTORE2 1 */
+#define errout YP_stderr
+#endif
+
+STATIC_PROTO(void  RestoreEntries, (PropEntry *));
+STATIC_PROTO(void  ConvDBList, (Term, char *,CELL));
+
+#define AtomMarkedBit 1
+
+static inline void
+MarkAtomEntry(AtomEntry *ae)
+{
+  CELL c = (CELL)(ae->NextOfAE);
+  c |= AtomMarkedBit;
+  ae->NextOfAE = (Atom)c;
+}
+
+static inline int
+AtomResetMark(AtomEntry *ae)
+{
+  CELL c = (CELL)(ae->NextOfAE);
+  if (c & AtomMarkedBit) {
+    c &= ~AtomMarkedBit;
+    ae->NextOfAE = (Atom)c;
+    return (TRUE);
+  }
+  return (FALSE);
+}
+
+static inline Atom
+CleanAtomMarkedBit(Atom a)
+{
+  CELL c = (CELL)a;
+  c &= ~AtomMarkedBit;
+  return((Atom)c);
+}
+
+static inline Functor
+FuncAdjust(Functor f)
+{
+  AtomEntry *ae = RepAtom(NameOfFunctor(f));
+  MarkAtomEntry(ae);
+  return(f);
+}
+
+
+static inline Term
+AtomTermAdjust(Term t)
+{
+  AtomEntry *ae = RepAtom(AtomOfTerm(t));
+  MarkAtomEntry(ae);
+  return(t);  
+}
+
+static inline Atom
+AtomAdjust(Atom a)
+{
+  AtomEntry *ae;
+  if (a == NIL) return(a);
+  ae = RepAtom(a);
+  MarkAtomEntry(ae);
+  return(a);
+}
+
+#define HDiff TRUE
+
+#define OldHeapTop HeapTop
+
+#define IsOldCode(P) FALSE
+#define IsOldCodeCellPtr(P) FALSE
+#define IsOldDelay(P) FALSE
+#define IsOldDelayPtr(P) FALSE
+#define IsOldLocalInTR(P) FALSE
+#define IsOldLocalInTRPtr(P) FALSE
+#define IsOldGlobal(P) FALSE
+#define IsOldGlobalPtr(P) FALSE
+#define IsOldTrail(P) FALSE
+#define IsOldTrailPtr(P) FALSE
+
+#define CharP(X) ((char *)(X))
+
+#define AddrAdjust(P) (P)
+#define AtomEntryAdjust(P) (P)
+#define BlobTermAdjust(P) (P)
+#define CellPtoHeapAdjust(P) (P)
+#define CellPtoHeapCellAdjust(P) (P)
+#define CellPtoTRAdjust(P) (P)
+#define CodeAddrAdjust(P) (P)
+#define ConsultObjAdjust(P) (P)
+#define DelayAddrAdjust(P) (P)
+#define DBRefAdjust(P) (P)
+#define LocalAddrAdjust(P) (P)
+#define GlobalAddrAdjust(P) (P)
+#define PtoArrayEAdjust(P) (P)
+#define PtoDelayAdjust(P) (P)
+#define PtoGloAdjust(P) (P)
+#define PtoLocAdjust(P) (P)
+#define PtoHeapCellAdjust(P) (P)
+#define PtoOpAdjust(P) (P)
+#define PtoPredAdjust(P) (P)
+#define PropAdjust(P) (P)
+#define TrailAddrAdjust(P) (P)
+#define XAdjust(P) (P)
+#define YAdjust(P) (P)
+
+static void
+recompute_mask(DBRef dbr)
+{
+  return;
+}
+
+static CODEADDR
+CCodeAdjust(PredEntry *pe, CODEADDR c)
+{
+  /* add this code to a list of ccalls that must be adjusted */
+  
+  return c;
+}
+
+static CODEADDR
+NextCCodeAdjust(PredEntry *pe, CODEADDR c)
+{
+  /* add this code to a list of ccalls that must be adjusted */
+  
+  return c;
+}
+
+static CODEADDR
+DirectCCodeAdjust(PredEntry *pe, CODEADDR c)
+{
+  /* add this code to a list of ccalls that must be adjusted */
+  
+  return (c);
+}
+
+static void 
+rehash(CELL *oldcode, int NOfE, int KindOfEntries)
+{
+}
+
+#include "rheap.h"
+
+/*
+ * This is the really tough part, to restore the whole of the heap 
+ */
+static void 
+mark_atoms(void)
+{
+  AtomHashEntry *HashPtr = HashChain;
+  register int    i;
+  Atom atm;
+  AtomEntry      *at;
+
+  restore_codes();
+  for (i = 0; i < MaxHash; ++i) {
+    atm = HashPtr->Entry;
+    if (atm) {
+      at =  RepAtom(atm);
+      do {
+#ifdef DEBUG_RESTORE2			/* useful during debug */
+	YP_fprintf(errout, "Restoring %s\n", at->StrOfAE);
+#endif
+	RestoreEntries(RepProp(at->PropsOfAE));
+	atm = at->NextOfAE;
+	at = RepAtom(CleanAtomMarkedBit(atm));
+      } while (!EndOfPAEntr(at));
+    }
+    HashPtr++;
+  }
+
+  atm = INVISIBLECHAIN.Entry;
+  at = RepAtom(atm);
+  if (EndOfPAEntr(at)) {
+    return;
+  }
+  do {
+#ifdef DEBUG_RESTORE2		/* useful during debug */
+    YP_fprintf(errout, "Restoring %s\n", at->StrOfAE);
+    if (strcmp(at->StrOfAE,"$module_expansion") == 0) {
+      printf("oops\n");
+    }
+#endif
+    RestoreEntries(RepProp(at->PropsOfAE));
+    atm = at->NextOfAE;
+    at = RepAtom(CleanAtomMarkedBit(atm));
+  } while (!EndOfPAEntr(at));
+}
+
+static void
+mark_trail(void)
+{
+  register CELL *pt;
+
+  pt = (CELL *)TR;
+  /* moving the trail is simple */
+  while (pt != (CELL *)TrailBase) {
+    register CELL reg = pt[-1];
+    pt--;
+    if (!IsVarTerm(reg)) {
+      if (IsAtomTerm(reg)) {
+	MarkAtomEntry(RepAtom(AtomOfTerm(reg)));
+      }
+    }
+  }
+}
+
+static void
+mark_local(void)
+{
+  register CELL   *pt;
+
+  /* Adjusting the local */
+  pt = LCL0;
+  /* moving the trail is simple */
+  while (pt > ASP) {
+    CELL reg = *--pt;
+
+    if (!IsVarTerm(reg)) {
+      if (IsAtomTerm(reg)) {
+	MarkAtomEntry(RepAtom(AtomOfTerm(reg)));
+      }
+    }
+  }
+}
+
+static void
+mark_global(void)
+{
+  register CELL *pt;
+
+  /*
+   * to clean the global now that functors are just variables pointing to
+   * the code 
+   */
+  pt = CellPtr(GlobalBase);
+  while (pt < H) {
+    register CELL reg;
+    
+    reg = *pt;
+    if (IsVarTerm(reg)) {
+      pt++;
+      continue;
+    } else if (IsAtomTerm(reg)) {
+      	MarkAtomEntry(RepAtom(AtomOfTerm(reg)));
+    } else if (IsApplTerm(reg)) {
+      Functor f = FunctorOfTerm(reg);
+      if (f <= FunctorDouble && f >= FunctorLongInt) {
+	/* skip bitmaps */
+	switch((CELL)f) {
+	case (CELL)FunctorDouble:
+#if SIZEOF_DOUBLE == 2*SIZEOF_LONG_INT
+	  pt += 3;
+#else
+	  pt += 2;
+#endif
+	  break;
+#if USE_GMP
+	case (CELL)FunctorBigInt:
+	  {
+	    Int sz = 1+
+	      sizeof(MP_INT)+
+	      (((MP_INT *)(pt+1))->_mp_alloc*sizeof(mp_limb_t));
+	    pt += sz;
+	  }
+	  break;
+#endif
+	case (CELL)FunctorLongInt:
+	default:
+	  pt += 2;
+	  break;
+	}
+      }
+    }
+    pt++;
+  }
+}
+
+static void
+mark_stacks(void)
+{
+  mark_trail();
+  mark_local();
+  mark_global();
+}
+
+/*
+ * This is the really tough part, to restore the whole of the heap 
+ */
+static void 
+clean_atoms(void)
+{
+  AtomHashEntry *HashPtr = HashChain;
+  register int    i;
+  Atom atm;
+  Atom *patm;
+  AtomEntry  *at;
+
+  for (i = 0; i < MaxHash; ++i) {
+    atm = HashPtr->Entry;
+    patm = &(HashPtr->Entry);
+    while (atm != NIL) {
+      at =  RepAtom(CleanAtomMarkedBit(atm));
+      if (AtomResetMark(at) || (AGCHook != NULL && !AGCHook(atm))) {
+	patm = &(at->NextOfAE);
+	atm = at->NextOfAE;
+      } else {
+#ifdef DEBUG_RESTORE2
+	fprintf(stderr, "Purged %s\n", at->StrOfAE);
+#endif
+	*patm = at->NextOfAE;
+	atm = at->NextOfAE;
+	FreeCodeSpace((char *)at);
+      }
+    }
+    HashPtr++;
+  }
+  patm = &(INVISIBLECHAIN.Entry);
+  atm = INVISIBLECHAIN.Entry;
+  while (atm != NIL) {
+    at =  RepAtom(CleanAtomMarkedBit(atm));
+    if (AtomResetMark(at) || (AGCHook != NULL && !AGCHook(atm))) {
+      patm = &(atm->NextOfAE);
+      atm = at->NextOfAE;
+    } else {
+#ifdef DEBUG_RESTORE2
+      fprintf(stderr, "Purged %s\n", at->StrOfAE);
+#endif
+      *patm = at->NextOfAE;
+      atm = at->NextOfAE;
+      FreeCodeSpace((char *)at);
+    }
+  }
+}
+
+void
+atom_gc(void)
+{
+  mark_stacks();
+  mark_atoms();
+  clean_atoms();
+  LookupAtom("!");
+}

C/amasm.c

@@ -2389,7 +2389,8 @@ do_pass(void)
     case label_op:
       if (!ystop_found &&
 	  cpc->nextInst != NULL &&
-	  cpc->nextInst->op == mark_initialised_pvars_op) {
+	  (cpc->nextInst->op == mark_initialised_pvars_op ||
+	   cpc->nextInst->op == blob_op)) {
 	ystop_found = TRUE;
 	a_e(_Ystop);
       }

C/heapgc.c

@@ -3096,9 +3096,19 @@ p_gc(void)
   return(TRUE);
 }
 
+static Int
+p_atom_gc(void)
+{
+#ifndef FIXED_STACKS
+  atom_gc();
+#endif  /* FIXED_STACKS */
+  return(TRUE);
+}
+
 void 
 init_gc(void)
 {
   InitCPred("$gc", 0, p_gc, 0);
   InitCPred("$inform_gc", 3, p_inform_gc, 0);
+  InitCPred("$atom_gc", 0, p_atom_gc, 0);
 }

C/init.c

@@ -1029,6 +1029,7 @@ InitCodes(void)
   heap_regs->file_aliases = NULL;
   heap_regs->foreign_code_loaded = NULL;
   heap_regs->yap_lib_dir = NULL;
+  heap_regs->agc_hook = NULL;
   heap_regs->size_of_overflow  = 0;
   /* make sure no one else can use these two atoms */
   CurrentModule = 0;

H/Heap.h

@@ -10,7 +10,7 @@
 * File:		Heap.h         						 *
 * mods:									 *
 * comments:	Heap Init Structure					 *
-* version:      $Id: Heap.h,v 1.27 2002-06-04 00:46:32 vsc Exp $	 *
+* version:      $Id: Heap.h,v 1.28 2002-06-04 18:21:54 vsc Exp $	 *
 *************************************************************************/
 
 /* information that can be stored in Code Space */
@@ -27,6 +27,8 @@ typedef struct atom_hash_entry {
   Atom Entry;
 } AtomHashEntry;
 
+typedef int   (*Agc_hook)(Atom);
+
 typedef struct various_codes {
   special_functors funcs;
   Int heap_used;
@@ -288,6 +290,7 @@ typedef struct various_codes {
   struct AliasDescS * file_aliases;
   void *foreign_code_loaded;
   char *yap_lib_dir;
+  Agc_hook  agc_hook;
 #if defined(YAPOR) || defined(TABLING)
   struct global_data global;
   struct local_data remote[MAX_WORKERS];
@@ -481,6 +484,7 @@ typedef struct various_codes {
 #define  FileAliases              heap_regs->file_aliases
 #define  ForeignCodeLoaded        heap_regs->foreign_code_loaded
 #define  Yap_LibDir               heap_regs->yap_lib_dir
+#define  AGCHook                  heap_regs->agc_hook
 #define  DeadClauses              heap_regs->dead_clauses
 #define  SizeOfOverflow           heap_regs->size_of_overflow
 #define  LastWtimePtr             heap_regs->last_wtime

H/Yapproto.h

@@ -10,7 +10,7 @@
 * File:		Yap.proto						 *
 * mods:									 *
 * comments:	Function declarations for YAP				 *
-* version:      $Id: Yapproto.h,v 1.18 2002-05-16 20:33:00 vsc Exp $	 *
+* version:      $Id: Yapproto.h,v 1.19 2002-06-04 18:21:55 vsc Exp $	 *
 *************************************************************************/
 
 /* prototype file for Yap */
@@ -62,6 +62,8 @@ Prop	STD_PROTO(GetExpProp,(Atom,unsigned int));
 Prop	STD_PROTO(GetExpPropHavingLock,(AtomEntry *,unsigned int));
 Term    STD_PROTO(Module_Name, (CODEADDR));
 
+/* agc.c */
+void    STD_PROTO(atom_gc, (void));
 
 /* alloc.c */
 int	STD_PROTO(SizeOfBlock,(CODEADDR));

Makefile.in

@@ -110,6 +110,7 @@ HEADERS = \
 	$(srcdir)/H/clause.h $(srcdir)/H/compile.h \
 	$(srcdir)/H/corout.h $(srcdir)/H/eval.h $(srcdir)/H/heapgc.h   \
 	$(srcdir)/H/index.h $(srcdir)/H/iopreds.h \
+	$(srcdir)/H/rheap.h \
 	$(srcdir)/H/tracer.h $(srcdir)/H/yapio.h \
 	$(srcdir)/OPTYap/opt.config.h \
 	$(srcdir)/OPTYap/opt.proto.h $(srcdir)/OPTYap/opt.structs.h \
@@ -121,7 +122,8 @@ HEADERS = \
 	$(srcdir)/OPTYap/alpha_locks_funcs.h
 
 C_SOURCES= \
-	$(srcdir)/C/absmi.c $(srcdir)/C/adtdefs.c $(srcdir)/C/alloc.c \
+	$(srcdir)/C/absmi.c $(srcdir)/C/adtdefs.c \
+	$(srcdir)/C/agc.c $(srcdir)/C/alloc.c \
 	$(srcdir)/C/amasm.c $(srcdir)/C/analyst.c \
 	$(srcdir)/C/arith0.c $(srcdir)/C/arith1.c $(srcdir)/C/arith2.c \
 	$(srcdir)/C/arrays.c \
@@ -138,7 +140,8 @@ C_SOURCES= \
 	$(srcdir)/C/load_aout.c $(srcdir)/C/load_aix.c $(srcdir)/C/load_dll.c \
 	$(srcdir)/C/load_shl.c \
 	$(srcdir)/C/mavar.c $(srcdir)/C/modules.c $(srcdir)/C/other.c       \
-	$(srcdir)/C/parser.c $(srcdir)/C/save.c $(srcdir)/C/scanner.c \
+	$(srcdir)/C/parser.c \
+	$(srcdir)/C/save.c $(srcdir)/C/scanner.c \
 	$(srcdir)/C/sort.c $(srcdir)/C/stdpreds.c $(srcdir)/C/sysbits.c \
 	$(srcdir)/C/tracer.c $(srcdir)/C/unify.c $(srcdir)/C/userpreds.c  \
 	$(srcdir)/C/utilpreds.c $(srcdir)/C/write.c $(srcdir)/console/yap.c \
@@ -169,7 +172,7 @@ PL_SOURCES= \
 	$(srcdir)/pl/yapor.yap $(srcdir)/pl/yio.yap
 
 ENGINE_OBJECTS = \
-	absmi.o adtdefs.o alloc.o amasm.o analyst.o arrays.o \
+	agc.o absmi.o adtdefs.o alloc.o amasm.o analyst.o arrays.o \
 	arith0.o arith1.o arith2.o attvar.o bb.o \
 	cdmgr.o cmppreds.o compiler.o computils.o \
 	corout.o dbase.o errors.o eval.o bignum.o \
@@ -247,6 +250,9 @@ absmi.o: $(srcdir)/C/absmi.c
 adtdefs.o: $(srcdir)/C/adtdefs.c
 	$(CC) -c $(CFLAGS) $(srcdir)/C/adtdefs.c -o $@
 
+agc.o: $(srcdir)/C/agc.c
+	$(CC) -c $(CFLAGS) $(srcdir)/C/agc.c -o $@
+
 alloc.o: $(srcdir)/C/alloc.c
 	$(CC) -c $(CFLAGS) $(srcdir)/C/alloc.c -o $@
 

changes4.3.html

@@ -16,6 +16,7 @@
 
 <h2>Yap-4.3.22:</h2>
 <ul>
+	<li>NEW: atom garbage collector.</li>
 	<li>FIXED: recover space for logical update semantics.</li>
 	<li>FIXED: smash references to deleted entries with logical
 	update semantics.</li>

library/yap2swi/yap2swi.c

@@ -1,7 +1,7 @@
 /* yap2swi.c  */
 /*
  * Project: jpl for Yap Prolog
- * Author: Steve Moyle
+ * Author: Steve Moyle and Vitor Santos Costa
  * Email:  steve.moyle@comlab.ox.ac.uk
  * Date:   21 January 2002
 
@@ -36,7 +36,8 @@ alloc_ring_buf(void)
    YAP: NO EQUIVALENT */
 
 /* dummy function for now (until Vitor comes through!)*/
-X_API void PL_agc_hook(void)
+X_API PL_agc_hook_t
+PL_agc_hook(PL_agc_hook_t entry)
 {
 }
 

library/yap2swi/yap2swi.h

@@ -28,6 +28,7 @@ typedef Atom	atom_t;
 typedef	Term    *predicate_t;
 typedef struct  open_query_struct *qid_t;
 typedef long    functor_t;
+typedef int     (*PL_agc_hook_t)(atom_t);
 
 typedef int (*CPredicate)(void);
 
@@ -86,7 +87,7 @@ typedef struct _PL_extension
 /* end from pl-itf.h */
 
 
-extern X_API void PL_agc_hook(void);
+extern X_API PL_agc_hook_t PL_agc_hook(PL_agc_hook_t);
 extern X_API char* PL_atom_chars(atom_t);
 extern X_API term_t PL_copy_term_ref(term_t);
 extern X_API term_t PL_new_term_ref(void);

pl/utils.yap

@@ -613,6 +613,9 @@ gc :-
 nogc :-
 	yap_flag(gc,off).
 
+garbage_collect_atoms :-
+	'$atom_gc'.
+
 '$force_environment_for_gc'.
 
 '$good_list_of_character_codes'(V) :- var(V), !.