libguile/vm-engine.c

   1 /* Copyright (C) 2001, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
   2  *
   3  * This library is free software; you can redistribute it and/or
   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.
   7  *
   8  * This library is distributed in the hope that it will be useful, but
   9  * WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11  * Lesser General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU Lesser General Public
  14  * License along with this library; if not, write to the Free Software
  15  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  16  * 02110-1301 USA
  17  */
  18
  19 /* This file is included in vm.c multiple times */
  20
  21 #if (VM_ENGINE == SCM_VM_REGULAR_ENGINE)
  22 #define VM_USE_HOOKS            0       /* Various hooks */
  23 #define VM_CHECK_OBJECT         0       /* Check object table */
  24 #define VM_CHECK_FREE_VARIABLES 0       /* Check free variable access */
  25 #define VM_CHECK_UNDERFLOW      0       /* Check underflow when popping values */
  26 #elif (VM_ENGINE == SCM_VM_DEBUG_ENGINE)
  27 #define VM_USE_HOOKS            1
  28 #define VM_CHECK_OBJECT         0
  29 #define VM_CHECK_FREE_VARIABLES 0
  30 #define VM_CHECK_UNDERFLOW      0       /* Check underflow when popping values */
  31 #else
  32 #error unknown debug engine VM_ENGINE
  33 #endif
  34
  35 #include "vm-engine.h"
  36
  37
  38 static SCM
  39 VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
  40 {
  41   /* VM registers */
  42   register scm_t_uint8 *ip IP_REG;      /* instruction pointer */
  43   register SCM *sp SP_REG;              /* stack pointer */
  44   register SCM *fp FP_REG;              /* frame pointer */
  45   struct scm_vm *vp = SCM_VM_DATA (vm);
  46
  47   /* Cache variables */
  48   struct scm_objcode *bp = NULL;        /* program base pointer */
  49   SCM *objects = NULL;                  /* constant objects */
  50 #if VM_CHECK_OBJECT
  51   size_t object_count = 0;              /* length of OBJECTS */
  52 #endif
  53   SCM *stack_limit = vp->stack_limit;   /* stack limit address */
  54
  55   scm_i_thread *current_thread = SCM_I_CURRENT_THREAD;
  56
  57   /* Internal variables */
  58   int nvalues = 0;
  59   scm_i_jmp_buf registers;              /* used for prompts */
  60
  61 #ifdef HAVE_LABELS_AS_VALUES
  62   static const void **jump_table_pointer = NULL;
  63 #endif
  64
  65 #ifdef HAVE_LABELS_AS_VALUES
  66   register const void **jump_table JT_REG;
  67
  68   if (SCM_UNLIKELY (!jump_table_pointer))
  69     {
  70       int i;
  71       jump_table_pointer = malloc (SCM_VM_NUM_INSTRUCTIONS * sizeof (void*));
  72       for (i = 0; i < SCM_VM_NUM_INSTRUCTIONS; i++)
  73         jump_table_pointer[i] = &&vm_error_bad_instruction;
  74 #define VM_INSTRUCTION_TO_LABEL 1
  75 #define jump_table jump_table_pointer
  76 #include <libguile/vm-expand.h>
  77 #include <libguile/vm-i-system.i>
  78 #include <libguile/vm-i-scheme.i>
  79 #include <libguile/vm-i-loader.i>
  80 #undef jump_table
  81 #undef VM_INSTRUCTION_TO_LABEL
  82     }
  83
  84   /* Attempt to keep JUMP_TABLE_POINTER in a register.  This saves one
  85      load instruction at each instruction dispatch.  */
  86   jump_table = jump_table_pointer;
  87 #endif
  88
  89   if (SCM_I_SETJMP (registers))
  90     {
  91       /* Non-local return.  Cache the VM registers back from the vp, and
  92          go to the handler.
  93
  94          Note, at this point, we must assume that any variable local to
  95          vm_engine that can be assigned *has* been assigned. So we need to pull
  96          all our state back from the ip/fp/sp.
  97       */
  98       CACHE_REGISTER ();
  99       program = SCM_FRAME_PROGRAM (fp);
 100       CACHE_PROGRAM ();
 101       /* The stack contains the values returned to this continuation,
 102          along with a number-of-values marker -- like an MV return. */
 103       ABORT_CONTINUATION_HOOK ();
 104       NEXT;
 105     }
 106
 107   /* Initial frame */
 108   CACHE_REGISTER ();
 109   PUSH (SCM_PACK (fp)); /* dynamic link */
 110   PUSH (SCM_PACK (0)); /* mvra */
 111   PUSH (SCM_PACK (ip)); /* ra */
 112   PUSH (boot_continuation);
 113   fp = sp + 1;
 114   ip = SCM_C_OBJCODE_BASE (SCM_PROGRAM_DATA (boot_continuation));
 115
 116   /* MV-call frame, function & arguments */
 117   PUSH (SCM_PACK (fp)); /* dynamic link */
 118   PUSH (SCM_PACK (ip + 1)); /* mvra */
 119   PUSH (SCM_PACK (ip)); /* ra */
 120   PUSH (program);
 121   fp = sp + 1;
 122   VM_ASSERT (sp + nargs < stack_limit, vm_error_too_many_args (nargs));
 123   while (nargs--)
 124     PUSH (*argv++);
 125
 126   PUSH_CONTINUATION_HOOK ();
 127
 128  apply:
 129   program = fp[-1];
 130   if (!SCM_PROGRAM_P (program))
 131     {
 132       if (SCM_STRUCTP (program) && SCM_STRUCT_APPLICABLE_P (program))
 133         fp[-1] = SCM_STRUCT_PROCEDURE (program);
 134       else if (SCM_HAS_TYP7 (program, scm_tc7_smob)
 135                && SCM_SMOB_APPLICABLE_P (program))
 136         {
 137           /* (smob arg0 ... argN) => (apply-smob smob arg0 ... argN) */
 138           int i;
 139           PUSH (SCM_BOOL_F);
 140           for (i = sp - fp; i >= 0; i--)
 141             fp[i] = fp[i - 1];
 142           fp[-1] = SCM_SMOB_DESCRIPTOR (program).apply_trampoline;
 143         }
 144       else
 145         {
 146           SYNC_ALL();
 147           vm_error_wrong_type_apply (program);
 148         }
 149       goto apply;
 150     }
 151
 152   CACHE_PROGRAM ();
 153   ip = SCM_C_OBJCODE_BASE (bp);
 154
 155   APPLY_HOOK ();
 156
 157   /* Let's go! */
 158   NEXT;
 159
 160 #ifndef HAVE_LABELS_AS_VALUES
 161  vm_start:
 162   switch ((*ip++) & SCM_VM_INSTRUCTION_MASK) {
 163 #endif
 164
 165 #include "vm-expand.h"
 166 #include "vm-i-system.c"
 167 #include "vm-i-scheme.c"
 168 #include "vm-i-loader.c"
 169
 170 #ifndef HAVE_LABELS_AS_VALUES
 171   default:
 172     goto vm_error_bad_instruction;
 173   }
 174 #endif
 175
 176   abort (); /* never reached */
 177
 178  vm_error_bad_instruction:
 179   vm_error_bad_instruction (ip[-1]);
 180   abort (); /* never reached */
 181
 182  handle_overflow:
 183   SYNC_ALL ();
 184   vm_error_stack_overflow (vp);
 185   abort (); /* never reached */
 186 }
 187
 188 #undef VM_USE_HOOKS
 189 #undef VM_CHECK_OBJECT
 190 #undef VM_CHECK_FREE_VARIABLE
 191 #undef VM_CHECK_UNDERFLOW
 192
 193 /*
 194   Local Variables:
 195   c-file-style: "gnu"
 196   End:
 197 */