[bpt/guile.git] / libguile / vm-engine.c

/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
 * 
 * This library 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.
 *
 * This library 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
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
 * 02110-1301 USA
 */

/* This file is included in vm.c multiple times */

#if (VM_ENGINE == SCM_VM_REGULAR_ENGINE)
# define VM_USE_HOOKS		0	/* Various hooks */
#elif (VM_ENGINE == SCM_VM_DEBUG_ENGINE)
# define VM_USE_HOOKS		1
#else
# error unknown debug engine VM_ENGINE
#endif


/* Register optimization. [ stolen from librep/src/lispmach.h,v 1.3 ]

   Some compilers underestimate the use of the local variables representing
   the abstract machine registers, and don't put them in hardware registers,
   which slows down the interpreter considerably.
   For GCC, I have hand-assigned hardware registers for several architectures.
*/

#ifdef __GNUC__
#ifdef __mips__
#define IP_REG asm("$16")
#define SP_REG asm("$17")
#define FP_REG asm("$18")
#endif
#ifdef __sparc__
#define IP_REG asm("%l0")
#define SP_REG asm("%l1")
#define FP_REG asm("%l2")
#endif
#ifdef __alpha__
#ifdef __CRAY__
#define IP_REG asm("r9")
#define SP_REG asm("r10")
#define FP_REG asm("r11")
#else
#define IP_REG asm("$9")
#define SP_REG asm("$10")
#define FP_REG asm("$11")
#endif
#endif
#ifdef __i386__
/* too few registers! because of register allocation errors with various gcs,
   just punt on explicit assignments on i386, hoping that the "register"
   declaration will be sufficient. */
#elif defined __x86_64__
/* GCC 4.6 chooses %rbp for IP_REG and %rbx for SP_REG, which works
   well.  Tell it to keep the jump table in a r12, which is
   callee-saved.  */
#define JT_REG asm ("r12")
#endif
#if defined(PPC) || defined(_POWER) || defined(_IBMR2)
#define IP_REG asm("26")
#define SP_REG asm("27")
#define FP_REG asm("28")
#endif
#ifdef __hppa__
#define IP_REG asm("%r18")
#define SP_REG asm("%r17")
#define FP_REG asm("%r16")
#endif
#ifdef __mc68000__
#define IP_REG asm("a5")
#define SP_REG asm("a4")
#define FP_REG
#endif
#ifdef __arm__
#define IP_REG asm("r9")
#define SP_REG asm("r8")
#define FP_REG asm("r7")
#endif
#endif

#ifndef IP_REG
#define IP_REG
#endif
#ifndef SP_REG
#define SP_REG
#endif
#ifndef FP_REG
#define FP_REG
#endif
#ifndef JT_REG
#define JT_REG
#endif

#define VM_ASSERT(condition, handler)           \
  do {                                          \
    if (SCM_UNLIKELY (!(condition)))            \
      {                                         \
        SYNC_ALL();                             \
        handler;                                \
      }                                         \
  } while (0)

#ifdef VM_ENABLE_ASSERTIONS
# define ASSERT(condition) VM_ASSERT (condition, abort())
#else
# define ASSERT(condition)
#endif


/* Cache the VM's instruction, stack, and frame pointer in local variables.  */
#define CACHE_REGISTER()			\
{						\
  ip = vp->ip;					\
  sp = vp->sp;					\
  fp = vp->fp;					\
}

/* Update the registers in VP, a pointer to the current VM.  This must be done
   at least before any GC invocation so that `vp->sp' is up-to-date and the
   whole stack gets marked.  */
#define SYNC_REGISTER()				\
{						\
  vp->ip = ip;					\
  vp->sp = sp;					\
  vp->fp = fp;					\
}

/* FIXME */
#define ASSERT_VARIABLE(x)                                              \
  VM_ASSERT (SCM_VARIABLEP (x), abort())
#define ASSERT_BOUND_VARIABLE(x)                                        \
  VM_ASSERT (SCM_VARIABLEP (x)                                          \
             && !scm_is_eq (SCM_VARIABLE_REF (x), SCM_UNDEFINED),       \
             abort())

#ifdef VM_ENABLE_PARANOID_ASSERTIONS
#define CHECK_IP() \
  do { if (ip < bp->base || ip - bp->base > bp->len) abort (); } while (0)
#define ASSERT_ALIGNED_PROCEDURE() \
  do { if ((scm_t_bits)bp % 8) abort (); } while (0)
#define ASSERT_BOUND(x) \
  VM_ASSERT (!scm_is_eq ((x), SCM_UNDEFINED), abort())
#else
#define CHECK_IP()
#define ASSERT_ALIGNED_PROCEDURE()
#define ASSERT_BOUND(x)
#endif

/* Cache the object table and free variables.  */
#define CACHE_PROGRAM()							\
{									\
  if (bp != SCM_PROGRAM_DATA (program)) {                               \
    bp = SCM_PROGRAM_DATA (program);					\
    ASSERT_ALIGNED_PROCEDURE ();                                        \
    if (SCM_I_IS_VECTOR (SCM_PROGRAM_OBJTABLE (program))) {             \
      objects = SCM_I_VECTOR_WELTS (SCM_PROGRAM_OBJTABLE (program));    \
    } else {                                                            \
      objects = NULL;                                                   \
    }                                                                   \
  }                                                                     \
}

#define SYNC_BEFORE_GC()			\
{						\
  SYNC_REGISTER ();				\
}

#define SYNC_ALL()				\
{						\
  SYNC_REGISTER ();				\
}

\f
/*
 * Error check
 */

/* Accesses to a program's object table.  */
#define CHECK_OBJECT(_num)
#define CHECK_FREE_VARIABLE(_num)

\f
/*
 * Hooks
 */

#if VM_USE_HOOKS
#define RUN_HOOK(h)                                     \
  {                                                     \
    if (SCM_UNLIKELY (vp->trace_level > 0))             \
      {                                                 \
        SYNC_REGISTER ();				\
        vm_dispatch_hook (vm, h);                       \
      }                                                 \
  }
#define RUN_HOOK1(h, x)                                 \
  {                                                     \
    if (SCM_UNLIKELY (vp->trace_level > 0))             \
      {                                                 \
        PUSH (x);                                       \
        SYNC_REGISTER ();				\
        vm_dispatch_hook (vm, h);                       \
        DROP();                                         \
      }                                                 \
  }
#else
#define RUN_HOOK(h)
#define RUN_HOOK1(h, x)
#endif

#define APPLY_HOOK()                            \
  RUN_HOOK (SCM_VM_APPLY_HOOK)
#define PUSH_CONTINUATION_HOOK()                \
  RUN_HOOK (SCM_VM_PUSH_CONTINUATION_HOOK)
#define POP_CONTINUATION_HOOK(n)                \
  RUN_HOOK1 (SCM_VM_POP_CONTINUATION_HOOK, SCM_I_MAKINUM (n))
#define NEXT_HOOK()                             \
  RUN_HOOK (SCM_VM_NEXT_HOOK)
#define ABORT_CONTINUATION_HOOK()               \
  RUN_HOOK (SCM_VM_ABORT_CONTINUATION_HOOK)
#define RESTORE_CONTINUATION_HOOK()            \
  RUN_HOOK (SCM_VM_RESTORE_CONTINUATION_HOOK)

#define VM_HANDLE_INTERRUPTS                     \
  SCM_ASYNC_TICK_WITH_CODE (current_thread, SYNC_REGISTER ())

\f
/*
 * Stack operation
 */

#ifdef VM_ENABLE_STACK_NULLING
# define CHECK_STACK_LEAKN(_n) ASSERT (!sp[_n]);
# define CHECK_STACK_LEAK() CHECK_STACK_LEAKN(1)
# define NULLSTACK(_n) { int __x = _n; CHECK_STACK_LEAKN (_n+1); while (__x > 0) sp[__x--] = NULL; }
/* If you have a nonlocal exit in a pre-wind proc while invoking a continuation
   inside a dynwind (phew!), the stack is fully rewound but vm_reset_stack for
   that continuation doesn't have a chance to run. It's not important on a
   semantic level, but it does mess up our stack nulling -- so this macro is to
   fix that. */
# define NULLSTACK_FOR_NONLOCAL_EXIT() if (vp->sp > sp) NULLSTACK (vp->sp - sp);
#else
# define CHECK_STACK_LEAKN(_n)
# define CHECK_STACK_LEAK()
# define NULLSTACK(_n)
# define NULLSTACK_FOR_NONLOCAL_EXIT()
#endif

/* For this check, we don't use VM_ASSERT, because that leads to a
   per-site SYNC_ALL, which is too much code growth.  The real problem
   of course is having to check for overflow all the time... */
#define CHECK_OVERFLOW()                                                \
  do { if (SCM_UNLIKELY (sp >= stack_limit)) goto handle_overflow; } while (0)

#ifdef VM_CHECK_UNDERFLOW
#define PRE_CHECK_UNDERFLOW(N)                  \
  VM_ASSERT (sp - (N) > SCM_FRAME_UPPER_ADDRESS (fp), vm_error_stack_underflow ())
#define CHECK_UNDERFLOW() PRE_CHECK_UNDERFLOW (0)
#else
#define PRE_CHECK_UNDERFLOW(N) /* nop */
#define CHECK_UNDERFLOW() /* nop */
#endif


#define PUSH(x)	do { sp++; CHECK_OVERFLOW (); *sp = x; } while (0)
#define DROP()	do { sp--; CHECK_UNDERFLOW (); NULLSTACK (1); } while (0)
#define DROPN(_n) do { sp -= (_n); CHECK_UNDERFLOW (); NULLSTACK (_n); } while (0)
#define POP(x)	do { PRE_CHECK_UNDERFLOW (1); x = *sp--; NULLSTACK (1); } while (0)
#define POP2(x,y) do { PRE_CHECK_UNDERFLOW (2); x = *sp--; y = *sp--; NULLSTACK (2); } while (0)
#define POP3(x,y,z) do { PRE_CHECK_UNDERFLOW (3); x = *sp--; y = *sp--; z = *sp--; NULLSTACK (3); } while (0)

/* Pop the N objects on top of the stack and push a list that contains
   them.  */
#define POP_LIST(n)				\
do						\
{						\
  int i;					\
  SCM l = SCM_EOL, x;				\
  SYNC_BEFORE_GC ();                            \
  for (i = n; i; i--)                           \
    {                                           \
      POP (x);                                  \
      l = scm_cons (x, l);                      \
    }                                           \
  PUSH (l);					\
} while (0)

/* The opposite: push all of the elements in L onto the list. */
#define PUSH_LIST(l, NILP)			\
do						\
{						\
  for (; scm_is_pair (l); l = SCM_CDR (l))      \
    PUSH (SCM_CAR (l));                         \
  VM_ASSERT (NILP (l), vm_error_improper_list (l)); \
} while (0)

\f
/*
 * Instruction operation
 */

#define FETCH()		(*ip++)
#define FETCH_LENGTH(len) do { len=*ip++; len<<=8; len+=*ip++; len<<=8; len+=*ip++; } while (0)

#undef NEXT_JUMP
#ifdef HAVE_LABELS_AS_VALUES
# define NEXT_JUMP()		goto *jump_table[FETCH () & SCM_VM_INSTRUCTION_MASK]
#else
# define NEXT_JUMP()		goto vm_start
#endif

#define NEXT					\
{						\
  NEXT_HOOK ();					\
  CHECK_STACK_LEAK ();                          \
  NEXT_JUMP ();					\
}

\f
/* See frames.h for the layout of stack frames */
/* When this is called, bp points to the new program data,
   and the arguments are already on the stack */
#define DROP_FRAME()                            \
  {                                             \
    sp -= 3;                                    \
    NULLSTACK (3);                              \
    CHECK_UNDERFLOW ();                         \
  }
    

static SCM
VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
{
  /* VM registers */
  register scm_t_uint8 *ip IP_REG;	/* instruction pointer */
  register SCM *sp SP_REG;		/* stack pointer */
  register SCM *fp FP_REG;		/* frame pointer */
  struct scm_vm *vp = SCM_VM_DATA (vm);

  /* Cache variables */
  struct scm_objcode *bp = NULL;	/* program base pointer */
  SCM *objects = NULL;			/* constant objects */
  SCM *stack_limit = vp->stack_limit;	/* stack limit address */

  scm_i_thread *current_thread = SCM_I_CURRENT_THREAD;

  /* Internal variables */
  int nvalues = 0;
  scm_i_jmp_buf registers;              /* used for prompts */

#ifdef HAVE_LABELS_AS_VALUES
  static const void **jump_table_pointer = NULL;
#endif

#ifdef HAVE_LABELS_AS_VALUES
  register const void **jump_table JT_REG;

  if (SCM_UNLIKELY (!jump_table_pointer))
    {
      int i;
      jump_table_pointer = malloc (SCM_VM_NUM_INSTRUCTIONS * sizeof (void*));
      for (i = 0; i < SCM_VM_NUM_INSTRUCTIONS; i++)
        jump_table_pointer[i] = &&vm_error_bad_instruction;
#define VM_INSTRUCTION_TO_LABEL 1
#define jump_table jump_table_pointer
#include <libguile/vm-expand.h>
#include <libguile/vm-i-system.i>
#include <libguile/vm-i-scheme.i>
#include <libguile/vm-i-loader.i>
#undef jump_table
#undef VM_INSTRUCTION_TO_LABEL
    }

  /* Attempt to keep JUMP_TABLE_POINTER in a register.  This saves one
     load instruction at each instruction dispatch.  */
  jump_table = jump_table_pointer;
#endif

  if (SCM_I_SETJMP (registers))
    {
      /* Non-local return.  Cache the VM registers back from the vp, and
         go to the handler.

         Note, at this point, we must assume that any variable local to
         vm_engine that can be assigned *has* been assigned. So we need to pull
         all our state back from the ip/fp/sp.
      */
      CACHE_REGISTER ();
      program = SCM_FRAME_PROGRAM (fp);
      CACHE_PROGRAM ();
      /* The stack contains the values returned to this continuation,
         along with a number-of-values marker -- like an MV return. */
      ABORT_CONTINUATION_HOOK ();
      NEXT;
    }

  /* Initial frame */
  CACHE_REGISTER ();
  PUSH (SCM_PACK (fp)); /* dynamic link */
  PUSH (SCM_PACK (0)); /* mvra */
  PUSH (SCM_PACK (ip)); /* ra */
  PUSH (boot_continuation);
  fp = sp + 1;
  ip = SCM_C_OBJCODE_BASE (SCM_PROGRAM_DATA (boot_continuation));

  /* MV-call frame, function & arguments */
  PUSH (SCM_PACK (fp)); /* dynamic link */
  PUSH (SCM_PACK (ip + 1)); /* mvra */
  PUSH (SCM_PACK (ip)); /* ra */
  PUSH (program);
  fp = sp + 1;
  VM_ASSERT (sp + nargs < stack_limit, vm_error_too_many_args (nargs));
  while (nargs--)
    PUSH (*argv++);

  PUSH_CONTINUATION_HOOK ();

 apply:
  program = fp[-1];
  if (!SCM_PROGRAM_P (program))
    {
      if (SCM_STRUCTP (program) && SCM_STRUCT_APPLICABLE_P (program))
        fp[-1] = SCM_STRUCT_PROCEDURE (program);
      else if (SCM_HAS_TYP7 (program, scm_tc7_smob)
               && SCM_SMOB_APPLICABLE_P (program))
        {
          /* (smob arg0 ... argN) => (apply-smob smob arg0 ... argN) */
          int i;
          PUSH (SCM_BOOL_F);
          for (i = sp - fp; i >= 0; i--)
            fp[i] = fp[i - 1];
          fp[-1] = SCM_SMOB_DESCRIPTOR (program).apply_trampoline;
        }
      else
        {
          SYNC_ALL();
          vm_error_wrong_type_apply (program);
        }
      goto apply;
    }

  CACHE_PROGRAM ();
  ip = SCM_C_OBJCODE_BASE (bp);

  APPLY_HOOK ();

  /* Let's go! */
  NEXT;

#ifndef HAVE_LABELS_AS_VALUES
 vm_start:
  switch ((*ip++) & SCM_VM_INSTRUCTION_MASK) {
#endif

#include "vm-expand.h"
#include "vm-i-system.c"
#include "vm-i-scheme.c"
#include "vm-i-loader.c"

#ifndef HAVE_LABELS_AS_VALUES
  default:
    goto vm_error_bad_instruction;
  }
#endif

  abort (); /* never reached */

 vm_error_bad_instruction:
  vm_error_bad_instruction (ip[-1]);
  abort (); /* never reached */

 handle_overflow:
  SYNC_ALL ();
  vm_error_stack_overflow (vp);
  abort (); /* never reached */
}

#undef RUN_HOOK
#undef RUN_HOOK1
#undef VM_USE_HOOKS

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/
Commit	Line	Data
27c7c630	1	/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
a98cef7e	2	*
560b9c25	3	* This library is free software; you can redistribute it and/or
53befeb7 NJ	4	* modify it under the terms of the GNU Lesser General Public License
	5	* as published by the Free Software Foundation; either version 3 of
	6	* the License, or (at your option) any later version.
a98cef7e	7	*
53befeb7 NJ	8	* This library is distributed in the hope that it will be useful, but
53befeb7 NJ	9	* WITHOUT ANY WARRANTY; without even the implied warranty of
560b9c25 AW	10	* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
560b9c25 AW	11	* Lesser General Public License for more details.
a98cef7e	12	*
560b9c25 AW	13	* You should have received a copy of the GNU Lesser General Public
560b9c25 AW	14	* License along with this library; if not, write to the Free Software
53befeb7 NJ	15	* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
53befeb7 NJ	16	* 02110-1301 USA
560b9c25	17	*/
a98cef7e	18
6d14383e AW	19	/* This file is included in vm.c multiple times */
	20
	21	#if (VM_ENGINE == SCM_VM_REGULAR_ENGINE)
ff3968c2	22	# define VM_USE_HOOKS 0 /* Various hooks */
6d14383e	23	#elif (VM_ENGINE == SCM_VM_DEBUG_ENGINE)
ff3968c2	24	# define VM_USE_HOOKS 1
6d14383e	25	#else
ff3968c2	26	# error unknown debug engine VM_ENGINE
6d14383e	27	#endif
a98cef7e	28
a98cef7e	29
eac12024 AW	30	/* Register optimization. [ stolen from librep/src/lispmach.h,v 1.3 ]
	31
	32	Some compilers underestimate the use of the local variables representing
	33	the abstract machine registers, and don't put them in hardware registers,
	34	which slows down the interpreter considerably.
	35	For GCC, I have hand-assigned hardware registers for several architectures.
	36	*/
	37
	38	#ifdef __GNUC__
	39	#ifdef __mips__
	40	#define IP_REG asm("$16")
	41	#define SP_REG asm("$17")
	42	#define FP_REG asm("$18")
	43	#endif
	44	#ifdef __sparc__
	45	#define IP_REG asm("%l0")
	46	#define SP_REG asm("%l1")
	47	#define FP_REG asm("%l2")
	48	#endif
	49	#ifdef __alpha__
	50	#ifdef __CRAY__
	51	#define IP_REG asm("r9")
	52	#define SP_REG asm("r10")
	53	#define FP_REG asm("r11")
	54	#else
	55	#define IP_REG asm("$9")
	56	#define SP_REG asm("$10")
	57	#define FP_REG asm("$11")
	58	#endif
	59	#endif
	60	#ifdef __i386__
	61	/* too few registers! because of register allocation errors with various gcs,
	62	just punt on explicit assignments on i386, hoping that the "register"
	63	declaration will be sufficient. */
	64	#elif defined __x86_64__
	65	/* GCC 4.6 chooses %rbp for IP_REG and %rbx for SP_REG, which works
	66	well. Tell it to keep the jump table in a r12, which is
	67	callee-saved. */
	68	#define JT_REG asm ("r12")
	69	#endif
	70	#if defined(PPC) \|\| defined(_POWER) \|\| defined(_IBMR2)
	71	#define IP_REG asm("26")
	72	#define SP_REG asm("27")
	73	#define FP_REG asm("28")
	74	#endif
	75	#ifdef __hppa__
	76	#define IP_REG asm("%r18")
	77	#define SP_REG asm("%r17")
	78	#define FP_REG asm("%r16")
	79	#endif
	80	#ifdef __mc68000__
	81	#define IP_REG asm("a5")
	82	#define SP_REG asm("a4")
	83	#define FP_REG
	84	#endif
	85	#ifdef __arm__
	86	#define IP_REG asm("r9")
	87	#define SP_REG asm("r8")
	88	#define FP_REG asm("r7")
	89	#endif
	90	#endif
	91
	92	#ifndef IP_REG
	93	#define IP_REG
94	#endif
95	#ifndef SP_REG
96	#define SP_REG
97	#endif
98	#ifndef FP_REG
99	#define FP_REG
100	#endif
101	#ifndef JT_REG
102	#define JT_REG
103	#endif
104
27c7c630 AW	105	#define VM_ASSERT(condition, handler) \
	106	do { \
	107	if (SCM_UNLIKELY (!(condition))) \
	108	{ \
	109	SYNC_ALL(); \
	110	handler; \
	111	} \
	112	} while (0)
eac12024 AW	113
	114	#ifdef VM_ENABLE_ASSERTIONS
	115	# define ASSERT(condition) VM_ASSERT (condition, abort())
	116	#else
	117	# define ASSERT(condition)
	118	#endif
	119
	120
	121	/* Cache the VM's instruction, stack, and frame pointer in local variables. */
	122	#define CACHE_REGISTER() \
	123	{ \
	124	ip = vp->ip; \
	125	sp = vp->sp; \
	126	fp = vp->fp; \
	127	}
	128
	129	/* Update the registers in VP, a pointer to the current VM. This must be done
	130	at least before any GC invocation so that `vp->sp' is up-to-date and the
	131	whole stack gets marked. */
	132	#define SYNC_REGISTER() \
	133	{ \
	134	vp->ip = ip; \
	135	vp->sp = sp; \
	136	vp->fp = fp; \
	137	}
	138
	139	/* FIXME */
	140	#define ASSERT_VARIABLE(x) \
27c7c630	141	VM_ASSERT (SCM_VARIABLEP (x), abort())
eac12024	142	#define ASSERT_BOUND_VARIABLE(x) \
27c7c630 AW	143	VM_ASSERT (SCM_VARIABLEP (x) \
	144	&& !scm_is_eq (SCM_VARIABLE_REF (x), SCM_UNDEFINED), \
	145	abort())
eac12024 AW	146
	147	#ifdef VM_ENABLE_PARANOID_ASSERTIONS
	148	#define CHECK_IP() \
	149	do { if (ip < bp->base \|\| ip - bp->base > bp->len) abort (); } while (0)
	150	#define ASSERT_ALIGNED_PROCEDURE() \
	151	do { if ((scm_t_bits)bp % 8) abort (); } while (0)
	152	#define ASSERT_BOUND(x) \
27c7c630	153	VM_ASSERT (!scm_is_eq ((x), SCM_UNDEFINED), abort())
eac12024 AW	154	#else
	155	#define CHECK_IP()
	156	#define ASSERT_ALIGNED_PROCEDURE()
	157	#define ASSERT_BOUND(x)
	158	#endif
	159
eac12024 AW	160	/* Cache the object table and free variables. */
	161	#define CACHE_PROGRAM() \
	162	{ \
	163	if (bp != SCM_PROGRAM_DATA (program)) { \
	164	bp = SCM_PROGRAM_DATA (program); \
	165	ASSERT_ALIGNED_PROCEDURE (); \
	166	if (SCM_I_IS_VECTOR (SCM_PROGRAM_OBJTABLE (program))) { \
	167	objects = SCM_I_VECTOR_WELTS (SCM_PROGRAM_OBJTABLE (program)); \
eac12024 AW	168	} else { \
eac12024 AW	169	objects = NULL; \
eac12024 AW	170	} \
	171	} \
	172	}
	173
	174	#define SYNC_BEFORE_GC() \
	175	{ \
	176	SYNC_REGISTER (); \
	177	}
	178
	179	#define SYNC_ALL() \
	180	{ \
	181	SYNC_REGISTER (); \
	182	}
	183
	184	\f
	185	/*
	186	* Error check
	187	*/
	188
	189	/* Accesses to a program's object table. */
eac12024	190	#define CHECK_OBJECT(_num)
eac12024	191	#define CHECK_FREE_VARIABLE(_num)
eac12024 AW	192
	193	\f
	194	/*
	195	* Hooks
	196	*/
	197
eac12024 AW	198	#if VM_USE_HOOKS
	199	#define RUN_HOOK(h) \
	200	{ \
	201	if (SCM_UNLIKELY (vp->trace_level > 0)) \
	202	{ \
	203	SYNC_REGISTER (); \
	204	vm_dispatch_hook (vm, h); \
	205	} \
	206	}
	207	#define RUN_HOOK1(h, x) \
	208	{ \
	209	if (SCM_UNLIKELY (vp->trace_level > 0)) \
	210	{ \
	211	PUSH (x); \
	212	SYNC_REGISTER (); \
	213	vm_dispatch_hook (vm, h); \
	214	DROP(); \
	215	} \
	216	}
	217	#else
	218	#define RUN_HOOK(h)
	219	#define RUN_HOOK1(h, x)
	220	#endif
	221
	222	#define APPLY_HOOK() \
	223	RUN_HOOK (SCM_VM_APPLY_HOOK)
	224	#define PUSH_CONTINUATION_HOOK() \
	225	RUN_HOOK (SCM_VM_PUSH_CONTINUATION_HOOK)
	226	#define POP_CONTINUATION_HOOK(n) \
	227	RUN_HOOK1 (SCM_VM_POP_CONTINUATION_HOOK, SCM_I_MAKINUM (n))
	228	#define NEXT_HOOK() \
	229	RUN_HOOK (SCM_VM_NEXT_HOOK)
	230	#define ABORT_CONTINUATION_HOOK() \
	231	RUN_HOOK (SCM_VM_ABORT_CONTINUATION_HOOK)
	232	#define RESTORE_CONTINUATION_HOOK() \
	233	RUN_HOOK (SCM_VM_RESTORE_CONTINUATION_HOOK)
	234
	235	#define VM_HANDLE_INTERRUPTS \
	236	SCM_ASYNC_TICK_WITH_CODE (current_thread, SYNC_REGISTER ())
	237
	238	\f
	239	/*
	240	* Stack operation
	241	*/
	242
	243	#ifdef VM_ENABLE_STACK_NULLING
	244	# define CHECK_STACK_LEAKN(_n) ASSERT (!sp[_n]);
	245	# define CHECK_STACK_LEAK() CHECK_STACK_LEAKN(1)
	246	# define NULLSTACK(_n) { int __x = _n; CHECK_STACK_LEAKN (_n+1); while (__x > 0) sp[__x--] = NULL; }
	247	/* If you have a nonlocal exit in a pre-wind proc while invoking a continuation
	248	inside a dynwind (phew!), the stack is fully rewound but vm_reset_stack for
	249	that continuation doesn't have a chance to run. It's not important on a
	250	semantic level, but it does mess up our stack nulling -- so this macro is to
	251	fix that. */
	252	# define NULLSTACK_FOR_NONLOCAL_EXIT() if (vp->sp > sp) NULLSTACK (vp->sp - sp);
	253	#else
	254	# define CHECK_STACK_LEAKN(_n)
	255	# define CHECK_STACK_LEAK()
	256	# define NULLSTACK(_n)
	257	# define NULLSTACK_FOR_NONLOCAL_EXIT()
	258	#endif
	259
	260	/* For this check, we don't use VM_ASSERT, because that leads to a
	261	per-site SYNC_ALL, which is too much code growth. The real problem
262	of course is having to check for overflow all the time... */
263	#define CHECK_OVERFLOW() \
264	do { if (SCM_UNLIKELY (sp >= stack_limit)) goto handle_overflow; } while (0)
265
266	#ifdef VM_CHECK_UNDERFLOW
267	#define PRE_CHECK_UNDERFLOW(N) \
268	VM_ASSERT (sp - (N) > SCM_FRAME_UPPER_ADDRESS (fp), vm_error_stack_underflow ())
269	#define CHECK_UNDERFLOW() PRE_CHECK_UNDERFLOW (0)
270	#else
271	#define PRE_CHECK_UNDERFLOW(N) /* nop */
272	#define CHECK_UNDERFLOW() /* nop */
273	#endif
274
275
276	#define PUSH(x) do { sp++; CHECK_OVERFLOW (); *sp = x; } while (0)
277	#define DROP() do { sp--; CHECK_UNDERFLOW (); NULLSTACK (1); } while (0)
278	#define DROPN(_n) do { sp -= (_n); CHECK_UNDERFLOW (); NULLSTACK (_n); } while (0)
279	#define POP(x) do { PRE_CHECK_UNDERFLOW (1); x = *sp--; NULLSTACK (1); } while (0)
280	#define POP2(x,y) do { PRE_CHECK_UNDERFLOW (2); x = sp--; y = sp--; NULLSTACK (2); } while (0)
281	#define POP3(x,y,z) do { PRE_CHECK_UNDERFLOW (3); x = sp--; y = sp--; z = *sp--; NULLSTACK (3); } while (0)
282
eac12024 AW	283	/* Pop the N objects on top of the stack and push a list that contains
	284	them. */
	285	#define POP_LIST(n) \
	286	do \
	287	{ \
	288	int i; \
	289	SCM l = SCM_EOL, x; \
52182d52	290	SYNC_BEFORE_GC (); \
eac12024 AW	291	for (i = n; i; i--) \
	292	{ \
	293	POP (x); \
52182d52	294	l = scm_cons (x, l); \
eac12024 AW	295	} \
	296	PUSH (l); \
	297	} while (0)
	298
	299	/* The opposite: push all of the elements in L onto the list. */
	300	#define PUSH_LIST(l, NILP) \
	301	do \
	302	{ \
	303	for (; scm_is_pair (l); l = SCM_CDR (l)) \
	304	PUSH (SCM_CAR (l)); \
	305	VM_ASSERT (NILP (l), vm_error_improper_list (l)); \
	306	} while (0)
	307
	308	\f
eac12024 AW	309	/*
	310	* Instruction operation
	311	*/
	312
	313	#define FETCH() (*ip++)
	314	#define FETCH_LENGTH(len) do { len=ip++; len<<=8; len+=ip++; len<<=8; len+=*ip++; } while (0)
	315
	316	#undef NEXT_JUMP
	317	#ifdef HAVE_LABELS_AS_VALUES
27c7c630	318	# define NEXT_JUMP() goto *jump_table[FETCH () & SCM_VM_INSTRUCTION_MASK]
eac12024	319	#else
27c7c630	320	# define NEXT_JUMP() goto vm_start
eac12024 AW	321	#endif
	322
	323	#define NEXT \
	324	{ \
	325	NEXT_HOOK (); \
	326	CHECK_STACK_LEAK (); \
	327	NEXT_JUMP (); \
	328	}
	329
	330	\f
	331	/* See frames.h for the layout of stack frames */
	332	/* When this is called, bp points to the new program data,
	333	and the arguments are already on the stack */
	334	#define DROP_FRAME() \
	335	{ \
	336	sp -= 3; \
	337	NULLSTACK (3); \
	338	CHECK_UNDERFLOW (); \
	339	}
	340
238e7a11	341
a98cef7e	342	static SCM
7656f194	343	VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
a98cef7e	344	{
17e90c5e	345	/* VM registers */
2fb924f6	346	register scm_t_uint8 ip IP_REG; / instruction pointer */
17e90c5e KN	347	register SCM sp SP_REG; / stack pointer */
17e90c5e KN	348	register SCM fp FP_REG; / frame pointer */
7656f194	349	struct scm_vm *vp = SCM_VM_DATA (vm);
a98cef7e	350
d608d68d	351	/* Cache variables */
53e28ed9	352	struct scm_objcode bp = NULL; / program base pointer */
17e90c5e	353	SCM objects = NULL; / constant objects */
3d5ee0cd	354	SCM stack_limit = vp->stack_limit; / stack limit address */
2d026f04	355
a2a6c0e3	356	scm_i_thread *current_thread = SCM_I_CURRENT_THREAD;
a98cef7e	357
d608d68d	358	/* Internal variables */
ef24c01b	359	int nvalues = 0;
9d381ba4 AW	360	scm_i_jmp_buf registers; /* used for prompts */
9d381ba4 AW	361
53e28ed9	362	#ifdef HAVE_LABELS_AS_VALUES
37a5970c	363	static const void **jump_table_pointer = NULL;
e06e857c	364	#endif
37a5970c	365
e06e857c	366	#ifdef HAVE_LABELS_AS_VALUES
37a5970c LC	367	register const void **jump_table JT_REG;
	368
	369	if (SCM_UNLIKELY (!jump_table_pointer))
53e28ed9 AW	370	{
53e28ed9 AW	371	int i;
37a5970c	372	jump_table_pointer = malloc (SCM_VM_NUM_INSTRUCTIONS * sizeof (void*));
53e28ed9	373	for (i = 0; i < SCM_VM_NUM_INSTRUCTIONS; i++)
37a5970c	374	jump_table_pointer[i] = &&vm_error_bad_instruction;
53e28ed9	375	#define VM_INSTRUCTION_TO_LABEL 1
37a5970c	376	#define jump_table jump_table_pointer
aeeff258 AW	377	#include <libguile/vm-expand.h>
	378	#include <libguile/vm-i-system.i>
	379	#include <libguile/vm-i-scheme.i>
	380	#include <libguile/vm-i-loader.i>
37a5970c	381	#undef jump_table
53e28ed9 AW	382	#undef VM_INSTRUCTION_TO_LABEL
53e28ed9 AW	383	}
37a5970c LC	384
	385	/* Attempt to keep JUMP_TABLE_POINTER in a register. This saves one
	386	load instruction at each instruction dispatch. */
	387	jump_table = jump_table_pointer;
53e28ed9	388	#endif
9d381ba4 AW	389
	390	if (SCM_I_SETJMP (registers))
	391	{
	392	/* Non-local return. Cache the VM registers back from the vp, and
	393	go to the handler.
	394
	395	Note, at this point, we must assume that any variable local to
	396	vm_engine that can be assigned has been assigned. So we need to pull
	397	all our state back from the ip/fp/sp.
	398	*/
	399	CACHE_REGISTER ();
	400	program = SCM_FRAME_PROGRAM (fp);
	401	CACHE_PROGRAM ();
	402	/* The stack contains the values returned to this continuation,
	403	along with a number-of-values marker -- like an MV return. */
	404	ABORT_CONTINUATION_HOOK ();
	405	NEXT;
	406	}
53e28ed9	407
67b699cc AW	408	/* Initial frame */
	409	CACHE_REGISTER ();
	410	PUSH (SCM_PACK (fp)); /* dynamic link */
	411	PUSH (SCM_PACK (0)); /* mvra */
	412	PUSH (SCM_PACK (ip)); /* ra */
	413	PUSH (boot_continuation);
	414	fp = sp + 1;
	415	ip = SCM_C_OBJCODE_BASE (SCM_PROGRAM_DATA (boot_continuation));
	416
	417	/* MV-call frame, function & arguments */
	418	PUSH (SCM_PACK (fp)); /* dynamic link */
	419	PUSH (SCM_PACK (ip + 1)); /* mvra */
	420	PUSH (SCM_PACK (ip)); /* ra */
	421	PUSH (program);
	422	fp = sp + 1;
	423	VM_ASSERT (sp + nargs < stack_limit, vm_error_too_many_args (nargs));
	424	while (nargs--)
	425	PUSH (*argv++);
	426
	427	PUSH_CONTINUATION_HOOK ();
	428
	429	apply:
	430	program = fp[-1];
	431	if (!SCM_PROGRAM_P (program))
	432	{
	433	if (SCM_STRUCTP (program) && SCM_STRUCT_APPLICABLE_P (program))
	434	fp[-1] = SCM_STRUCT_PROCEDURE (program);
968a9add	435	else if (SCM_HAS_TYP7 (program, scm_tc7_smob)
67b699cc AW	436	&& SCM_SMOB_APPLICABLE_P (program))
	437	{
	438	/* (smob arg0 ... argN) => (apply-smob smob arg0 ... argN) */
	439	int i;
	440	PUSH (SCM_BOOL_F);
	441	for (i = sp - fp; i >= 0; i--)
	442	fp[i] = fp[i - 1];
968a9add	443	fp[-1] = SCM_SMOB_DESCRIPTOR (program).apply_trampoline;
67b699cc AW	444	}
	445	else
	446	{
	447	SYNC_ALL();
	448	vm_error_wrong_type_apply (program);
	449	}
	450	goto apply;
	451	}
	452
	453	CACHE_PROGRAM ();
	454	ip = SCM_C_OBJCODE_BASE (bp);
	455
	456	APPLY_HOOK ();
a98cef7e KN	457
a98cef7e KN	458	/* Let's go! */
53e28ed9	459	NEXT;
a98cef7e KN	460
a98cef7e KN	461	#ifndef HAVE_LABELS_AS_VALUES
17e90c5e	462	vm_start:
53e28ed9	463	switch ((*ip++) & SCM_VM_INSTRUCTION_MASK) {
a98cef7e KN	464	#endif
a98cef7e KN	465
83495480 AW	466	#include "vm-expand.h"
	467	#include "vm-i-system.c"
	468	#include "vm-i-scheme.c"
	469	#include "vm-i-loader.c"
a98cef7e KN	470
a98cef7e KN	471	#ifndef HAVE_LABELS_AS_VALUES
53e28ed9 AW	472	default:
53e28ed9 AW	473	goto vm_error_bad_instruction;
a98cef7e KN	474	}
	475	#endif
	476
53bdfcf0	477	abort (); /* never reached */
a52b2d3d	478
53bdfcf0 AW	479	vm_error_bad_instruction:
	480	vm_error_bad_instruction (ip[-1]);
	481	abort (); /* never reached */
17e90c5e	482
53bdfcf0 AW	483	handle_overflow:
	484	SYNC_ALL ();
	485	vm_error_stack_overflow (vp);
a98cef7e KN	486	abort (); /* never reached */
a98cef7e KN	487	}
6d14383e	488
27c7c630 AW	489	#undef RUN_HOOK
27c7c630 AW	490	#undef RUN_HOOK1
6d14383e	491	#undef VM_USE_HOOKS
17e90c5e KN	492
	493	/*
	494	Local Variables:
	495	c-file-style: "gnu"
	496	End:
	497	*/