src/inter_run.c

   1 /*
   2 Copyright (C) 2001-2003, The Perl Foundation.
   3 $Id$
   4
   5 =head1 NAME
   6
   7 src/inter_run.c - Parrot Interpreter - Run Ops and Methods
   8
   9 =head1 DESCRIPTION
  10
  11 Various functions that call the run loop.
  12
  13 =head2 Functions
  14
  15 =over 4
  16
  17 =cut
  18
  19 */
  20
  21
  22 #include <assert.h>
  23 #include "parrot/parrot.h"
  24
  25 /*
  26
  27 =item C<void
  28 runops(Interp *interpreter, size_t offset)>
  29
  30 Run parrot ops. Set exception handler and/or resume after exception.
  31
  32 =cut
  33
  34 */
  35
  36 #define STACKED_EXCEPTIONS 1
  37 /* #define RUNLOOP_TRACE 1 */
  38
  39 static int
  40 runloop_id_counter = 0;          /* for synthesizing runloop ids. */
  41
  42 void
  43 runops(Interp *interpreter, size_t offs)
  44 {
  45     volatile size_t offset = offs;
  46     int old_runloop_id = interpreter->current_runloop_id;
  47     int our_runloop_level = ++interpreter->current_runloop_level;
  48     int our_runloop_id = ++runloop_id_counter;
  49
  50     /* It is OK if the runloop ID overflows; we only ever test it for equality,
  51        so the chance of collision is slight. */
  52     interpreter->current_runloop_id = our_runloop_id;
  53 #ifdef RUNLOOP_TRACE
  54     fprintf(stderr, "[entering loop %d, level %d]\n",
  55             interpreter->current_runloop_id, our_runloop_level);
  56 #endif
  57     /*
  58      * STACKED_EXCEPTIONS are necessary to catch exceptions in reentered
  59      * run loops, e.g. if a delegate methods throws an exception
  60      */
  61 #if ! STACKED_EXCEPTIONS
  62     if (!interpreter->exceptions)
  63 #endif
  64     {
  65         new_internal_exception(interpreter);
  66         if (setjmp(interpreter->exceptions->destination)) {
  67             /* an exception was thrown */
  68             interpreter->current_runloop_level = our_runloop_level;
  69             interpreter->current_runloop_id = our_runloop_id;
  70 #ifdef RUNLOOP_TRACE
  71             fprintf(stderr, "[exception; back to loop %d, level %d]\n",
  72                     our_runloop_id, our_runloop_level);
  73 #endif
  74             offset = handle_exception(interpreter);
  75             /* update profile for exception execution time */
  76             if (interpreter->profile &&
  77                     Interp_flags_TEST(interpreter, PARROT_PROFILE_FLAG)) {
  78                 RunProfile *profile = interpreter->profile;
  79                 if (profile->cur_op == PARROT_PROF_EXCEPTION) {
  80                     profile->data[PARROT_PROF_EXCEPTION].time +=
  81                         Parrot_floatval_time() - profile->starttime;
  82                 }
  83             }
  84         }
  85     }
  86
  87     runops_int(interpreter, offset);
  88
  89     /*
  90      * pop off exception and put it onto the free list
  91      * s. above
  92      */
  93     if (STACKED_EXCEPTIONS) {
  94         free_internal_exception(interpreter);
  95     }
  96 #ifdef RUNLOOP_TRACE
  97     fprintf(stderr, "[exiting loop %d, level %d]\n",
  98             our_runloop_id, our_runloop_level);
  99 #endif
 100     interpreter->current_runloop_level = --our_runloop_level;
 101     interpreter->current_runloop_id = old_runloop_id;
 102     /*
 103      * not yet - this needs classifying of exceptions and handlers
 104      * so that only an exit handler does catch this exception
 105      */
 106 #if 0
 107     do_exception(interpreter, EXCEPT_exit, 0);
 108 #endif
 109 }
 110
 111 /*
 112
 113 =item C<parrot_context_t *
 114 Parrot_runops_fromc(Parrot_Interp interpreter, PMC *sub)>
 115
 116 Runs the Parrot ops, called from C code. The function arguments are
 117 already setup according to Parrot calling conventions, the C<sub> argument
 118 is an invocable C<Sub> PMC.
 119
 120 =cut
 121
 122 */
 123
 124 parrot_context_t *
 125 Parrot_runops_fromc(Parrot_Interp interpreter, PMC *sub)
 126 {
 127     PMC *ret_c;
 128     opcode_t offset, *dest;
 129     parrot_context_t *ctx;
 130
 131     /* we need one return continuation with a NULL offset */
 132     interpreter->current_cont = ret_c =
 133         new_ret_continuation_pmc(interpreter, NULL);
 134 #if GC_VERBOSE
 135     PObj_report_SET(ret_c);     /* s. also dod.c */
 136 #endif
 137     /* invoke the sub, which places the context of the sub in the
 138      * interpreter, and switches code segments if needed
 139      * Passing a dummy true destination copies registers
 140      */
 141     dest = VTABLE_invoke(interpreter, sub, (void*) 1);
 142     if (!dest)
 143         internal_exception(1, "Subroutine returned a NULL address");
 144     ctx = CONTEXT(interpreter->ctx);
 145     offset = dest - interpreter->code->base.data;
 146     runops(interpreter, offset);
 147     return ctx;
 148 }
 149
 150
 151 static parrot_context_t *
 152 runops_args(Parrot_Interp interpreter, PMC *sub, PMC *obj,
 153         STRING *meth, const char* sig, va_list ap)
 154 {
 155     opcode_t offset, *dest;
 156     parrot_context_t *ctx;
 157     parrot_context_t *old_ctx;
 158     /*
 159      * FIXME argument count limited - check strlen of sig
 160      */
 161     char new_sig[10];
 162     const char *sig_p;
 163
 164     old_ctx = CONTEXT(interpreter->ctx);
 165     interpreter->current_cont  = new_ret_continuation_pmc(interpreter, NULL);
 166     interpreter->current_object = obj;
 167     dest = VTABLE_invoke(interpreter, sub, NULL);
 168     if (!dest)
 169         internal_exception(1, "Subroutine returned a NULL address");
 170     if (PMC_IS_NULL(obj)) {
 171         /* skip over the return type */
 172         sig_p = sig + 1;
 173     }
 174     else if (sig[1] == 'O') {
 175         /* skip over the return type */
 176         sig_p = sig + 1;
 177     }
 178     else  {
 179         size_t len = strlen(sig);
 180         if (len > 8)
 181             internal_exception(1, "too many arguments in runops_args");
 182         new_sig[0] = 'O';
 183         strcpy(new_sig + 1, sig + 1);
 184         sig_p = new_sig;
 185     }
 186     if (*sig_p) {
 187         dest = parrot_pass_args_fromc(interpreter, sig_p, dest,
 188                 old_ctx, ap);
 189     }
 190
 191     ctx = CONTEXT(interpreter->ctx);
 192     offset = dest - interpreter->code->base.data;
 193     runops(interpreter, offset);
 194     return ctx;
 195 }
 196
 197
 198 /*
 199
 200 =item C<void *
 201 Parrot_run_meth_fromc(Parrot_Interp, PMC *sub, PMC *obj, STRING *meth)>
 202
 203 Run a method sub from C. The function arguments are
 204 already setup according to Parrot calling conventions, the C<sub> argument
 205 is an invocable C<Sub> PMC.
 206
 207 If registers a PMC return values, it is returned.
 208
 209 =cut
 210
 211 */
 212
 213
 214
 215 /*
 216
 217 =item C<void *
 218 Parrot_runops_fromc_args(Parrot_Interp interpreter, PMC *sub,
 219         const char *sig, ...)>
 220
 221 =item C<INTVAL
 222 Parrot_runops_fromc_args_reti(Parrot_Interp interpreter, PMC *sub,
 223         const char *sig, ...)>
 224
 225 =item C<FLOATVAL
 226 Parrot_runops_fromc_args_retf(Parrot_Interp interpreter, PMC *sub,
 227         const char *sig, ...)>
 228
 229 =item C<void *
 230 Parrot_runops_fromc_arglist(Parrot_Interp interpreter, PMC *sub,
 231         const char *sig, va_list args)>
 232
 233 =item C<void *
 234 Parrot_run_meth_fromc_args(Parrot_Interp interpreter, PMC *sub,
 235         PMC* obj, STRING* meth, const char *sig, ...)>
 236
 237 =item C<INTVAL
 238 Parrot_run_meth_fromc_args_reti(Parrot_Interp interpreter, PMC *sub,
 239         PMC* obj, STRING* meth, const char *sig, ...)>
 240
 241 =item C<FLOATVAL
 242 Parrot_run_meth_fromc_args_retf(Parrot_Interp interpreter, PMC *sub,
 243         PMC* obj, STRING* meth, const char *sig, ...)>
 244
 245 Run parrot ops, called from C code, function arguments are passed as
 246 C<va_args> according to the signature. The C<sub> argument is an
 247 invocable C<Sub> PMC.
 248
 249 Signatures are similar to NCI:
 250
 251     v ... void return
 252     I ... INTVAL (not Interpreter)
 253     N ... NUMVAL
 254     S ... STRING*
 255     P ... PMC*
 256
 257 =item C<void *
 258 Parrot_runops_fromc_args_event(Parrot_Interp interpreter, PMC *sub,
 259         const char *sig, ...)>
 260
 261 Run code from within event handlers. This variant deals with some reentrency
 262 issues. It also should do sanity checks, if e.g. the handler subroutine
 263 didn't return properly.
 264
 265 =cut
 266
 267 */
 268
 269 void *
 270 Parrot_run_meth_fromc(Parrot_Interp interpreter,
 271         PMC *sub, PMC *obj, STRING *meth)
 272 {
 273     parrot_context_t *ctx;
 274     opcode_t offset, *dest;
 275
 276     interpreter->current_cont = new_ret_continuation_pmc(interpreter, NULL);
 277     interpreter->current_object = obj;
 278     dest = VTABLE_invoke(interpreter, sub, (void*)1);
 279     if (!dest)
 280         internal_exception(1, "Subroutine returned a NULL address");
 281     ctx = CONTEXT(interpreter->ctx);
 282     offset = dest - interpreter->code->base.data;
 283     runops(interpreter, offset);
 284     return set_retval(interpreter, 0, ctx);
 285 }
 286
 287 void *
 288 Parrot_runops_fromc_args(Parrot_Interp interpreter, PMC *sub,
 289         const char *sig, ...)
 290 {
 291     va_list args;
 292     parrot_context_t *ctx;
 293
 294     va_start(args, sig);
 295     ctx = runops_args(interpreter, sub, PMCNULL, NULL, sig, args);
 296     va_end(args);
 297     return set_retval(interpreter, *sig, ctx);
 298 }
 299
 300 void *
 301 Parrot_runops_fromc_args_event(Parrot_Interp interpreter, PMC *sub,
 302         const char *sig, ...)
 303 {
 304     va_list args;
 305     parrot_context_t *ctx;
 306     opcode_t *cargs, *params, *returns;
 307     PMC *cont;
 308     void *retval;
 309     /*
 310      * running code from event handlers isn't fully reentrant due to
 311      * these interpreter variables - mainly related to calls
 312      */
 313     cargs   = interpreter->current_args;
 314     params  = interpreter->current_params;
 315     returns = interpreter->current_returns;
 316     cont    = interpreter->current_cont;
 317     /* what else ? */
 318
 319     va_start(args, sig);
 320     ctx = runops_args(interpreter, sub, PMCNULL, NULL, sig, args);
 321     va_end(args);
 322     retval = set_retval(interpreter, *sig, ctx);
 323
 324     interpreter->current_args     = cargs;
 325     interpreter->current_params   = params;
 326     interpreter->current_returns  = returns;
 327     interpreter->current_cont     = cont;
 328     return retval;
 329 }
 330
 331 INTVAL
 332 Parrot_runops_fromc_args_reti(Parrot_Interp interpreter, PMC *sub,
 333         const char *sig, ...)
 334 {
 335     va_list args;
 336     parrot_context_t *ctx;
 337
 338     va_start(args, sig);
 339     ctx = runops_args(interpreter, sub, PMCNULL, NULL, sig, args);
 340     va_end(args);
 341     return set_retval_i(interpreter, *sig, ctx);
 342 }
 343
 344 FLOATVAL
 345 Parrot_runops_fromc_args_retf(Parrot_Interp interpreter, PMC *sub,
 346         const char *sig, ...)
 347 {
 348     va_list args;
 349     parrot_context_t *ctx;
 350
 351     va_start(args, sig);
 352     ctx = runops_args(interpreter, sub, PMCNULL, NULL, sig, args);
 353     va_end(args);
 354     return set_retval_f(interpreter, *sig, ctx);
 355 }
 356
 357 void*
 358 Parrot_run_meth_fromc_args(Parrot_Interp interpreter,
 359         PMC *sub, PMC *obj, STRING *meth, const char *sig, ...)
 360 {
 361     va_list args;
 362     parrot_context_t *ctx;
 363
 364     va_start(args, sig);
 365     ctx = runops_args(interpreter, sub, obj, meth, sig, args);
 366     va_end(args);
 367     return set_retval(interpreter, *sig, ctx);
 368 }
 369
 370 INTVAL
 371 Parrot_run_meth_fromc_args_reti(Parrot_Interp interpreter,
 372         PMC *sub, PMC *obj, STRING *meth, const char *sig, ...)
 373 {
 374     va_list args;
 375     parrot_context_t *ctx;
 376
 377     va_start(args, sig);
 378     ctx = runops_args(interpreter, sub, obj, meth, sig, args);
 379     va_end(args);
 380     return set_retval_i(interpreter, *sig, ctx);
 381 }
 382
 383 FLOATVAL
 384 Parrot_run_meth_fromc_args_retf(Parrot_Interp interpreter,
 385         PMC *sub, PMC *obj, STRING *meth, const char *sig, ...)
 386 {
 387     va_list args;
 388     parrot_context_t *ctx;
 389
 390     va_start(args, sig);
 391     ctx = runops_args(interpreter, sub, obj, meth, sig, args);
 392     va_end(args);
 393     return set_retval_f(interpreter, *sig, ctx);
 394 }
 395
 396 void *
 397 Parrot_runops_fromc_arglist(Parrot_Interp interpreter, PMC *sub,
 398         const char *sig, va_list args)
 399 {
 400     parrot_context_t *ctx;
 401
 402     ctx = runops_args(interpreter, sub, PMCNULL, NULL, sig, args);
 403     return set_retval(interpreter, *sig, ctx);
 404 }
 405
 406 INTVAL
 407 Parrot_runops_fromc_arglist_reti(Parrot_Interp interpreter, PMC *sub,
 408         const char *sig, va_list args)
 409 {
 410     parrot_context_t *ctx;
 411
 412     ctx = runops_args(interpreter, sub, PMCNULL, NULL, sig, args);
 413     return set_retval_i(interpreter, *sig, ctx);
 414 }
 415
 416 FLOATVAL
 417 Parrot_runops_fromc_arglist_retf(Parrot_Interp interpreter, PMC *sub,
 418         const char *sig, va_list args)
 419 {
 420     parrot_context_t *ctx;
 421
 422     ctx = runops_args(interpreter, sub, PMCNULL, NULL, sig, args);
 423     return set_retval_f(interpreter, *sig, ctx);
 424 }
 425
 426 void*
 427 Parrot_run_meth_fromc_arglist(Parrot_Interp interpreter,
 428         PMC *sub, PMC *obj, STRING *meth, const char *sig, va_list args)
 429 {
 430     parrot_context_t *ctx;
 431
 432     ctx = runops_args(interpreter, sub, obj, meth, sig, args);
 433     return set_retval(interpreter, *sig, ctx);
 434 }
 435
 436 INTVAL
 437 Parrot_run_meth_fromc_arglist_reti(Parrot_Interp interpreter,
 438         PMC *sub, PMC *obj, STRING *meth, const char *sig, va_list args)
 439 {
 440     parrot_context_t *ctx;
 441
 442     ctx = runops_args(interpreter, sub, obj, meth, sig, args);
 443     return set_retval_i(interpreter, *sig, ctx);
 444 }
 445
 446 FLOATVAL
 447 Parrot_run_meth_fromc_arglist_retf(Parrot_Interp interpreter,
 448         PMC *sub, PMC *obj, STRING *meth, const char *sig, va_list args)
 449 {
 450     parrot_context_t *ctx;
 451
 452     ctx = runops_args(interpreter, sub, obj, meth, sig, args);
 453     return set_retval_f(interpreter, *sig, ctx);
 454 }
 455
 456 /*
 457
 458 =back
 459
 460 =head1 SEE ALSO
 461
 462 F<include/parrot/interpreter.h>, F<src/interpreter.c>.
 463
 464 =cut
 465
 466 */
 467
 468 /*
 469  * Local variables:
 470  *   c-file-style: "parrot"
 471  * End:
 472  * vim: expandtab shiftwidth=4:
 473  */