/* -*- mode: c -*- */
/*
    stacks.h -- Bind/Jump/Frame stacks.
*/
/*
    Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
    Copyright (c) 1990, Giuseppe Attardi.
    Copyright (c) 2000, Juan Jose Garcia-Ripoll
    Copyright (c) 2010-2012, Jean-Claude Beaudoin.

    MKCL is free software; you can redistribute it and/or
    modify it under the terms of the GNU Lesser General Public
    License as published by the Free Software Foundation; either
    version 3 of the License, or (at your option) any later version.

    See file './Copyright' for full details.
*/

#ifndef MKCL_STACKS_H
#define MKCL_STACKS_H

#ifdef __cplusplus
extern "C" {
#endif

/***********
 * C STACK
 ***********/

  extern MKCL_API void mkcl_call_stack_overflow(MKCL, char * const stack_mark_address);


#ifdef MKCL_DOWN_STACK
#define mkcl_call_stack_check(env)					\
  {									\
    int stack_mark = 0;							\
    char * const stack_mark_address = (char *) &stack_mark;		\
    if (mkcl_unlikely(stack_mark_address <= (env)->cs_limit))		\
      mkcl_call_stack_overflow(env, stack_mark_address);		\
  }
#else
#define mkcl_call_stack_check(env)					\
  {									\
    int stack_mark = 0;							\
    char * const stack_mark_address = (char *) &stack_mark;		\
    if (mkcl_unlikely(stack_mark_address >= (env)->cs_limit))		\
      mkcl_call_stack_overflow(env, stack_mark_address);		\
  }
#endif

#ifdef MKCL_DOWN_STACK
#define mkcl_ensure_call_stack(env, size)				\
  {									\
    int stack_mark = 0;							\
    char * const stack_mark_address = (char*) &stack_mark;		\
    char * const max_sp =  stack_mark_address - size;			\
    if (mkcl_unlikely((max_sp <= (env)->cs_limit) /* blew it */		\
		      || (max_sp > stack_mark_address))) /* wrapped */	\
      mkcl_call_stack_overflow(env, stack_mark_address);		\
  }
#else
#define mkcl_ensure_call_stack(env, size)				\
  {									\
    int stack_mark = 0;							\
    char * const stack_mark_address = (char*) &stack_mark;		\
    char * const max_sp =  stack_mark_address + size;			\
    if (mkcl_unlikely((max_sp >= (env)->cs_limit) /* blew it */		\
		      || (max_sp < stack_mark_address))) /* wrapped */	\
      mkcl_call_stack_overflow(env, stack_mark_address);		\
  }
#endif

  /* These two MKCL_XXX_STACK_DEPTH macro are estimate of the minimum stack
     depth required to safely (without stack overflow) perform a function
     in the XXX context/library. */
  /* They are somewhat rough guesses that try to err on the safe side.
     We could increase them if exprience show them to be too small. */
#define MKCL_LIBC_STACK_DEPTH (8 * 1024 * sizeof(mkcl_word))
#define MKCL_GC_STACK_DEPTH (16 * 1024 * sizeof(mkcl_word)) /* need to allow for a full GC collect phase. */



/**************
 * BIND STACK
 **************/

  typedef struct mkcl_bds_bd {
    mkcl_object symbol;	/*  symbol  */
    mkcl_object value;	/*  previous value of the symbol  */
  } *mkcl_bds_ptr;

/* This value is chosen because it cannot reference any valid lisp object
   and cannot be confused with MKCL_OBJNULL. */
#define MKCL_END_OF_BDS_CHAIN ((mkcl_object) 0x04)

  extern MKCL_API void mkcl_grow_bds_stack(MKCL);

#define	mkcl_bds_check(env) (((env)->bds_top >= (env)->bds_upper_bound) ? mkcl_grow_bds_stack() : (void)0)

  extern MKCL_API void mkcl_bds_push(MKCL, mkcl_object symbol);
#if 0
  extern MKCL_API mkcl_object mkcl_set_symbol_value(MKCL, mkcl_object s, mkcl_object v);
#endif

  static inline mkcl_object _mkcl_sym_val(MKCL, mkcl_object sym)
  {
    mkcl_index index;

    if (mkcl_Null(sym)) return mk_cl_Cnil;

    if ((index = sym->symbol.special_index) < env->specials_size)
      {
	mkcl_object val = (env->specials)[index];
#ifdef MKCL_STATS
	extern bool mkcl_trace_specials;

	if (mkcl_unlikely(mkcl_trace_specials)) /* debug JCB */
	  printf("\nreading special var: %s", sym->symbol.name->base_string.self);
#endif	
	if (val != MKCL_END_OF_BDS_CHAIN) return val;
      }
    return sym->symbol.value;
  }

  static inline void mkcl_bds_bind(MKCL, mkcl_object s, mkcl_object value)
  {
    struct mkcl_bds_bd * slot;
    mkcl_index index;

    if (mkcl_Null(s))
      mkcl_FEprogram_error(env, "Tried to bind a value to the constant NIL.", 0);

    if ((index = s->symbol.special_index) >= env->specials_size)
      {
	MKCL_API mkcl_index mkcl_alloc_new_special_index(MKCL, mkcl_object sym);
	MKCL_API void mkcl_grow_specials(MKCL, mkcl_index new_size);

	if (index == MKCL_NOT_A_SPECIAL_INDEX)
	  index = s->symbol.special_index = mkcl_alloc_new_special_index(env, s);
	if (index >= env->specials_size)
	  mkcl_grow_specials(env, index + 1);
      }

    slot = ++(env->bds_top);
    if (slot >= env->bds_upper_bound) {
      mkcl_grow_bds_stack(env);
      slot = env->bds_top;
    }

    {
      mkcl_object * specials = env->specials;

      slot->symbol = s;
      slot->value = specials[index];
   
      specials[index] = value;
    }
  }

  static inline void mkcl_bds_unwind1(MKCL)
  { /* FIXME: This could underflow! JCB */
    register struct mkcl_bds_bd *slot = ((env->bds_org < env->bds_top) ? env->bds_top-- : env->bds_org);

    (env->specials)[slot->symbol->symbol.special_index] = slot->value;
  }

  static inline void mkcl_bds_unwind_n(MKCL, int n)
  {
    while (n--) mkcl_bds_unwind1(env);
  }

#define MKCL_SYM_VAL(env,s) (_mkcl_sym_val(env,s))
#define MKCL_SET(s,v) ((s)->symbol.value=(v))
#define MKCL_SETQ(env,s,v) (mkcl_set_symbol_value(env,s,v))


  static inline mkcl_object mkcl_symbol_value(MKCL, mkcl_object s)
  {
    mkcl_object value = MKCL_SYM_VAL(env, s);

    if (mkcl_unlikely(value == MKCL_OBJNULL))
      mkcl_FEunbound_variable(env, s);
    return value;
  }

  static inline mkcl_object mkcl_set_symbol_value(MKCL, mkcl_object s, mkcl_object value)
  {
    mkcl_type type_of_s = mkcl_type_of(s);

    if (mkcl_unlikely(type_of_s != mkcl_t_symbol))
      mkcl_FEillegal_variable_name(env, s);
    else if (mkcl_unlikely(mkcl_Null(s) || s->symbol.stype & mkcl_stp_constant))
      mkcl_FEprogram_error(env, "Tried to bind a value to the constant ~S.", 1, s);
    else
      {
	mkcl_index index = s->symbol.special_index;
#ifdef MKCL_STATS
	extern bool mkcl_trace_specials;

	if (mkcl_trace_specials)
	  printf("\nsetting special var: %s", s->symbol.name->base_string.self);
#endif

	if (mkcl_likely(index < env->specials_size))
	  {
	    mkcl_object v = env->specials[index];
	    if (v != MKCL_END_OF_BDS_CHAIN)
	      return env->specials[index] = value;
	  }
	return s->symbol.value = value;
      }
  }



/****************************
 * INVOCATION HISTORY STACK
 ****************************/

  typedef struct mkcl_ihs_frame {
    struct mkcl_ihs_frame *next;
    mkcl_object function;
    mkcl_object lex_env;
    mkcl_index index;
    mkcl_index bds_marker;
  } *mkcl_ihs_ptr;

#define mkcl_ihs_push(env,rec,fun,lisp_env) do {		     \
    const mkcl_env __the_env = (env);				     \
    struct mkcl_ihs_frame * const r = (rec);			     \
    r->next=__the_env->ihs_top;					     \
    r->function=(fun);						     \
    r->lex_env=(lisp_env);					     \
    r->index=(__the_env->ihs_top->index)+1;			     \
    r->bds_marker=__the_env->bds_top-__the_env->bds_org;	     \
    __the_env->ihs_top = r;					     \
  } while(0)

#define mkcl_ihs_pop(env) do {				\
    const mkcl_env __the_env = (env);			\
    struct mkcl_ihs_frame *r = __the_env->ihs_top;	\
    if (r) __the_env->ihs_top = r->next;		\
  } while(0)

  extern MKCL_API mkcl_object mk_si_ihs_top_function_name(MKCL);



/***************
 * FRAME STACK
 ***************/
/* Frames signal points in the code to which we can at any time jump.
 * Frames are established, for instance, by CATCH, BLOCK, TAGBODY,
 * LAMBDA, UNWIND-PROTECT, etc.
 *
 * Frames are established by mkcl_frs_push(). For each call to mkcl_frs_push()
 * there must be a corresponding mkcl_frs_pop(). More precisely, since our
 * frame mechanism relies on the C stack and on the setjmp/longjmp
 * functions, any function that creates a frame must also destroy it
 * with mkcl_frs_pop() before returning.
 *
 * Frames are identified by a value frs_val. This can be either a
 * unique identifier, created for each CATCH, BLOCK, etc, or a common
 * one MKCL_PROTECT_TAG, used by UNWIND-PROTECT forms. The first type
 * of frames can be target of a search mkcl_frs_sch() and thus one can jump
 * to them. The second type of frames are like barriers designed to
 * intercept the jumps to the outer frames and are called
 * automatically by the function unwind() whenever it jumps to a frame
 * which is beyond one of these barriers.
 */

  typedef struct mkcl_interrupt_status {
    volatile int disable_interrupts;
#if MKCL_DEBUG_INTERRUPT_MASK
    char * volatile interrupt_disabler_file;
    volatile size_t interrupt_disabler_lineno;
#endif
  } mkcl_interrupt_status;

#if MKCL_DEBUG_INTERRUPT_MASK
# if 0
# define mkcl_get_interrupt_status(the_env, status)			\
  ((status)->disable_interrupts = (the_env)->disable_interrupts,		\
   (status)->interrupt_disabler_file = (the_env)->interrupt_disabler_file, \
   (status)->interrupt_disabler_lineno = (the_env)->interrupt_disabler_lineno)

# define mkcl_set_interrupt_status(the_env, status)			\
  ((the_env)->interrupt_disabler_lineno = (status)->interrupt_disabler_lineno, \
   (the_env)->interrupt_disabler_file = (status)->interrupt_disabler_file, \
   (the_env)->disable_interrupts = (status)->disable_interrupts)
# else
  static inline void mkcl_get_interrupt_status(MKCL, mkcl_interrupt_status * const status_ptr)
  {
    (status_ptr)->disable_interrupts = (env)->disable_interrupts;
    (status_ptr)->interrupt_disabler_file = (env)->interrupt_disabler_file;
    (status_ptr)->interrupt_disabler_lineno = (env)->interrupt_disabler_lineno;
  }
  static inline int mkcl_set_interrupt_status(MKCL, const mkcl_interrupt_status * const status_ptr)
  {
    (env)->interrupt_disabler_lineno = (status_ptr)->interrupt_disabler_lineno;
    (env)->interrupt_disabler_file = (status_ptr)->interrupt_disabler_file;
    return (env)->disable_interrupts = (status_ptr)->disable_interrupts;
  }
# endif
#else
# define mkcl_get_interrupt_status(the_env, status)		\
  ((status)->disable_interrupts = (the_env)->disable_interrupts)
  
# define mkcl_set_interrupt_status(the_env, status)		\
  ((the_env)->disable_interrupts = (status)->disable_interrupts)
#endif

  typedef struct mkcl_frame {
    mkcl_jmp_buf frs_jmpbuf;
    mkcl_object	frs_val;
    mkcl_index	frs_bds_top_index;
    mkcl_ihs_ptr frs_ihs;
    mkcl_index	frs_sp;
    mkcl_interrupt_status frs_intr;
  } *mkcl_frame_ptr;

  extern MKCL_API mkcl_frame_ptr _mkcl_frs_push(MKCL, mkcl_object);

#define mkcl_frs_push(env,val)  mkcl_setjmp(_mkcl_frs_push(env,val)->frs_jmpbuf)

#if 0 /* def MKCL_WINDOWS */ /* Will use it if we go back to hardware detection */
# define mkcl_maybe_reset_call_stack_overflow(env)			\
  if (mkcl_unlikely((env)->cs_has_overflowed))				\
    if (!_resetstkoflw())						\
      mkcl_FEwin32_error(env, "Stack overflow reset has failed", 0);
#else
# define mkcl_maybe_reset_call_stack_overflow(env)
#endif

#if 0
  /* This version will happily underflow! JCB */
# define mkcl_frs_pop(env)						\
  ((((env)->frs_top < (env)->frs_org)					\
    ? mkcl_disable_interrupts(env)					\
    : mkcl_set_interrupt_status(env, &(env)->frs_top->frs_intr)),	\
   (env)->frs_top--)
#else
# define mkcl_frs_pop(env)						\
  (mkcl_likely((env)->frs_top > (env)->frs_org)				\
   ? mkcl_set_interrupt_status(env, &(((env)->frs_top--)->frs_intr))	\
   : mkcl_disable_interrupts(env)) /* Shouldn't this case raise an internal error instead? JCB */
#endif


/*******************
 * ARGUMENTS STACK
 *******************
 * Here we define how we handle the incoming arguments for a
 * function. Our calling conventions specify that at most
 * MKCL_C_ARGUMENTS_LIMIT are pushed onto the C stack. If the function
 * receives more than this number of arguments it will keep a copy of
 * _all_ those arguments _plus_ the remaining ones in the lisp temporaries
 * stack. The caller is responsible for storing and removing such
 * values.
 *
 * Given this structure, we need our own object for handling variable
 * argument list, mkcl_va_list. This object joins the C data type for
 * handling vararg lists and a pointer to the lisp temp stack, in case the
 * arguments were passed there.
 *
 * Note that keeping a direct reference to the lisp temp stack effectively
 * locks it in memory, preventing the block from being garbage
 * collected if the stack grows -- at least until all references are
 * eliminated --. This is something we have to live with and which
 * is somehow unavoidable, given that function arguments have to be
 * stored somewhere.
 */

  extern MKCL_API mkcl_object *_mkcl_va_sp(MKCL, mkcl_narg narg);

#define mkcl_va_start(e,a,p,n,k) {					\
    a[0].narg = (n)-(k);						\
    va_start(a[0].args,p);						\
    a[0].sp = ((n) <= MKCL_C_ARGUMENTS_LIMIT) ? 0 : _mkcl_va_sp(e, a[0].narg); \
  }

#define mkcl_va_arg(a)							\
  (a[0].narg--, (a[0].sp ? *(a[0].sp++) : va_arg(a[0].args,mkcl_object)))

#if 0

#define mkcl_va_copy(dest,orig) {	    \
    dest[0].narg = orig[0].narg;	    \
    dest[0].sp = orig[0].sp;		    \
    va_copy(dest[0].args, orig[0].args);    \
  }

#endif