/* 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.4 2002/03/12 17:31:21 lfcastro Exp $
** 
*/

#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 ;
  int  i, 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 ;
    }

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

} /* mark_cell */

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

static int mark_root(Cell cell_val)
{
  int m, i, 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 ;
      pointer_from_cell(v,&tag,&whereto) ;
      switch (tag) {
      case XSB_REF:
      case XSB_REF1:
	if (whereto != TO_HEAP) return(0) ;
	break ;
      }
      v = *(++cell_ptr) ;
      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) ;

    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;
}
/*----------------------------------------------------------------------*/

static int mark_query(void)
{
  int yvar, i, 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) ;
	  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(void)
{
  CPtr b, bprev, h;
  int  i, 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 */

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

/**
 * mark_from_attv_array: marks reachable cells from the attributed variables 
 *                       interrupt chain.
 * 
 * 
 * Return value: number of marked cells.
 **/
static int mark_from_attv_array()
{
  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(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 = (flags[GARBAGE_COLLECT] == SLIDING_GC) |
    (flags[GARBAGE_COLLECT] == INDIRECTION_SLIDE_GC);
  
  stack_boundaries ;
  
  if (print_on_gc) print_all_stacks(arity);
  
  if (slide) {
#ifdef INDIRECTION_SLIDE
    /* space for keeping pointers to live data */
    slide_buf_size = (hreg+1-(CPtr)glstack.low)*0.2;
    slide_buf = (CPtr *) calloc(slide_buf_size+1, sizeof(CPtr));
    if (!slide_buf)
      xsb_exit("Not enough space to allocate slide_buf");
    slide_top=0;
    if (flags[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 *)calloc(cp_bot - cp_top + 1,1);
  tr_marks = (char *)calloc(tr_top - tr_bot + 1,1);
  if ((! cp_marks) || (! tr_marks))
    xsb_exit("Not enough core to perform garbage collection chaining phase");
#endif  
  heap_marks = (char * )calloc(heap_top - heap_bot + 2 + avail_dreg_marks,1);
  ls_marks   = (char * )calloc(ls_bot - ls_top + 1,1);
  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);
  }
  
  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();

  marked += mark_from_attv_array();

  if (slide)
    marked += mark_hreg_from_choicepoints();

  if (print_on_gc) print_all_stacks(arity);

  return marked ;
} /* mark_heap */

