gc_mark.h

/* File:      gc_mark.h
** Author(s): Luis Castro, Bart Demoen, Kostis Sagonas
** Contact:   xsb-contact@cs.sunysb.edu
** 
** Copyright (C) The Research Foundation of SUNY, 1986, 1993-1998
** Copyright (C) ECRC, Germany, 1990
** 
** XSB is free software; you can redistribute it and/or modify it under the
** terms of the GNU Library General Public License as published by the Free
** Software Foundation; either version 2 of the License, or (at your option)
** any later version.
** 
** XSB is distributed in the hope that it will be useful, but WITHOUT ANY
** WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
** FOR A PARTICULAR PURPOSE.  See the GNU Library General Public License for
** more details.
** 
** You should have received a copy of the GNU Library General Public License
** along with XSB; if not, write to the Free Software Foundation,
** Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
**
** $Id: gc_mark.h,v 1.18 2006/04/24 19:34:14 dwarren Exp $
** 
*/

#ifndef MULTI_THREAD
extern Structure_Manager smTSTN;
#endif

extern Structure_Manager smTableBTN;
extern Structure_Manager smAssertBTN;
extern PrRef dynpredep_to_prref(CTXTdeclc void *pred_ep);
extern ClRef db_get_clause_code_space(PrRef, ClRef, CPtr *, CPtr *);
extern void mark_findall_strings(CTXTdecl);
extern void mark_open_filenames();
extern void mark_hash_table_strings(CTXTdecl);

#ifdef INDIRECTION_SLIDE
#define TO_BUFFER(ptr) \
{ \
  if (slide_buffering) { \
    slide_buf[slide_top] = ptr; \
    slide_top++; \
    slide_buffering = slide_top <= slide_buf_size; \
  } \
}
#else
#define TO_BUFFER(ptr)
#endif

#ifdef GC_PROFILE
#define h_mark(i) \
do { \
  CPtr cell_ptr; int place;\
  place = i;\
  cell_ptr = (CPtr) heap_bot + place;\
  inspect_ptr(cell_ptr);  \
  heap_marks[place] |= MARKED;\
} while (0)
#else
#define h_mark(i)          heap_marks[i] |= MARKED
#endif

#define h_marked(i)        (heap_marks[i])
#define h_clear_mark(i)    heap_marks[i] &= ~MARKED

#define ls_marked(i)       (ls_marks[i])
#ifdef GC_PROFILE
#define ls_mark(i)         \
do { \
  int tag, place; \
  CPtr ptr; \
  place = i; \
  ptr = (CPtr) ls_top + place; \
  tag = cell_tag(*ptr); \
  inspect_chain(ptr); \
  ls_marks[place] |= MARKED; \
} while (0)
#else
#define ls_mark(i)         ls_marks[i] |= MARKED
#endif
#define ls_clear_mark(i)   ls_marks[i] = 0

#define tr_marked(i)         (tr_marks[i])
#define tr_mark(i)           tr_marks[i] |= MARKED
#define tr_clear_mark(i)     tr_marks[i] &= ~MARKED
#define tr_mark_pre(i)       tr_marks[i] |= TRAIL_PRE
#define tr_clear_pre_mark(i) tr_marks[i] &= ~TRAIL_PRE
#define tr_pre_marked(i)     (tr_marks[i] & TRAIL_PRE)

#define cp_marked(i)       (cp_marks[i])
#define cp_mark(i)         cp_marks[i] |= MARKED
#define cp_clear_mark(i)   cp_marks[i] &= ~MARKED

/*=========================================================================*/

#ifdef GC
inline static CPtr hp_pointer_from_cell(Cell cell, int *tag)
{
  int t;
  CPtr retp;

  t = cell_tag(cell) ;

  /* the use of if-tests rather than a switch is for efficiency ! */
  /* as this function is very heavily used - do not modify */
  if (t == XSB_LIST)
    {
      *tag = XSB_LIST;
      retp = clref_val(cell);
      testreturnit(retp);
    }
  if (t == XSB_STRUCT)
    {
      *tag = XSB_STRUCT;
      retp = (CPtr)(cs_val(cell));
      testreturnit(retp);
    }
  if ((t == XSB_REF) || (t == XSB_REF1))
    {
      *tag = t;
      retp = (CPtr)cell ;
      if (points_into_heap(retp)) return(retp);
    }
  if (t == XSB_ATTV)
    {
      *tag = XSB_ATTV;
      retp = clref_val(cell);
      testreturnit(retp);
    }

  return NULL;
} /* hp_pointer_from_cell */
#endif

static CPtr pointer_from_cell(Cell cell, int *tag, int *whereto)
{ int t ;
 CPtr retp ;

 *tag = t = cell_tag(cell) ;
 switch (t)
   {
   case XSB_REF:
   case XSB_REF1: 
     retp = (CPtr)cell ;
     break ;
   case XSB_LIST: 
   case XSB_ATTV:
     retp = clref_val(cell) ;
     break ;
   case XSB_STRUCT:
     retp = ((CPtr)(cs_val(cell))) ;
     break ;
   default:
     *whereto = TO_NOWHERE ;
     return((CPtr)cell) ;
   }

 if (points_into_heap(retp)) *whereto = TO_HEAP ;
 else
   if (points_into_tr(retp)) *whereto = TO_TR ;
   else
     if (points_into_ls(retp)) *whereto = TO_LS ;
     else
       if (points_into_cp(retp)) *whereto = TO_CP ;
       else
         if (points_into_compl(retp)) *whereto = TO_COMPL ;
         else *whereto = TO_NOWHERE ;
 return(retp) ;

} /* pointer_from_cell */

/*-------------------------------------------------------------------------*/

inline static char * pr_h_marked(CPtr cell_ptr)
{ int i ;
 i = cell_ptr - heap_bot ;
 if (heap_marks == NULL) return("not_m") ;
 if (h_marked(i) == MARKED) return("marked") ;
 if (h_marked(i) == CHAIN_BIT) return("chained") ;
 if (h_marked(i) == (CHAIN_BIT | MARKED)) return("chained+marked") ;
 return("not_m") ;
} /* pr_h_marked */

inline static char * pr_ls_marked(CPtr cell_ptr) 
{ int i ; 
 i = cell_ptr - ls_top ;
 if (ls_marks == NULL) return("not_m") ;
 if (ls_marked(i) == MARKED) return("marked") ;
 if (ls_marked(i) == CHAIN_BIT) return("chained") ;
 if (ls_marked(i) == (CHAIN_BIT | MARKED)) return("chained+marked") ;
 return("not_m") ; 
} /* pr_ls_marked */ 

inline static char * pr_cp_marked(CPtr cell_ptr) 
{ int i ; 
 i = cell_ptr - cp_top ;
 if (cp_marks == NULL) return("not_m") ;
 if (cp_marked(i) == MARKED) return("marked") ;
 if (cp_marked(i) == CHAIN_BIT) return("chained") ;
 if (cp_marked(i) == (CHAIN_BIT | MARKED)) return("chained+marked") ;
 return("not_m") ; 
} /* pr_cp_marked */ 

inline static char * pr_tr_marked(CPtr cell_ptr) 
{ int i ; 
 i = cell_ptr - tr_bot ;
 if (tr_marks == NULL) return("not_m") ;
 if (tr_marked(i) == MARKED) return("marked") ;
 if (tr_marked(i) == CHAIN_BIT) return("chained") ;
 if (tr_marked(i) == (CHAIN_BIT | MARKED)) return("chained+marked") ;
 if (tr_marked(i) == (CHAIN_BIT | MARKED | TRAIL_PRE)) 
   return("chained+marked+pre");
 return("not_m") ; 
} /* pr_tr_marked */ 

/*-------------------------------------------------------------------------*/

/* Function mark_cell() keeps an explicit stack to perform marking.
   Marking without using such a stack, as in SICStus, should not be
   considered.  It is nice, but slower and more prone to errors.
   Recursive marking is the only alternative in my opinion, but one can
   construct too easily examples that overflow the C-stack - Bart Demoen.
*/

#define MAXS 3700
#define push_to_mark(p) mark_stack[mark_top++] = p
#define mark_overflow   (mark_top >= MAXS)
static int mark_cell(CPtr cell_ptr)
{
  CPtr p ;
  Cell cell_val ;
  Integer i;
  int  m, arity, tag ;
  int  mark_top = 0 ;
  CPtr mark_stack[MAXS+MAX_ARITY+1] ;

  m = 0 ;
 mark_more:
  if (!points_into_heap(cell_ptr)) /* defensive marking */
    goto pop_more ;
 safe_mark_more:
  i = cell_ptr - heap_bot ;
  if (h_marked(i)) goto pop_more ;
  TO_BUFFER(cell_ptr);
  h_mark(i) ;
  m++ ;

  cell_val = *cell_ptr;
  tag = cell_tag(cell_val);


  if (tag == XSB_LIST || tag == XSB_ATTV)
    { cell_ptr = clref_val(cell_val) ;
    if (mark_overflow)
      { m += mark_cell(cell_ptr+1) ; }
    else push_to_mark(cell_ptr+1) ;
    goto safe_mark_more ;
    }

  if (tag == XSB_STRUCT)
    { p = (CPtr)cell_val ;
    cell_ptr = ((CPtr)(cs_val(cell_val))) ;
    i = cell_ptr - heap_bot ;
    if (h_marked(i)) goto pop_more ;
    TO_BUFFER(cell_ptr);
    h_mark(i) ; m++ ;
    cell_val = *cell_ptr;
    arity = get_arity((Psc)(cell_val)) ;
    p = ++cell_ptr ;
    if (mark_overflow)
      { while (--arity)
        { m += mark_cell(++p) ; }
      }
    else while (--arity) push_to_mark(++p) ;
    goto mark_more ;
    }

  if ((tag == XSB_REF) || (tag == XSB_REF1))
    { p = (CPtr)cell_val ;
      if (p == cell_ptr) goto pop_more ;
    cell_ptr = p ;
    goto mark_more ;
    }

#ifndef NO_STRING_GC
#ifdef MULTI_THREAD
  if (flags[NUM_THREADS] == 1)
#endif
    if (gc_strings) {
      if (tag == XSB_STRING) {
        char *astr = string_val(cell_val);
        if (astr && (string_find_safe(astr) == astr))
          mark_string_safe(astr,"mark_cell");
      }
    }
#endif /* ndef NO_STRING_GC */

 pop_more:
  if (mark_top--)
    { cell_ptr = mark_stack[mark_top] ; goto mark_more ; }
  return(m) ;

} /* mark_cell */

/*----------------------------------------------------------------------*/

/* TLS: Overall, attvs are treated analogously to lists in the GC:
   thus when an attv is encountered, its attribute list is also
   traversed.  Note that when one attv is replaced by another in an
   interrupt handler, it should be through a put_attr().  When this
   happens a chain of attvs is created, so that starting out from some
   cell or another, the old attvs (which may be needed in
   backtracking) are marked since they are proximate to attvs.  Thus,
   you dont need to set the attvs in the pre-image trail (as I
   mistakenly thought), at least not for GC. */

static int mark_root(Cell cell_val)
{
  Integer i;
  int m, arity ;
  CPtr cell_ptr;
  int tag, whereto ;
  Cell v ;

  /* this is one of the places to be defensive while marking: an uninitialised
     cell in the ls can point to a Psc; the danger is not in following the Psc
     and mark something outside of the heap: mark_cell takes care of that; the
     dangerous thing is to mark the cell with the Psc on the heap without
     marking all its arguments */

  if (cell_val == 0) return(0) ;
  switch (cell_tag(cell_val))
    {
    case XSB_REF:
    case XSB_REF1:
      v = *(CPtr)cell_val ;
      pointer_from_cell(v,&tag,&whereto) ;
      switch (tag)
        { case XSB_REF: case XSB_REF1:
          if (whereto != TO_HEAP) return(0) ;
          break ;
        }
      return(mark_cell((CPtr)cell_val)) ;

    case XSB_STRUCT : 
      cell_ptr = ((CPtr)(cs_val(cell_val))) ;
      if (!points_into_heap(cell_ptr)) return(0) ;
      i = cell_ptr - heap_bot ; 
      if (h_marked(i)) return(0) ; 
      /* now check that at i, there is a Psc */
      v = *cell_ptr ;
      pointer_from_cell(v,&tag,&whereto) ;
      /* v must be a PSC - the following tries to test this */
      switch (tag) {
      case XSB_REF: 
      case XSB_REF1 :
        if (whereto != TO_NOWHERE) return(0) ;
        break ;
        /* default: return(0); */
      }
      TO_BUFFER(cell_ptr);
      h_mark(i) ; m = 1 ; 
      cell_val = *cell_ptr;
      arity = get_arity((Psc)(cell_val)) ;
      while (arity--) m += mark_cell(++cell_ptr) ;
      return(m) ;
      
    case XSB_LIST: 
    case XSB_ATTV:
      /* the 2 cells will be marked iff neither of them is a Psc */
      cell_ptr = clref_val(cell_val) ;
      if (!points_into_heap(cell_ptr)) return(0) ;
      v = *cell_ptr ;
#ifndef NO_STRING_GC
      if (gc_strings) mark_if_string(v,"attv 1");
#endif
      pointer_from_cell(v,&tag,&whereto) ;
      switch (tag) {
      case XSB_REF:
      case XSB_REF1:
        if (whereto != TO_HEAP) return(0) ;
        break ;
      }
      v = *(++cell_ptr) ;
#ifndef NO_STRING_GC
      if (gc_strings) mark_if_string(v,"attv 2");
#endif
      pointer_from_cell(v,&tag,&whereto) ;
      switch (tag) {
      case XSB_REF:
      case XSB_REF1:
        if (whereto != TO_HEAP) return(0) ;
        break ;
      }
      m = mark_cell(cell_ptr) ;
      cell_ptr-- ; 
      m += mark_cell(cell_ptr) ;
      return(m) ;

#ifndef NO_STRING_GC
    case XSB_STRING:
#ifdef MULTI_THREAD
  if (flags[NUM_THREADS] == 1)
#endif
    if (gc_strings) {
      char *sstr = string_val(cell_val);
      if (sstr && (string_find_safe(sstr) == sstr))
        mark_string_safe(sstr,"mark_root");
      return(0);
    }
#endif /* ndef NO_STRING_GC */

    default : return(0) ;
    }

} /* mark_root */

/*----------------------------------------------------------------------*/

inline static int mark_region(CPtr beginp, CPtr endp)
{
  int marked = 0 ;

  while (beginp <= endp) {
    marked += mark_root(*(beginp++)) ;
  }

  return(marked) ;
} /* mark_region */

/*----------------------------------------------------------------------*/
inline static unsigned long mark_trail_section(CPtr begintr, CPtr endtr)
{
  CPtr a = begintr;
  CPtr trailed_cell;
  unsigned long i=0, marked=0;
#ifdef PRE_IMAGE_TRAIL
  CPtr pre_value = NULL;
#endif
  
  while (a > (CPtr)endtr)
    { 
      tr_mark(a - tr_bot); /* mark trail cell as visited */
      /* lfcastro -- needed for copying */
      tr_mark((a-tr_bot)-1);
      tr_mark((a-tr_bot)-2);

      trailed_cell = (CPtr) *(a-2);
#ifdef PRE_IMAGE_TRAIL
      if ((long) trailed_cell & PRE_IMAGE_MARK) {
        trailed_cell = (CPtr) ((Cell) trailed_cell & ~PRE_IMAGE_MARK);
        pre_value = (CPtr) *(a-3);
        tr_mark_pre((a-tr_bot)-2); /* mark somewhere else */
        *(a-2) = ((Cell)trailed_cell & ~PRE_IMAGE_MARK); /* and delete mark */
      /* lfcastro -- needed for copying */
        tr_mark((a-tr_bot)-3);
      }
#endif
      
      if (points_into_heap(trailed_cell))
        { i = trailed_cell - heap_bot ;
        if (! h_marked(i))
          {
#if (EARLY_RESET == 1)
            {
              /* instead of marking the word in the heap, 
                 we make the trail cell point to itself */
              TO_BUFFER(trailed_cell);
              h_mark(i) ;
              marked++ ;
              
#ifdef PRE_IMAGE_TRAIL
              if (pre_value) 
                *trailed_cell = (Cell) pre_value;
              else
#endif
                bld_free(trailed_cell); /* early reset */
              
              /* could do trail compaction now or later */
              heap_early_reset++;
            }
#else
            {
              marked += mark_root((Cell)trailed_cell);
            }
#endif
            
          }
        }
      else
        /* it must be a ls pointer, but for safety
           we take into account between_h_ls */
        if (points_into_ls(trailed_cell))
          { i = trailed_cell - ls_top ;
          if (! ls_marked(i))
            {
#if (EARLY_RESET == 1)
              {
                /* don't ls_mark(i) because we early reset
                   so, it is not a heap pointer
                   but marking would be correct */
#ifdef PRE_IMAGE_TRAIL
                if (pre_value)
                  *trailed_cell = (Cell) pre_value;
                else
#endif
                  bld_free(trailed_cell) ; /* early reset */
                
                /* could do trail compaction now or later */
                ls_early_reset++;
              }
#else
              { ls_mark(i) ;
              marked += mark_region(trailed_cell, trailed_cell);
              }
#endif
            }
          }
      
      /* mark the forward value */
      marked += mark_root((Cell) *(a-1));
      
#ifdef PRE_IMAGE_TRAIL
      if (pre_value) { 
        marked += mark_root((Cell) pre_value);
        pre_value = NULL;
      }
#endif

      /* stop if we're not going anywhere */
      if ((unsigned long) a == (unsigned long) *a)
        break;

      /* jump to previous cell */
      a = (CPtr) *a;
    }
  return marked;
}
/*----------------------------------------------------------------------*/
/* TLS: as I understand it, this should mark all WAM-register regions
 * of choice points, as well as the substitution factors of tabled
 * choice points.  It traverses the CP stack via the special cell
 * prev-top which has noting to do with the previous breg.  The part
 * of this code that checks first time and resets the register values
 * seems a little weird -- I don't see why just takeing the youngest
 * of breg/bfreg and traversing from there wouldn't amount to the same
 * thing. */

static int mark_query(CTXTdecl)
{
  Integer i;
  int yvar, total_marked = 0 ;
  CPtr b,e,*tr,a,d;
  byte *cp;
  int first_time;

  b = breg ;
  e = ereg ;
  tr = trreg ;
  cp = cpreg ;
  first_time = 1;

restart:
  while (1)
    {
      while ((e < ls_bot) && (cp != NULL))
        {
          if (ls_marked(e - ls_top)) break ;
          ls_mark(e - ls_top) ;
          /* TLS: get number of perm. vars from cpreg */
          yvar = *(cp-2*sizeof(Cell)+3) - 1 ;  
          total_marked += mark_region(e-yvar,e-2) ;
          i = (e-2) - ls_top ;
          while (yvar-- > 1) { ls_mark(i--); }
          cp = (byte *)e[-1] ;
          e = (CPtr)e[0] ;
        }
      if (b >= (cp_bot-CP_SIZE)) {
        return(total_marked) ;
      }
      a = (CPtr)tr ;
      tr = cp_trreg(b) ;

      /* the answer template is part of the forward computation for 
         consumers, so it should be marked before the trail in order
         to allow for early reset                      --lfcastro */
      
      if (is_generator_choicepoint(b)) {
        CPtr region;
        int at_size;
        region = (CPtr) tcp_template(b);
        at_size = (int_val(cell(region)) & 0xffff) + 1;
        while (at_size--)
          total_marked += mark_cell(region--);
      } else if (is_consumer_choicepoint(b)) {
        CPtr region;
        int at_size;
        region = (CPtr) nlcp_template(b);
        at_size = (int_val(cell(region))&0xffff)+1;
        while (at_size--)
          total_marked += mark_cell(region--);
      }

      /* mark the delay list field of all choice points in CP stack too */
      if ((d = cp_pdreg(b)) != NULL) {
        total_marked += mark_root((Cell)d);
      }

      total_marked += mark_trail_section(a,(CPtr) tr);

      /* mark the arguments in the choicepoint */
      /* the choicepoint can be a consumer, a generator or ... */

      /* the code for non-tabled choice points is ok */
      /* for all other cps - check that
         (1) the saved arguments are marked
         (2) the substitution factor is marked
      */

      if (is_generator_choicepoint(b))
        { /* mark the arguments */
          total_marked += mark_region(b+TCP_SIZE, tcp_prevtop(b)-1);
        }
      else if (is_consumer_choicepoint(b))
        { /* mark substitution factor -- skip the number of SF vars */
          /* substitution factor is in the choicepoint for consumers */
#ifdef SLG_GC
          if (nlcp_prevtop(b) != b+NLCP_SIZE) {
            /* this was a producer that was backtracked over --lfcastro */
            /* mark the arguments, since chaining & copying consider them */
            CPtr ptr;
            for (ptr = b+NLCP_SIZE; ptr < nlcp_prevtop(b); ptr++)
              *ptr = makeint(6660666);
/*          total_marked += mark_region(b+NLCP_SIZE, nlcp_prevtop(b)-1); */
          } 

#endif
        }
      else if (is_compl_susp_frame(b)) 
        /* there is nothing to do in this case */ ;
      else { 
        CPtr endregion, beginregion;
        endregion = cp_prevtop(b)-1;
        beginregion = b+CP_SIZE;
        total_marked += mark_region(beginregion,endregion) ;

      }

      e = cp_ereg(b) ;
      cp = cp_cpreg(b) ;
#if defined(GC_PROFILE) && defined(CP_DEBUG)
      if (examine_data) {
        print_cpf_pred(b);
        active_cps++;
      }
#endif
      if (first_time) {
        first_time = 0;
        if (bfreg < breg) {
          b = bfreg;
          e = cp_ereg(b);
          cp = cp_cpreg(b);
          tr = cp_trreg(b);
          goto restart;
        }
      }

      b = cp_prevtop(b);
    }

} /* mark_query */

/*----------------------------------------------------------------------*/

static int mark_hreg_from_choicepoints(CTXTdecl)
{
  CPtr b, bprev, h;
  Integer i;
  int  m;

  /* this has to happen after all other marking ! */
  /* actually there is no need to do this for a copying collector */

  b = (bfreg < breg ? bfreg : breg);
  bprev = 0;
  m = 0;
    while(1)
     {
      h = cp_hreg(b) ;
      i = h - heap_bot ;
      if (! h_marked(i)) /* h from choicepoint should point to something that
                            is marked; if not, mark it now and set it
                            to something reasonable - int(666) is ok
                            although a bit scary :-)
                         */
        {
          cell(h) = makeint(666) ;
          TO_BUFFER(h);
          h_mark(i) ;
          m++ ;
        }
#ifdef SLG_GC
      /* should mark hfreg for generators, too --lfcastro */
      if (is_generator_choicepoint(b)) {
        h = tcp_hfreg(b);
        i = h - heap_bot;
        if (! h_marked(i)) {
          cell(h) = makeint(6660);
          TO_BUFFER(h);
          h_mark(i);
          m++;
        }
      }
#endif
      bprev = b; 
    b = cp_prevtop(b);
    if (b >= (cp_bot-CP_SIZE))
      break;
  }
  return m;
} /* mark_hreg_from_choicepoints */

/*-------------------------------------------------------------------------*/

static int mark_from_attv_array(CTXTdecl)
{
  int i,max;
  int m=0;

  max = int_val(cell(interrupt_reg));

  for (i=0; i<max; i++) {
    m += mark_cell((CPtr) attv_interrupts[i][0]);
    m += mark_cell((CPtr) attv_interrupts[i][1]);
  }
  return m;
}

/*-------------------------------------------------------------------------*/


int mark_heap(CTXTdeclc int arity, int *marked_dregs)
{
  int avail_dreg_marks = 0, marked = 0;

  /* the following seems unnecessary, but it is not !
     mark_heap() may be called directly and not only through gc_heap() */
  slide = (pflags[GARBAGE_COLLECT] == SLIDING_GC) |
    (pflags[GARBAGE_COLLECT] == INDIRECTION_SLIDE_GC);
  
  stack_boundaries ;
  
  if (print_on_gc) print_all_stacks(CTXTc arity);
  
  if (slide) {
#ifdef INDIRECTION_SLIDE
    /* space for keeping pointers to live data */
    slide_buf_size = (unsigned long) ((hreg+1-(CPtr)glstack.low)*0.2);
    slide_buf = (CPtr *) mem_calloc(slide_buf_size+1, sizeof(CPtr),GC_SPACE);
    if (!slide_buf)
      xsb_exit("Not enough space to allocate slide_buf");
    slide_top=0;
    if (pflags[GARBAGE_COLLECT] == INDIRECTION_SLIDE_GC)
      slide_buffering=1;
    else
      slide_buffering=0;
#endif
  }
  
#ifdef INDIRECTION_SLIDE
  else
    slide_buffering=0;
#endif
  
#ifdef SLG_GC
  cp_marks = (char *)mem_calloc(cp_bot - cp_top + 1,1,GC_SPACE);
  tr_marks = (char *)mem_calloc(tr_top - tr_bot + 1,1,GC_SPACE);
  if ((! cp_marks) || (! tr_marks))
    xsb_exit("Not enough core to perform garbage collection chaining phase");
#endif  
  heap_marks_size = heap_top - heap_bot + 2 + avail_dreg_marks;
  heap_marks = (char * )mem_calloc(heap_marks_size,1,GC_SPACE);
  ls_marks   = (char * )mem_calloc(ls_bot - ls_top + 1,1,GC_SPACE);
  if ((! heap_marks) || (! ls_marks))
    xsb_exit("Not enough core to perform garbage collection marking phase");
  
  heap_marks += 1; /* see its free; also note that heap_marks[-1] = 0 is
                      needed for copying garbage collection see copy_block() */
  
  /* start marking phase */
  marked = mark_region(reg+1,reg+arity);
  if (delayreg != NULL) {
    marked += mark_root((Cell)delayreg);
  }
  /* Heap[0] is a global variable */
  marked += mark_root((Cell)glstack.low);
  
  if (slide)
    { 
      int put_on_heap;
      put_on_heap = arity;
      marked += put_on_heap;
      while (put_on_heap > 0) {
#ifdef SLG_GC
        TO_BUFFER((heap_top-put_on_heap-1));
        h_mark((heap_top - 1 - put_on_heap--)-heap_bot);
#else
        TO_BUFFER((heap_top-put_on_heap));
        h_mark((heap_top - put_on_heap--)-heap_bot);
#endif
      }
    }

#ifdef SLG_GC
  /* hfreg's also kept in the heap so that it's automatically adjusted */
  /* only for sliding GC */
  if (slide) { 
    CPtr hfreg_in_heap;
    /* mark from hfreg */
    marked += mark_root((Cell)hfreg);
  
    hfreg_in_heap = heap_top - 1;
    TO_BUFFER(hfreg_in_heap);
    if (!h_marked(hfreg_in_heap - heap_bot)) {
      h_mark(hfreg_in_heap - heap_bot);
      marked++;
    }
  }
#endif

  marked += mark_query(CTXT);

  marked += mark_from_attv_array(CTXT);

  if (slide)
    marked += mark_hreg_from_choicepoints(CTXT);

  if (print_on_gc) print_all_stacks(CTXTc arity);

  return marked ;
} /* mark_heap */

#ifndef NO_STRING_GC
#define mark_trie_strings_for(SM,BType,pStruct,apStruct)        \
  pBlock = SM_CurBlock(SM);                                     \
  if (pBlock != NULL) {                                         \
    int isusedblock, anyunusedblock = FALSE;                    \
    for (pStruct = (BType)SMBlk_FirstStruct(pBlock);            \
         pStruct < (BType)SM_NextStruct(SM);                    \
         pStruct = (BType)SMBlk_NextStruct(pStruct,SM_StructSize(SM))) { \
      if (isstring(BTN_Symbol(pStruct)) && (*(((Integer *)pStruct)+1) != FREE_TRIE_NODE_MARK)) {\
        mark_string(string_val(BTN_Symbol(pStruct)),"trie 1");  \
      }                                                         \
    }                                                           \
    pBlock = SMBlk_NextBlock(pBlock);                           \
    while (pBlock != NULL) {                                    \
      isusedblock = FALSE;                                      \
      for (pStruct = (BType)SMBlk_FirstStruct(pBlock);          \
           pStruct <= (BType)SMBlk_LastStruct(pBlock,SM_StructSize(SM),SM_StructsPerBlock(SM)); \
           pStruct = (BType)SMBlk_NextStruct(pStruct,SM_StructSize(SM))) { \
        if (*(((Integer *)pStruct)+1) != FREE_TRIE_NODE_MARK) { \
          isusedblock = TRUE;                                   \
          if (isstring(BTN_Symbol(pStruct)))                    \
            mark_string(string_val(BTN_Symbol(pStruct)),"trie 2");\
        }                                                       \
      }                                                         \
      anyunusedblock |= !isusedblock;                           \
      if (!isusedblock) {                                       \
        /*printf("%p in %p is an unused block\n",pBlock,SM);*/  \
        for (pStruct = (BType)SMBlk_FirstStruct(pBlock);        \
             pStruct <= (BType)SMBlk_LastStruct(pBlock,SM_StructSize(SM),SM_StructsPerBlock(SM)); \
             pStruct = (BType)SMBlk_NextStruct(pStruct,SM_StructSize(SM))) { \
          *(((Integer *)pStruct)+1) = FREE_TRIE_BLOCK_MARK;     \
        }                                                       \
      }                                                         \
      pBlock = SMBlk_NextBlock(pBlock);                         \
    }                                                           \
    if (anyunusedblock) {                                       \
      apStruct = (BType *)&SM_FreeList(SM);                     \
      while (*apStruct != NULL) {                               \
        if (*((Integer *)(*apStruct)+1) == FREE_TRIE_BLOCK_MARK)\
          *apStruct = *((void **)(*apStruct));                  \
        else apStruct = *(void **)apStruct;                     \
      }                                                         \
      apBlock = &(SM_CurBlock(SM));                             \
      while (*apBlock != NULL) {                                \
        if (*((Integer *)(*apBlock)+2) == FREE_TRIE_BLOCK_MARK) {\
          pBlock = *apBlock;                                    \
          *apBlock = *((void **)(*apBlock));                    \
          mem_dealloc(pBlock,SM_NewBlockSize(SM),TABLE_SPACE);  \
        } else apBlock = *((void **)(apBlock));                 \
      }                                                         \
    }                                                           \
  }


void mark_trie_strings(CTXTdecl) {

  BTNptr pBTNStruct, *apBTNStruct;
  TSTNptr pTSTNStruct, *apTSTNStruct;
  void *pBlock, **apBlock;

#ifdef MULTI_THREAD
  //  printf("marking private trie strings\n");
  mark_trie_strings_for(*private_smTableBTN,BTNptr,pBTNStruct,apBTNStruct);
  //  printf("marked private trie strings\n");
#endif  
  SYS_MUTEX_LOCK(MUTEX_SM);
  mark_trie_strings_for(smTableBTN,BTNptr,pBTNStruct,apBTNStruct);
  mark_trie_strings_for(smAssertBTN,BTNptr,pBTNStruct,apBTNStruct);
  SYS_MUTEX_UNLOCK(MUTEX_SM);
  mark_trie_strings_for(smTSTN,TSTNptr,pTSTNStruct,apTSTNStruct);
}

void mark_code_strings(int pflag, CPtr inst_addr, CPtr end_addr) {
  int  current_opcode, oprand;

  //  printf("buffer\n");
  while (inst_addr<end_addr) {
    current_opcode = cell_opcode(inst_addr);
    //    printf("opcode: %x\n",current_opcode);
    inst_addr ++;
    for (oprand=1; oprand<=4; oprand++) {
      switch (inst_table[current_opcode][oprand]) {
      case A: case V: case R: case P: case PP: case PPP:
      case PPR: case PRR: case RRR: case X:
        break;
      case S: case L: case N: case B: case F:
      case I: case T:     
        inst_addr ++;
        break;
      case C:
      case G:
        if (pflag) printf("    %s\n",*(char **)inst_addr);
        mark_string(*(char **)inst_addr,"code");
        inst_addr ++;
        break;
      default:
        break;
      }  /* switch */
    } /* for */
  }
}

void mark_atom_and_code_strings(CTXTdecl) {
  unsigned long i;
  Pair pair_ptr, mod_pair_ptr;
  PrRef prref;
  ClRef clref;
  CPtr code_beg, code_end;

  //  printf("marking atom and code strings\n");
  //  printf("marking atoms in usermod\n");
  for (i = 0; i < symbol_table.size; i++) {
    if (symbol_table.table[i] != NULL) {
      for (pair_ptr = (Pair)symbol_table.table[i]; pair_ptr != NULL;
           pair_ptr = pair_next(pair_ptr)) {
        char *string = get_name(pair_psc(pair_ptr));
        mark_string(string,"usermod atom");
        if (get_type(pair_psc(pair_ptr)) == T_DYNA) {
          //      printf("mark dc for usermod:%s/%d\n",string,get_arity(pair_psc(pair_ptr)));
          prref = dynpredep_to_prref(CTXTc get_ep(pair_psc(pair_ptr))); // fix for multi-threading to handle dispatch for privates 
          if (prref) {
            clref = db_get_clause_code_space(prref,(ClRef)NULL,&code_beg,&code_end);
            while (clref) {
              mark_code_strings(0,code_beg,code_end);
              clref = db_get_clause_code_space(prref,clref,&code_beg,&code_end);
            }
          }
        }
      }
    }
  }
  for (mod_pair_ptr = (Pair)flags[MOD_LIST]; 
       mod_pair_ptr != NULL; 
       mod_pair_ptr = pair_next(mod_pair_ptr)) {
    mark_string(get_name(pair_psc(mod_pair_ptr)),"mod");
    pair_ptr = (Pair) get_data(pair_psc(mod_pair_ptr));
    if ((Integer)pair_ptr != 1) { // not global mod 
      while (pair_ptr != NULL) {
        char *string = get_name(pair_psc(pair_ptr));
        mark_string(string,"mod atom");
        if (get_type(pair_psc(pair_ptr)) == T_DYNA) {
          //      if (strcmp(get_name(pair_psc(pair_ptr)),"ipObjectSpec_T")==0) printf("mark dc for %s:%s/%d\n",get_name(pair_psc(mod_pair_ptr)),string,get_arity(pair_psc(pair_ptr)));
          prref = dynpredep_to_prref(CTXTc get_ep(pair_psc(pair_ptr)));
          clref = db_get_clause_code_space(prref,(ClRef)NULL,&code_beg,&code_end);
          while (clref) {
            //      printf("  mark code from %s/%d(%s), %p\n", string, get_arity(pair_psc(pair_ptr)), get_name(pair_psc(mod_pair_ptr)), clref);
            mark_code_strings(0,code_beg,code_end);
            clref = db_get_clause_code_space(prref,clref,&code_beg,&code_end);
          }
        }
        pair_ptr = pair_next(pair_ptr);
      }
    }
  }
  //  printf("marked atom and code strings\n");
}

void mark_nonheap_strings(CTXTdecl) {
  char *empty;

  mark_string((char *)(ret_psc[0]),"ret"); /* "ret" necessary */
  mark_string(nil_string,"[]"); /* necessary */
  empty = string_find_safe("");
  if (!empty) mark_string(empty,"empty");

  mark_trie_strings(CTXT);
  mark_atom_and_code_strings(CTXT);
  mark_findall_strings(CTXT);
  mark_open_filenames();
  mark_hash_table_strings(CTXT);

}
#endif /* ndef NO_STRING_GC */

---