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   const char *func_name = NULL;         /* used for error reporting */
  60   SCM finish_args;                      /* used both for returns: both in error
  61                                            and normal situations */
  62   scm_i_jmp_buf registers;              /* used for prompts */
  63
  64 #ifdef HAVE_LABELS_AS_VALUES
  65   static const void **jump_table_pointer = NULL;
  66 #endif
  67
  68 #ifdef HAVE_LABELS_AS_VALUES
  69   register const void **jump_table JT_REG;
  70
  71   if (SCM_UNLIKELY (!jump_table_pointer))
  72     {
  73       int i;
  74       jump_table_pointer = malloc (SCM_VM_NUM_INSTRUCTIONS * sizeof (void*));
  75       for (i = 0; i < SCM_VM_NUM_INSTRUCTIONS; i++)
  76         jump_table_pointer[i] = &&vm_error_bad_instruction;
  77 #define VM_INSTRUCTION_TO_LABEL 1
  78 #define jump_table jump_table_pointer
  79 #include <libguile/vm-expand.h>
  80 #include <libguile/vm-i-system.i>
  81 #include <libguile/vm-i-scheme.i>
  82 #include <libguile/vm-i-loader.i>
  83 #undef jump_table
  84 #undef VM_INSTRUCTION_TO_LABEL
  85     }
  86
  87   /* Attempt to keep JUMP_TABLE_POINTER in a register.  This saves one
  88      load instruction at each instruction dispatch.  */
  89   jump_table = jump_table_pointer;
  90 #endif
  91
  92   if (SCM_I_SETJMP (registers))
  93     {
  94       /* Non-local return.  Cache the VM registers back from the vp, and
  95          go to the handler.
  96
  97          Note, at this point, we must assume that any variable local to
  98          vm_engine that can be assigned *has* been assigned. So we need to pull
  99          all our state back from the ip/fp/sp.
 100       */
 101       CACHE_REGISTER ();
 102       program = SCM_FRAME_PROGRAM (fp);
 103       CACHE_PROGRAM ();
 104       /* The stack contains the values returned to this continuation,
 105          along with a number-of-values marker -- like an MV return. */
 106       ABORT_CONTINUATION_HOOK ();
 107       NEXT;
 108     }
 109
 110   /* Initialization */
 111   {
 112     SCM prog = program;
 113
 114     /* Boot program */
 115     program = vm_make_boot_program (nargs);
 116
 117     /* Initial frame */
 118     CACHE_REGISTER ();
 119     PUSH (SCM_PACK (fp)); /* dynamic link */
 120     PUSH (SCM_PACK (0)); /* mvra */
 121     PUSH (SCM_PACK (ip)); /* ra */
 122     CACHE_PROGRAM ();
 123     PUSH (program);
 124     fp = sp + 1;
 125     ip = SCM_C_OBJCODE_BASE (bp);
 126     /* MV-call frame, function & arguments */
 127     PUSH (SCM_PACK (0)); /* dynamic link */
 128     PUSH (SCM_PACK (0)); /* mvra */
 129     PUSH (SCM_PACK (0)); /* ra */
 130     PUSH (prog);
 131     if (SCM_UNLIKELY (sp + nargs >= stack_limit))
 132       goto vm_error_too_many_args;
 133     while (nargs--)
 134       PUSH (*argv++);
 135   }
 136
 137   /* Let's go! */
 138   NEXT;
 139
 140 #ifndef HAVE_LABELS_AS_VALUES
 141  vm_start:
 142   switch ((*ip++) & SCM_VM_INSTRUCTION_MASK) {
 143 #endif
 144
 145 #include "vm-expand.h"
 146 #include "vm-i-system.c"
 147 #include "vm-i-scheme.c"
 148 #include "vm-i-loader.c"
 149
 150 #ifndef HAVE_LABELS_AS_VALUES
 151   default:
 152     goto vm_error_bad_instruction;
 153   }
 154 #endif
 155
 156
 157  vm_done:
 158   SYNC_ALL ();
 159   return finish_args;
 160
 161   /* Errors */
 162   {
 163     SCM err_msg;
 164
 165     /* FIXME: need to sync regs before allocating anything, in each case. */
 166
 167   vm_error_bad_instruction:
 168     err_msg  = scm_from_latin1_string ("VM: Bad instruction: ~s");
 169     finish_args = scm_list_1 (scm_from_uchar (ip[-1]));
 170     goto vm_error;
 171
 172   vm_error_unbound:
 173     /* FINISH_ARGS should be the name of the unbound variable.  */
 174     SYNC_ALL ();
 175     err_msg = scm_from_latin1_string ("Unbound variable: ~s");
 176     scm_error_scm (scm_misc_error_key, program, err_msg,
 177                    scm_list_1 (finish_args), SCM_BOOL_F);
 178     goto vm_error;
 179
 180   vm_error_unbound_fluid:
 181     SYNC_ALL ();
 182     err_msg = scm_from_latin1_string ("Unbound fluid: ~s");
 183     scm_error_scm (scm_misc_error_key, program, err_msg,
 184                    scm_list_1 (finish_args), SCM_BOOL_F);
 185     goto vm_error;
 186
 187   vm_error_not_a_variable:
 188     SYNC_ALL ();
 189     scm_error (scm_arg_type_key, func_name, "Not a variable: ~S",
 190                scm_list_1 (finish_args), scm_list_1 (finish_args));
 191     goto vm_error;
 192
 193   vm_error_apply_to_non_list:
 194     SYNC_ALL ();
 195     scm_error (scm_arg_type_key, "apply", "Apply to non-list: ~S",
 196                scm_list_1 (finish_args), scm_list_1 (finish_args));
 197     goto vm_error;
 198
 199   vm_error_kwargs_length_not_even:
 200     SYNC_ALL ();
 201     err_msg = scm_from_latin1_string ("Odd length of keyword argument list");
 202     scm_error_scm (sym_keyword_argument_error, program, err_msg,
 203                    SCM_EOL, SCM_BOOL_F);
 204
 205   vm_error_kwargs_invalid_keyword:
 206     /* FIXME say which one it was */
 207     SYNC_ALL ();
 208     err_msg = scm_from_latin1_string ("Invalid keyword");
 209     scm_error_scm (sym_keyword_argument_error, program, err_msg,
 210                    SCM_EOL, SCM_BOOL_F);
 211
 212   vm_error_kwargs_unrecognized_keyword:
 213     /* FIXME say which one it was */
 214     SYNC_ALL ();
 215     err_msg = scm_from_latin1_string ("Unrecognized keyword");
 216     scm_error_scm (sym_keyword_argument_error, program, err_msg,
 217                    SCM_EOL, SCM_BOOL_F);
 218
 219   vm_error_too_many_args:
 220     err_msg  = scm_from_latin1_string ("VM: Too many arguments");
 221     finish_args = scm_list_1 (scm_from_int (nargs));
 222     goto vm_error;
 223
 224   vm_error_wrong_num_args:
 225     /* nargs and program are valid */
 226     SYNC_ALL ();
 227     scm_wrong_num_args (program);
 228     /* shouldn't get here */
 229     goto vm_error;
 230
 231   vm_error_wrong_type_apply:
 232     SYNC_ALL ();
 233     scm_error (scm_arg_type_key, NULL, "Wrong type to apply: ~S",
 234                scm_list_1 (program), scm_list_1 (program));
 235     goto vm_error;
 236
 237   vm_error_stack_overflow:
 238     err_msg  = scm_from_latin1_string ("VM: Stack overflow");
 239     finish_args = SCM_EOL;
 240     if (stack_limit < vp->stack_base + vp->stack_size)
 241       /* There are VM_STACK_RESERVE_SIZE bytes left.  Make them available so
 242          that `throw' below can run on this VM.  */
 243       vp->stack_limit = vp->stack_base + vp->stack_size;
 244     goto vm_error;
 245
 246   vm_error_stack_underflow:
 247     err_msg  = scm_from_latin1_string ("VM: Stack underflow");
 248     finish_args = SCM_EOL;
 249     goto vm_error;
 250
 251   vm_error_improper_list:
 252     err_msg  = scm_from_latin1_string ("Expected a proper list, but got object with tail ~s");
 253     goto vm_error;
 254
 255   vm_error_not_a_pair:
 256     SYNC_ALL ();
 257     scm_wrong_type_arg_msg (func_name, 1, finish_args, "pair");
 258     /* shouldn't get here */
 259     goto vm_error;
 260
 261   vm_error_not_a_bytevector:
 262     SYNC_ALL ();
 263     scm_wrong_type_arg_msg (func_name, 1, finish_args, "bytevector");
 264     /* shouldn't get here */
 265     goto vm_error;
 266
 267   vm_error_not_a_struct:
 268     SYNC_ALL ();
 269     scm_wrong_type_arg_msg (func_name, 1, finish_args, "struct");
 270     /* shouldn't get here */
 271     goto vm_error;
 272
 273   vm_error_no_values:
 274     err_msg  = scm_from_latin1_string ("Zero values returned to single-valued continuation");
 275     finish_args = SCM_EOL;
 276     goto vm_error;
 277
 278   vm_error_not_enough_values:
 279     err_msg  = scm_from_latin1_string ("Too few values returned to continuation");
 280     finish_args = SCM_EOL;
 281     goto vm_error;
 282
 283   vm_error_continuation_not_rewindable:
 284     err_msg  = scm_from_latin1_string ("Unrewindable partial continuation");
 285     finish_args = scm_cons (finish_args, SCM_EOL);
 286     goto vm_error;
 287
 288   vm_error_bad_wide_string_length:
 289     err_msg  = scm_from_latin1_string ("VM: Bad wide string length: ~S");
 290     goto vm_error;
 291
 292 #ifdef VM_CHECK_IP
 293   vm_error_invalid_address:
 294     err_msg  = scm_from_latin1_string ("VM: Invalid program address");
 295     finish_args = SCM_EOL;
 296     goto vm_error;
 297 #endif
 298
 299 #if VM_CHECK_OBJECT
 300   vm_error_object:
 301     err_msg = scm_from_latin1_string ("VM: Invalid object table access");
 302     finish_args = SCM_EOL;
 303     goto vm_error;
 304 #endif
 305
 306 #if VM_CHECK_FREE_VARIABLES
 307   vm_error_free_variable:
 308     err_msg = scm_from_latin1_string ("VM: Invalid free variable access");
 309     finish_args = SCM_EOL;
 310     goto vm_error;
 311 #endif
 312
 313   vm_error:
 314     SYNC_ALL ();
 315
 316     scm_ithrow (sym_vm_error, scm_list_3 (sym_vm_run, err_msg, finish_args),
 317                 1);
 318   }
 319
 320   abort (); /* never reached */
 321 }
 322
 323 #undef VM_USE_HOOKS
 324 #undef VM_CHECK_OBJECT
 325 #undef VM_CHECK_FREE_VARIABLE
 326 #undef VM_CHECK_UNDERFLOW
 327
 328 /*
 329   Local Variables:
 330   c-file-style: "gnu"
 331   End:
 332 */