libguile/vm-engine.h

   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_engine.c */
  20
  21 \f
  22 /*
  23  * Registers
  24  */
  25
  26 /* Register optimization. [ stolen from librep/src/lispmach.h,v 1.3 ]
  27
  28    Some compilers underestimate the use of the local variables representing
  29    the abstract machine registers, and don't put them in hardware registers,
  30    which slows down the interpreter considerably.
  31    For GCC, I have hand-assigned hardware registers for several architectures.
  32 */
  33
  34 #ifdef __GNUC__
  35 #ifdef __mips__
  36 #define IP_REG asm("$16")
  37 #define SP_REG asm("$17")
  38 #define FP_REG asm("$18")
  39 #endif
  40 #ifdef __sparc__
  41 #define IP_REG asm("%l0")
  42 #define SP_REG asm("%l1")
  43 #define FP_REG asm("%l2")
  44 #endif
  45 #ifdef __alpha__
  46 #ifdef __CRAY__
  47 #define IP_REG asm("r9")
  48 #define SP_REG asm("r10")
  49 #define FP_REG asm("r11")
  50 #else
  51 #define IP_REG asm("$9")
  52 #define SP_REG asm("$10")
  53 #define FP_REG asm("$11")
  54 #endif
  55 #endif
  56 #ifdef __i386__
  57 /* too few registers! because of register allocation errors with various gcs,
  58    just punt on explicit assignments on i386, hoping that the "register"
  59    declaration will be sufficient. */
  60 #elif defined __x86_64__
  61 /* GCC 4.6 chooses %rbp for IP_REG and %rbx for SP_REG, which works
  62    well.  Tell it to keep the jump table in a r12, which is
  63    callee-saved.  */
  64 #define JT_REG asm ("r12")
  65 #endif
  66 #if defined(PPC) || defined(_POWER) || defined(_IBMR2)
  67 #define IP_REG asm("26")
  68 #define SP_REG asm("27")
  69 #define FP_REG asm("28")
  70 #endif
  71 #ifdef __hppa__
  72 #define IP_REG asm("%r18")
  73 #define SP_REG asm("%r17")
  74 #define FP_REG asm("%r16")
  75 #endif
  76 #ifdef __mc68000__
  77 #define IP_REG asm("a5")
  78 #define SP_REG asm("a4")
  79 #define FP_REG
  80 #endif
  81 #ifdef __arm__
  82 #define IP_REG asm("r9")
  83 #define SP_REG asm("r8")
  84 #define FP_REG asm("r7")
  85 #endif
  86 #endif
  87
  88 #ifndef IP_REG
  89 #define IP_REG
  90 #endif
  91 #ifndef SP_REG
  92 #define SP_REG
  93 #endif
  94 #ifndef FP_REG
  95 #define FP_REG
  96 #endif
  97 #ifndef JT_REG
  98 #define JT_REG
  99 #endif
 100
 101 \f
 102 /*
 103  * Cache/Sync
 104  */
 105
 106 #ifdef VM_ENABLE_ASSERTIONS
 107 # define ASSERT(condition) if (SCM_UNLIKELY (!(condition))) abort()
 108 #else
 109 # define ASSERT(condition)
 110 #endif
 111
 112
 113 /* Cache the VM's instruction, stack, and frame pointer in local variables.  */
 114 #define CACHE_REGISTER()                        \
 115 {                                               \
 116   ip = vp->ip;                                  \
 117   sp = vp->sp;                                  \
 118   fp = vp->fp;                                  \
 119 }
 120
 121 /* Update the registers in VP, a pointer to the current VM.  This must be done
 122    at least before any GC invocation so that `vp->sp' is up-to-date and the
 123    whole stack gets marked.  */
 124 #define SYNC_REGISTER()                         \
 125 {                                               \
 126   vp->ip = ip;                                  \
 127   vp->sp = sp;                                  \
 128   vp->fp = fp;                                  \
 129 }
 130
 131 /* FIXME */
 132 #define ASSERT_VARIABLE(x)                                              \
 133   do { if (!SCM_VARIABLEP (x)) { SYNC_REGISTER (); abort(); }           \
 134   } while (0)
 135 #define ASSERT_BOUND_VARIABLE(x)                                        \
 136   do { ASSERT_VARIABLE (x);                                             \
 137     if (scm_is_eq (SCM_VARIABLE_REF (x), SCM_UNDEFINED))                \
 138       { SYNC_REGISTER (); abort(); }                                    \
 139   } while (0)
 140
 141 #ifdef VM_ENABLE_PARANOID_ASSERTIONS
 142 #define CHECK_IP() \
 143   do { if (ip < bp->base || ip - bp->base > bp->len) abort (); } while (0)
 144 #define ASSERT_ALIGNED_PROCEDURE() \
 145   do { if ((scm_t_bits)bp % 8) abort (); } while (0)
 146 #define ASSERT_BOUND(x) \
 147   do { if (scm_is_eq ((x), SCM_UNDEFINED)) { SYNC_REGISTER (); abort(); } \
 148   } while (0)
 149 #else
 150 #define CHECK_IP()
 151 #define ASSERT_ALIGNED_PROCEDURE()
 152 #define ASSERT_BOUND(x)
 153 #endif
 154
 155 #define DEAD(v) v = SCM_UNDEFINED
 156
 157 #if VM_CHECK_OBJECT
 158 #define SET_OBJECT_COUNT(n) object_count = n
 159 #else
 160 #define SET_OBJECT_COUNT(n) /* nop */
 161 #endif
 162
 163 /* Cache the object table and free variables.  */
 164 #define CACHE_PROGRAM()                                                 \
 165 {                                                                       \
 166   if (bp != SCM_PROGRAM_DATA (program)) {                               \
 167     bp = SCM_PROGRAM_DATA (program);                                    \
 168     ASSERT_ALIGNED_PROCEDURE ();                                        \
 169     if (SCM_I_IS_VECTOR (SCM_PROGRAM_OBJTABLE (program))) {             \
 170       objects = SCM_I_VECTOR_WELTS (SCM_PROGRAM_OBJTABLE (program));    \
 171       SET_OBJECT_COUNT (SCM_I_VECTOR_LENGTH (SCM_PROGRAM_OBJTABLE (program))); \
 172     } else {                                                            \
 173       objects = NULL;                                                   \
 174       SET_OBJECT_COUNT (0);                                             \
 175     }                                                                   \
 176   }                                                                     \
 177 }
 178
 179 #define SYNC_BEFORE_GC()                        \
 180 {                                               \
 181   SYNC_REGISTER ();                             \
 182 }
 183
 184 #define SYNC_ALL()                              \
 185 {                                               \
 186   SYNC_REGISTER ();                             \
 187 }
 188
 189 \f
 190 /*
 191  * Error check
 192  */
 193
 194 /* Accesses to a program's object table.  */
 195 #if VM_CHECK_OBJECT
 196 #define CHECK_OBJECT(_num) \
 197   do { if (SCM_UNLIKELY ((_num) >= object_count)) goto vm_error_object; } while (0)
 198 #else
 199 #define CHECK_OBJECT(_num)
 200 #endif
 201
 202 #if VM_CHECK_FREE_VARIABLES
 203 #define CHECK_FREE_VARIABLE(_num)                                       \
 204   do {                                                                  \
 205     if (SCM_UNLIKELY ((_num) >= SCM_PROGRAM_NUM_FREE_VARIABLES (program))) \
 206       goto vm_error_free_variable;                                      \
 207   } while (0)
 208 #else
 209 #define CHECK_FREE_VARIABLE(_num)
 210 #endif
 211
 212 \f
 213 /*
 214  * Hooks
 215  */
 216
 217 #undef RUN_HOOK
 218 #undef RUN_HOOK1
 219 #if VM_USE_HOOKS
 220 #define RUN_HOOK(h)                                     \
 221   {                                                     \
 222     if (SCM_UNLIKELY (vp->trace_level > 0))             \
 223       {                                                 \
 224         SYNC_REGISTER ();                               \
 225         vm_dispatch_hook (vm, h);                       \
 226       }                                                 \
 227   }
 228 #define RUN_HOOK1(h, x)                                 \
 229   {                                                     \
 230     if (SCM_UNLIKELY (vp->trace_level > 0))             \
 231       {                                                 \
 232         PUSH (x);                                       \
 233         SYNC_REGISTER ();                               \
 234         vm_dispatch_hook (vm, h);                       \
 235         DROP();                                         \
 236       }                                                 \
 237   }
 238 #else
 239 #define RUN_HOOK(h)
 240 #define RUN_HOOK1(h, x)
 241 #endif
 242
 243 #define APPLY_HOOK()                            \
 244   RUN_HOOK (SCM_VM_APPLY_HOOK)
 245 #define PUSH_CONTINUATION_HOOK()                \
 246   RUN_HOOK (SCM_VM_PUSH_CONTINUATION_HOOK)
 247 #define POP_CONTINUATION_HOOK(n)                \
 248   RUN_HOOK1 (SCM_VM_POP_CONTINUATION_HOOK, SCM_I_MAKINUM (n))
 249 #define NEXT_HOOK()                             \
 250   RUN_HOOK (SCM_VM_NEXT_HOOK)
 251 #define ABORT_CONTINUATION_HOOK()               \
 252   RUN_HOOK (SCM_VM_ABORT_CONTINUATION_HOOK)
 253 #define RESTORE_CONTINUATION_HOOK()            \
 254   RUN_HOOK (SCM_VM_RESTORE_CONTINUATION_HOOK)
 255
 256 #define VM_HANDLE_INTERRUPTS                     \
 257   SCM_ASYNC_TICK_WITH_CODE (current_thread, SYNC_REGISTER ())
 258
 259 \f
 260 /*
 261  * Stack operation
 262  */
 263
 264 #ifdef VM_ENABLE_STACK_NULLING
 265 # define CHECK_STACK_LEAKN(_n) ASSERT (!sp[_n]);
 266 # define CHECK_STACK_LEAK() CHECK_STACK_LEAKN(1)
 267 # define NULLSTACK(_n) { int __x = _n; CHECK_STACK_LEAKN (_n+1); while (__x > 0) sp[__x--] = NULL; }
 268 /* If you have a nonlocal exit in a pre-wind proc while invoking a continuation
 269    inside a dynwind (phew!), the stack is fully rewound but vm_reset_stack for
 270    that continuation doesn't have a chance to run. It's not important on a
 271    semantic level, but it does mess up our stack nulling -- so this macro is to
 272    fix that. */
 273 # define NULLSTACK_FOR_NONLOCAL_EXIT() if (vp->sp > sp) NULLSTACK (vp->sp - sp);
 274 #else
 275 # define CHECK_STACK_LEAKN(_n)
 276 # define CHECK_STACK_LEAK()
 277 # define NULLSTACK(_n)
 278 # define NULLSTACK_FOR_NONLOCAL_EXIT()
 279 #endif
 280
 281 #define CHECK_OVERFLOW()                        \
 282   if (SCM_UNLIKELY (sp >= stack_limit))         \
 283     goto vm_error_stack_overflow
 284
 285
 286 #ifdef VM_CHECK_UNDERFLOW
 287 #define CHECK_UNDERFLOW()                       \
 288   if (SCM_UNLIKELY (sp <= SCM_FRAME_UPPER_ADDRESS (fp)))        \
 289     goto vm_error_stack_underflow
 290 #define PRE_CHECK_UNDERFLOW(N)                  \
 291   if (SCM_UNLIKELY (sp - N <= SCM_FRAME_UPPER_ADDRESS (fp)))    \
 292     goto vm_error_stack_underflow
 293 #else
 294 #define CHECK_UNDERFLOW() /* nop */
 295 #define PRE_CHECK_UNDERFLOW(N) /* nop */
 296 #endif
 297
 298
 299 #define PUSH(x) do { sp++; CHECK_OVERFLOW (); *sp = x; } while (0)
 300 #define DROP()  do { sp--; CHECK_UNDERFLOW (); NULLSTACK (1); } while (0)
 301 #define DROPN(_n) do { sp -= (_n); CHECK_UNDERFLOW (); NULLSTACK (_n); } while (0)
 302 #define POP(x)  do { PRE_CHECK_UNDERFLOW (1); x = *sp--; NULLSTACK (1); } while (0)
 303 #define POP2(x,y) do { PRE_CHECK_UNDERFLOW (2); x = *sp--; y = *sp--; NULLSTACK (2); } while (0)
 304 #define POP3(x,y,z) do { PRE_CHECK_UNDERFLOW (3); x = *sp--; y = *sp--; z = *sp--; NULLSTACK (3); } while (0)
 305
 306 /* A fast CONS.  This has to be fast since its used, for instance, by
 307    POP_LIST when fetching a function's argument list.  Note: `scm_cell' is an
 308    inlined function in Guile 1.7.  Unfortunately, it calls
 309    `scm_gc_for_newcell ()' which is _not_ inlined and allocated cells on the
 310    heap.  XXX  */
 311 #define CONS(x,y,z)                                     \
 312 {                                                       \
 313   SYNC_BEFORE_GC ();                                    \
 314   x = scm_cell (SCM_UNPACK (y), SCM_UNPACK (z));        \
 315 }
 316
 317 /* Pop the N objects on top of the stack and push a list that contains
 318    them.  */
 319 #define POP_LIST(n)                             \
 320 do                                              \
 321 {                                               \
 322   int i;                                        \
 323   SCM l = SCM_EOL, x;                           \
 324   for (i = n; i; i--)                           \
 325     {                                           \
 326       POP (x);                                  \
 327       CONS (l, x, l);                           \
 328     }                                           \
 329   PUSH (l);                                     \
 330   DEAD (l);                                     \
 331 } while (0)
 332
 333 /* The opposite: push all of the elements in L onto the list. */
 334 #define PUSH_LIST(l, NILP)                      \
 335 do                                              \
 336 {                                               \
 337   for (; scm_is_pair (l); l = SCM_CDR (l))      \
 338     PUSH (SCM_CAR (l));                         \
 339   if (SCM_UNLIKELY (!NILP (l))) {               \
 340     finish_args = scm_list_1 (l);               \
 341     goto vm_error_improper_list;                \
 342   }                                             \
 343 } while (0)
 344
 345 \f
 346 #define POP_LIST_MARK()                         \
 347 do {                                            \
 348   SCM o;                                        \
 349   SCM l = SCM_EOL;                              \
 350   POP (o);                                      \
 351   while (!SCM_UNBNDP (o))                       \
 352     {                                           \
 353       CONS (l, o, l);                           \
 354       POP (o);                                  \
 355     }                                           \
 356   DEAD (o);                                     \
 357   PUSH (l);                                     \
 358   DEAD (l);                                     \
 359 } while (0)
 360
 361 #define POP_CONS_MARK()                         \
 362 do {                                            \
 363   SCM o, l;                                     \
 364   POP (l);                                      \
 365   POP (o);                                      \
 366   while (!SCM_UNBNDP (o))                       \
 367     {                                           \
 368       CONS (l, o, l);                           \
 369       POP (o);                                  \
 370     }                                           \
 371   DEAD (o);                                     \
 372   PUSH (l);                                     \
 373   DEAD (l);                                     \
 374 } while (0)
 375
 376 \f
 377 /*
 378  * Instruction operation
 379  */
 380
 381 #define FETCH()         (*ip++)
 382 #define FETCH_LENGTH(len) do { len=*ip++; len<<=8; len+=*ip++; len<<=8; len+=*ip++; } while (0)
 383
 384 #undef NEXT_JUMP
 385 #ifdef HAVE_LABELS_AS_VALUES
 386 #define NEXT_JUMP()             goto *jump_table[FETCH () & SCM_VM_INSTRUCTION_MASK]
 387 #else
 388 #define NEXT_JUMP()             goto vm_start
 389 #endif
 390
 391 #define NEXT                                    \
 392 {                                               \
 393   NEXT_HOOK ();                                 \
 394   CHECK_STACK_LEAK ();                          \
 395   NEXT_JUMP ();                                 \
 396 }
 397
 398 \f
 399 /* See frames.h for the layout of stack frames */
 400 /* When this is called, bp points to the new program data,
 401    and the arguments are already on the stack */
 402 #define DROP_FRAME()                            \
 403   {                                             \
 404     sp -= 3;                                    \
 405     NULLSTACK (3);                              \
 406     CHECK_UNDERFLOW ();                         \
 407   }
 408
 409
 410 /*
 411   Local Variables:
 412   c-file-style: "gnu"
 413   End:
 414 */