yap-6.3/C/agc.c

/*************************************************************************
*									 *
*	 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 "Foreign.h"
#include "alloc.h"
#include "yapio.h"
#include "iopreds.h"
#include "attvar.h"

#ifdef DEBUG
/* #define DEBUG_RESTORE1 1 */
/* #define DEBUG_RESTORE2 1 */
/* #define DEBUG_RESTORE3 1 */
#define errout GLOBAL_stderr
#endif

static void  RestoreEntries(PropEntry *, int USES_REGS);
static void  CleanCode(PredEntry * USES_REGS);

#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)
{
  if (!IsExtensionFunctor(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 Term
TermToGlobalOrAtomAdjust(Term t)
{
  if (t && IsAtomTerm(t))
    return AtomTermAdjust(t);
  return(t);
}

static inline Atom
AtomAdjust(Atom a)
{
  AtomEntry *ae;
  if (a == NIL) return(a);
  ae = RepAtom(a);
  MarkAtomEntry(ae);
  return(a);
}

#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 REINIT_LOCK(P) 
#define REINIT_RWLOCK(P) 
#define BlobTypeAdjust(P) (P)
#define NoAGCAtomAdjust(P) (P)
#define OrArgAdjust(P) 
#define TabEntryAdjust(P) 
#define IntegerAdjust(D)  (D)
#define AddrAdjust(P) (P)
#define MFileAdjust(P) (P)
#define CodeVarAdjust(P) (P)
#define ConstantAdjust(P) (P)
#define ArityAdjust(P) (P)
#define DoubleInCodeAdjust(P) 
#define IntegerInCodeAdjust(P) 
#define OpcodeAdjust(P) (P)
#define ModuleAdjust(P) (P)
#define ExternalFunctionAdjust(P) (P)
#define DBRecordAdjust(P) (P)
#define PredEntryAdjust(P) (P)
#define ModEntryPtrAdjust(P) (P)
#define AtomEntryAdjust(P) (P)
#define GlobalEntryAdjust(P) (P)
#define BlobTermInCodeAdjust(P) (P)
#define CellPtoHeapAdjust(P) (P)
#define PtoAtomHashEntryAdjust(P) (P)
#define CellPtoHeapCellAdjust(P) (P)
#define CellPtoTRAdjust(P) (P)
#define CodeAddrAdjust(P) (P)
#define ConsultObjAdjust(P) (P)
#define DelayAddrAdjust(P) (P)
#define DelayAdjust(P) (P)
#define GlobalAdjust(P) (P)
#define DBRefAdjust(P,REF) (P)
#define DBRefPAdjust(P) (P)
#define DBTermAdjust(P) (P)
#define LUIndexAdjust(P) (P)
#define SIndexAdjust(P) (P)
#define LocalAddrAdjust(P) (P)
#define GlobalAddrAdjust(P) (P)
#define OpListAdjust(P) (P)
#define PtoLUCAdjust(P) (P)
#define PtoStCAdjust(P) (P)
#define PtoArrayEAdjust(P) (P)
#define PtoArraySAdjust(P) (P)
#define PtoGlobalEAdjust(P) (P)
#define PtoDelayAdjust(P) (P)
#define PtoGloAdjust(P) (P)
#define PtoLocAdjust(P) (P)
#define PtoHeapCellAdjust(P) (P)
#define TermToGlobalAdjust(P) (P)
#define PtoOpAdjust(P) (P)
#define PtoLUClauseAdjust(P) (P)
#define PtoLUIndexAdjust(P) (P)
#define PtoDBTLAdjust(P) (P)
#define PtoPredAdjust(P) (P)
#define PtoPtoPredAdjust(P) (P)
#define OpRTableAdjust(P) (P)
#define OpEntryAdjust(P) (P)
#define PropAdjust(P) (P)
#define TrailAddrAdjust(P) (P)
#define XAdjust(P) (P)
#define YAdjust(P) (P)
#define HoldEntryAdjust(P) (P)
#define CodeCharPAdjust(P) (P)
#define CodeVoidPAdjust(P) (P)
#define HaltHookAdjust(P) (P)

#define recompute_mask(dbr)

#define rehash(oldcode, NOfE, KindOfEntries)

#define RestoreSWIHash()

#include "rheap.h"

static void
RestoreHashPreds( USES_REGS1 )
{
  UInt i;

  for (i = 0; i < PredHashTableSize; i++) {
    PredEntry *p = PredHash[i];

    if (p)
      p = PredEntryAdjust(p);
    while (p) {
      Prop nextp;
      
      if (p->NextOfPE)
	p->NextOfPE = PropAdjust(p->NextOfPE);
      nextp = p->NextOfPE;
      CleanCode(p PASS_REGS);
      p = RepPredProp(nextp);
    }
  }
}


static void init_reg_copies(USES_REGS1)
{
  LOCAL_OldASP = ASP;
  LOCAL_OldLCL0 = LCL0;
  LOCAL_OldTR = TR;
  LOCAL_OldGlobalBase = (CELL *)LOCAL_GlobalBase;
  LOCAL_OldH = H;
  LOCAL_OldH0 = H0;
  LOCAL_OldTrailBase = LOCAL_TrailBase;
  LOCAL_OldTrailTop = LOCAL_TrailTop;
  LOCAL_OldHeapBase = Yap_HeapBase;
  LOCAL_OldHeapTop = HeapTop;
}


static void
RestoreAtomList(Atom atm USES_REGS)
{
  AtomEntry      *at;

  at = RepAtom(atm);
  if (EndOfPAEntr(at))
    return;
  do {
    RestoreAtom(atm PASS_REGS);
    atm = CleanAtomMarkedBit(at->NextOfAE);
    at = RepAtom(atm);
  } while (!EndOfPAEntr(at));
}



static void
mark_trail(USES_REGS1)
{
  register tr_fr_ptr pt;

  pt = TR;
  /* moving the trail is simple */
  while (pt != (tr_fr_ptr)LOCAL_TrailBase) {
    CELL reg = TrailTerm(pt-1);

    if (!IsVarTerm(reg)) {
      if (IsAtomTerm(reg)) {
	MarkAtomEntry(RepAtom(AtomOfTerm(reg)));
      }
    }

    pt--;
  }
}

static void
mark_registers(USES_REGS1)
{
  CELL *pt;

  pt = XREGS;
  /* moving the trail is simple */
  while (pt != XREGS+MaxTemps) {
    CELL reg = *pt++;

    if (!IsVarTerm(reg)) {
      if (IsAtomTerm(reg)) {
	MarkAtomEntry(RepAtom(AtomOfTerm(reg)));
      }
    }
  }
}

static void
mark_local(USES_REGS1)
{
  CELL   *pt;

  /* Adjusting the local */
  pt = LCL0;
  /* moving the trail is simple */
  while (pt > ASP) {
    CELL reg = *--pt;

    if (!IsVarTerm(reg)) {
      if (IsAtomTerm(reg)
#ifdef TABLING
	  /* assume we cannot have atoms on first page,
	     so this must be an arity
	  */
	  && reg > Yap_page_size
#endif
	  ) {
	MarkAtomEntry(RepAtom(AtomOfTerm(reg)));
      }
    }
  }
}

static CELL *
mark_global_cell(CELL *pt)
{   
  CELL reg = *pt;

  if (IsVarTerm(reg)) {
    /* skip bitmaps */
    switch(reg) {
    case (CELL)FunctorDouble:
#if SIZEOF_DOUBLE == 2*SIZEOF_LONG_INT
      return pt + 4;
#else
      return pt + 3;
#endif
    case (CELL)FunctorBigInt:
      {
	Int sz = 3 +
	  (sizeof(MP_INT)+
	   (((MP_INT *)(pt+2))->_mp_alloc*sizeof(mp_limb_t)))/sizeof(CELL);
	Opaque_CallOnGCMark f;
	Opaque_CallOnGCRelocate f2;
	Term t = AbsAppl(pt);

	if ( (f = Yap_blob_gc_mark_handler(t)) ) {
	  CELL ar[256];
	  Int i,n = (f)(Yap_BlobTag(t), Yap_BlobInfo(t), ar, 256);
	  if (n < 0) {
	    Yap_Error(OUT_OF_HEAP_ERROR,TermNil,"not enough space for slot internal variables in agc");
	      }
	  for (i = 0; i< n; i++) {
	    CELL *pt = ar+i;
	    CELL reg = *pt;
	    if (!IsVarTerm(reg) && IsAtomTerm(reg)) {
	      *pt = AtomTermAdjust(reg);
	    }
	  }
	  if ( (f2 = Yap_blob_gc_relocate_handler(t)) < 0 ) {
	    int out = (f2)(Yap_BlobTag(t), Yap_BlobInfo(t), ar, n);
	    if (out < 0)
	      Yap_Error(OUT_OF_HEAP_ERROR,TermNil,"bad restore of slot internal variables in agc");
	  }
	}

	return pt + sz;
      }
    case (CELL)FunctorLongInt:
      return pt + 3;
      break;
    }
  } else if (IsAtomTerm(reg)) {
    MarkAtomEntry(RepAtom(AtomOfTerm(reg)));
    return pt+1;
  }
  return pt+1;
}

static void
mark_global(USES_REGS1)
{
  CELL *pt;

  /*
   * to clean the global now that functors are just variables pointing to
   * the code 
   */
  pt = H0;
  while (pt < H) {
    pt = mark_global_cell(pt);
  }
}

static void
mark_stacks(USES_REGS1)
{
  mark_registers(PASS_REGS1);
  mark_trail(PASS_REGS1);
  mark_local(PASS_REGS1);
  mark_global(PASS_REGS1);
}

static void
clean_atom_list(AtomHashEntry *HashPtr)
{
  Atom atm = HashPtr->Entry;
  Atom *patm = &(HashPtr->Entry);
  while (atm != NIL) {
    AtomEntry *at =  RepAtom(atm);
    if (AtomResetMark(at) ||
	( at->PropsOfAE != NIL && !IsBlob(at) ) ||
	(GLOBAL_AGCHook != NULL && !GLOBAL_AGCHook(atm))) {
      patm = &(at->NextOfAE);
      atm = at->NextOfAE;
    } else {
      NOfAtoms--;
      if (IsBlob(atm)) {
	BlobPropEntry *b = RepBlobProp(at->PropsOfAE);
	if (b->NextOfPE != NIL) {
	  patm = &(at->NextOfAE);
	  atm = at->NextOfAE;
	  continue;
	}
	NOfAtoms++;
	NOfBlobs--;
	Yap_FreeCodeSpace((char *)b);
	GLOBAL_agc_collected += sizeof(BlobPropEntry);
	GLOBAL_agc_collected += sizeof(AtomEntry)+sizeof(size_t)+at->rep.blob->length;
      } else if (IsWideAtom(atm)) {
#ifdef DEBUG_RESTORE3
	fprintf(stderr, "Purged %p:%S\n", at, at->WStrOfAE);
#endif
	GLOBAL_agc_collected += sizeof(AtomEntry)+wcslen(at->WStrOfAE);
      } else {
#ifdef DEBUG_RESTORE3
	fprintf(stderr, "Purged %p:%s patm=%p %p\n", at, at->StrOfAE, patm, at->NextOfAE);
#endif
	GLOBAL_agc_collected += sizeof(AtomEntry)+strlen(at->StrOfAE);
      }
      *patm = atm = at->NextOfAE;
      Yap_FreeCodeSpace((char *)at);
    }
  }
}

/*
 * This is the really tough part, to restore the whole of the heap 
 */
static void 
clean_atoms(void)
{
  AtomHashEntry *HashPtr = HashChain;
  register int    i;

  AtomResetMark(AtomFoundVar);
  AtomResetMark(AtomFreeTerm);
  for (i = 0; i < AtomHashTableSize; ++i) {
    clean_atom_list(HashPtr);
    HashPtr++;
  }
  HashPtr = WideHashChain;
  for (i = 0; i < WideAtomHashTableSize; ++i) {
    clean_atom_list(HashPtr);
    HashPtr++;
  }
  clean_atom_list(&INVISIBLECHAIN);
  {
    AtomHashEntry list;
    list.Entry = SWI_Blobs;
    clean_atom_list(&list);
  }
}

static void
atom_gc(USES_REGS1)
{
  int		gc_verbose = Yap_is_gc_verbose();
  int           gc_trace = 0;
  

  UInt		time_start, agc_time;
#if  defined(YAPOR) || defined(THREADS)
  return;
#endif
  if (Yap_GetValue(AtomGcTrace) != TermNil)
    gc_trace = 1;

  GLOBAL_agc_calls++;
  GLOBAL_agc_collected = 0;
  
  if (gc_trace) {
    fprintf(GLOBAL_stderr, "%% agc:\n");
  } else if (gc_verbose) {
    fprintf(GLOBAL_stderr, "%%   Start of atom garbage collection %d:\n", GLOBAL_agc_calls);
  }
  time_start = Yap_cputime();
  /* get the number of active registers */
  YAPEnterCriticalSection();
  init_reg_copies(PASS_REGS1);
  mark_stacks(PASS_REGS1);
  restore_codes();
  clean_atoms();
  NOfBlobsMax = NOfBlobs+(NOfBlobs/2+256< 1024 ? NOfBlobs/2+256 : 1024);
  YAPLeaveCriticalSection();
  agc_time = Yap_cputime()-time_start;
  GLOBAL_tot_agc_time += agc_time;
  GLOBAL_tot_agc_recovered += GLOBAL_agc_collected;
  if (gc_verbose) {
#ifdef _WIN32
    fprintf(GLOBAL_stderr, "%%   Collected %I64d bytes.\n", GLOBAL_agc_collected);
#else
    fprintf(GLOBAL_stderr, "%%   Collected %lld bytes.\n", GLOBAL_agc_collected);
#endif
    fprintf(GLOBAL_stderr, "%%   GC %d took %g sec, total of %g sec doing GC so far.\n", GLOBAL_agc_calls, (double)agc_time/1000, (double)GLOBAL_tot_agc_time/1000);
  }
}

void
Yap_atom_gc(USES_REGS1)
{
  atom_gc(PASS_REGS1);
}

static Int
p_atom_gc(USES_REGS1)
{
#ifndef FIXED_STACKS
  atom_gc(PASS_REGS1);
#endif  /* FIXED_STACKS */
  return TRUE;
}

static Int
p_inform_agc(USES_REGS1)
{
  Term tn = MkIntegerTerm(GLOBAL_tot_agc_time);
  Term tt = MkIntegerTerm(GLOBAL_agc_calls);
  Term ts = MkIntegerTerm(GLOBAL_tot_agc_recovered);

  return
    Yap_unify(tn, ARG2) &&
    Yap_unify(tt, ARG1) &&
    Yap_unify(ts, ARG3);
}

static Int
p_agc_threshold(USES_REGS1)
{
  Term t = Deref(ARG1);
  if (IsVarTerm(t)) {
    return Yap_unify(ARG1, MkIntegerTerm(GLOBAL_AGcThreshold));
  } else if (!IsIntegerTerm(t)) {
    Yap_Error(TYPE_ERROR_INTEGER,t,"prolog_flag/2 agc_margin");
    return FALSE;
  } else {
    Int i = IntegerOfTerm(t);
    if (i<0) {
      Yap_Error(DOMAIN_ERROR_NOT_LESS_THAN_ZERO,t,"prolog_flag/2 agc_margin");
      return FALSE;
    } else {
      GLOBAL_AGcThreshold = i;
      return TRUE;
    }
  }
}

void 
Yap_init_agc(void)
{
  Yap_InitCPred("$atom_gc", 0, p_atom_gc, 0);
  Yap_InitCPred("$inform_agc", 3, p_inform_agc, 0);
  Yap_InitCPred("$agc_threshold", 1, p_agc_threshold, SafePredFlag);
}