src/inter_run.c

   1 /*
   2 Copyright (C) 2001-2008, 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 "parrot/parrot.h"
  23 #include "parrot/oplib/ops.h"
  24
  25 /* HEADERIZER HFILE: include/parrot/interpreter.h */
  26
  27 /* HEADERIZER BEGIN: static */
  28 /* Don't modify between HEADERIZER BEGIN / HEADERIZER END.  Your changes will be lost. */
  29
  30 PARROT_WARN_UNUSED_RESULT
  31 PARROT_CANNOT_RETURN_NULL
  32 static parrot_context_t * runops_args(PARROT_INTERP,
  33     ARGIN(PMC *sub),
  34     ARGIN_NULLOK(PMC *obj),
  35     SHIM(STRING *meth),
  36     ARGIN(const char *sig),
  37     va_list ap)
  38         __attribute__nonnull__(1)
  39         __attribute__nonnull__(2)
  40         __attribute__nonnull__(5);
  41
  42 /* Don't modify between HEADERIZER BEGIN / HEADERIZER END.  Your changes will be lost. */
  43 /* HEADERIZER END: static */
  44
  45 #define STACKED_EXCEPTIONS 1
  46 /* #define RUNLOOP_TRACE 1 */
  47
  48 static int
  49 runloop_id_counter = 0;          /* for synthesizing runloop ids. */
  50
  51 /*
  52
  53 =item C<void runops>
  54
  55 Run parrot ops. Set exception handler and/or resume after exception.
  56
  57 =cut
  58
  59 */
  60
  61 void
  62 runops(PARROT_INTERP, size_t offs)
  63 {
  64     volatile size_t offset = offs;
  65     const int old_runloop_id    = interp->current_runloop_id;
  66     const int our_runloop_level = ++interp->current_runloop_level;
  67     const int our_runloop_id    = ++runloop_id_counter;
  68
  69     /* It is OK if the runloop ID overflows; we only ever test it for equality,
  70        so the chance of collision is slight. */
  71     interp->current_runloop_id = our_runloop_id;
  72 #ifdef RUNLOOP_TRACE
  73     fprintf(stderr, "[entering loop %d, level %d]\n",
  74             interp->current_runloop_id, our_runloop_level);
  75 #endif
  76     /*
  77      * STACKED_EXCEPTIONS are necessary to catch exceptions in reentered
  78      * run loops, e.g. if a delegate methods throws an exception
  79      */
  80 #if ! STACKED_EXCEPTIONS
  81     if (!interp->current_runloop)
  82 #endif
  83     {
  84         new_runloop_jump_point(interp);
  85         if (setjmp(interp->current_runloop->resume)) {
  86             /* an exception was handled */
  87             if (STACKED_EXCEPTIONS) {
  88                 free_runloop_jump_point(interp);
  89             }
  90             interp->current_runloop_level = our_runloop_level - 1;
  91             interp->current_runloop_id = old_runloop_id;
  92
  93 #ifdef RUNLOOP_TRACE
  94             fprintf(stderr, "[handled exception; back to loop %d, level %d]\n",
  95                     interp->current_runloop_id, interp->current_runloop_level);
  96 #endif
  97             return;
  98         }
  99     }
 100
 101     runops_int(interp, offset);
 102
 103     /* Remove the current runloop marker (put it on the free list). */
 104     if (STACKED_EXCEPTIONS) {
 105         free_runloop_jump_point(interp);
 106     }
 107 #ifdef RUNLOOP_TRACE
 108     fprintf(stderr, "[exiting loop %d, level %d]\n",
 109             our_runloop_id, our_runloop_level);
 110 #endif
 111     interp->current_runloop_level = our_runloop_level - 1;
 112     interp->current_runloop_id = old_runloop_id;
 113 }
 114
 115 /*
 116
 117 =item C<parrot_context_t * Parrot_runops_fromc>
 118
 119 Runs the Parrot ops, called from C code. The function arguments are
 120 already setup according to Parrot calling conventions, the C<sub> argument
 121 is an invocable C<Sub> PMC.
 122
 123 =cut
 124
 125 */
 126
 127 PARROT_API
 128 PARROT_IGNORABLE_RESULT
 129 PARROT_CANNOT_RETURN_NULL
 130 parrot_context_t *
 131 Parrot_runops_fromc(PARROT_INTERP, ARGIN(PMC *sub))
 132 {
 133     opcode_t offset, *dest;
 134     parrot_context_t *ctx;
 135
 136     /* we need one return continuation with a NULL offset */
 137     PMC * const ret_c = new_ret_continuation_pmc(interp, NULL);
 138     interp->current_cont = ret_c;
 139 #if defined GC_VERBOSE && GC_VERBOSE
 140     PObj_report_SET(ret_c);     /* s. also dod.c */
 141 #endif
 142     /* invoke the sub, which places the context of the sub in the
 143      * interpreter, and switches code segments if needed
 144      * Passing a dummy true destination copies registers
 145      */
 146     dest = VTABLE_invoke(interp, sub, (void*) 1);
 147     if (!dest)
 148         Parrot_ex_throw_from_c_args(interp, NULL, 1,
 149             "Subroutine returned a NULL address");
 150
 151     ctx    = CONTEXT(interp);
 152     offset = dest - interp->code->base.data;
 153     runops(interp, offset);
 154     return ctx;
 155 }
 156
 157
 158 /*
 159
 160 =item C<static parrot_context_t * runops_args>
 161
 162 RT#48260: Not yet documented!!!
 163
 164 =cut
 165
 166 */
 167
 168 PARROT_WARN_UNUSED_RESULT
 169 PARROT_CANNOT_RETURN_NULL
 170 static parrot_context_t *
 171 runops_args(PARROT_INTERP, ARGIN(PMC *sub), ARGIN_NULLOK(PMC *obj),
 172         SHIM(STRING *meth), ARGIN(const char *sig), va_list ap)
 173 {
 174     opcode_t offset, *dest;
 175     parrot_context_t *ctx;
 176
 177     char new_sig[10];
 178     const char *sig_p;
 179     parrot_context_t * const old_ctx = CONTEXT(interp);
 180
 181     interp->current_cont  = new_ret_continuation_pmc(interp, NULL);
 182     interp->current_object = obj;
 183     dest = VTABLE_invoke(interp, sub, NULL);
 184     if (!dest)
 185         Parrot_ex_throw_from_c_args(interp, NULL, 1,
 186             "Subroutine returned a NULL address");
 187
 188     if (PMC_IS_NULL(obj)) {
 189         /* skip over the return type */
 190         sig_p = sig + 1;
 191     }
 192     else if (sig[1] == 'O') {
 193         /* skip over the return type */
 194         sig_p = sig + 1;
 195     }
 196     else  {
 197         const size_t len = strlen(sig);
 198         if (len > 8)
 199             Parrot_ex_throw_from_c_args(interp, NULL, 1,
 200                 "too many arguments in runops_args");
 201
 202         new_sig[0] = 'O';
 203         strcpy(new_sig + 1, sig + 1);
 204         sig_p = new_sig;
 205     }
 206
 207     if (*sig_p && (dest[0] == PARROT_OP_get_params_pc
 208                 || (sub->vtable->base_type == enum_class_ExceptionHandler
 209                     && PMC_cont(sub)->current_results))) {
 210         dest = parrot_pass_args_fromc(interp, sig_p, dest, old_ctx, ap);
 211     }
 212     /*
 213      * main is now started with runops_args_fromc too
 214      * PASM subs usually don't have get_params
 215      * XXX we could check, if we are running main
 216      else
 217         Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
 218             "no get_params in sub");
 219      */
 220
 221     ctx    = CONTEXT(interp);
 222     offset = dest - interp->code->base.data;
 223     runops(interp, offset);
 224     return ctx;
 225 }
 226
 227
 228 /*
 229
 230 =item C<void * Parrot_run_meth_fromc>
 231
 232 Run a method sub from C. The function arguments are
 233 already setup according to Parrot calling conventions, the C<sub> argument
 234 is an invocable C<Sub> PMC.
 235
 236 If registers a PMC return values, it is returned.
 237
 238 =cut
 239
 240 */
 241
 242 PARROT_API
 243 PARROT_IGNORABLE_RESULT
 244 PARROT_CAN_RETURN_NULL
 245 void *
 246 Parrot_run_meth_fromc(PARROT_INTERP, ARGIN(PMC *sub), ARGIN_NULLOK(PMC *obj), SHIM(STRING *meth))
 247 {
 248     parrot_context_t *ctx;
 249     opcode_t offset, *dest;
 250
 251     interp->current_cont   = new_ret_continuation_pmc(interp, NULL);
 252     interp->current_object = obj;
 253     dest = VTABLE_invoke(interp, sub, (void *)1);
 254
 255     if (!dest)
 256         Parrot_ex_throw_from_c_args(interp, NULL, 1,
 257             "Subroutine returned a NULL address");
 258
 259     ctx    = CONTEXT(interp);
 260     offset = dest - interp->code->base.data;
 261     runops(interp, offset);
 262     return set_retval(interp, 0, ctx);
 263 }
 264
 265 /*
 266
 267 =item C<PMC * Parrot_runops_fromc_args>
 268
 269 Run parrot ops, called from C code, function arguments are passed as
 270 C<va_args> according to the signature. The C<sub> argument is an
 271 invocable C<Sub> PMC.
 272
 273 Signatures are similar to NCI:
 274
 275     v ... void return
 276     I ... INTVAL (not Interpreter)
 277     N ... NUMVAL
 278     S ... STRING*
 279     P ... PMC*
 280
 281 =cut
 282
 283 */
 284
 285 PARROT_API
 286 PARROT_IGNORABLE_RESULT
 287 PARROT_CAN_RETURN_NULL
 288 PMC *
 289 Parrot_runops_fromc_args(PARROT_INTERP, ARGIN(PMC *sub), ARGIN(const char *sig), ...)
 290 {
 291     va_list args;
 292     parrot_context_t *ctx;
 293
 294     va_start(args, sig);
 295     ctx = runops_args(interp, sub, PMCNULL, NULL, sig, args);
 296     va_end(args);
 297     return (PMC *)set_retval(interp, *sig, ctx);
 298 }
 299
 300 /*
 301
 302 =item C<void * Parrot_runops_fromc_args_event>
 303
 304 Run code from within event handlers. This variant deals with some reentrency
 305 issues. It also should do sanity checks, if e.g. the handler subroutine
 306 didn't return properly.
 307
 308 =cut
 309
 310 */
 311
 312 PARROT_API
 313 PARROT_IGNORABLE_RESULT
 314 PARROT_CAN_RETURN_NULL
 315 void *
 316 Parrot_runops_fromc_args_event(PARROT_INTERP, ARGIN(PMC *sub),
 317         ARGIN(const char *sig), ...)
 318 {
 319     va_list args;
 320     parrot_context_t *ctx;
 321     void *retval;
 322     /*
 323      * running code from event handlers isn't fully reentrant due to
 324      * these interpreter variables - mainly related to calls
 325      */
 326     opcode_t * const cargs   = interp->current_args;
 327     opcode_t * const params  = interp->current_params;
 328     opcode_t * const returns = interp->current_returns;
 329     PMC *      const cont    = interp->current_cont;
 330     /* what else ? */
 331
 332     va_start(args, sig);
 333     ctx = runops_args(interp, sub, PMCNULL, NULL, sig, args);
 334     va_end(args);
 335     retval = set_retval(interp, *sig, ctx);
 336
 337     interp->current_args     = cargs;
 338     interp->current_params   = params;
 339     interp->current_returns  = returns;
 340     interp->current_cont     = cont;
 341     return retval;
 342 }
 343
 344 /*
 345
 346 =item C<INTVAL Parrot_runops_fromc_args_reti>
 347
 348 RT#48260: Not yet documented!!!
 349
 350 =cut
 351
 352 */
 353
 354 PARROT_API
 355 PARROT_IGNORABLE_RESULT
 356 INTVAL
 357 Parrot_runops_fromc_args_reti(PARROT_INTERP, ARGIN(PMC *sub),
 358         ARGIN(const char *sig), ...)
 359 {
 360     va_list args;
 361     parrot_context_t *ctx;
 362
 363     va_start(args, sig);
 364     ctx = runops_args(interp, sub, PMCNULL, NULL, sig, args);
 365     va_end(args);
 366     return set_retval_i(interp, *sig, ctx);
 367 }
 368
 369 /*
 370
 371 =item C<FLOATVAL Parrot_runops_fromc_args_retf>
 372
 373 RT#48260: Not yet documented!!!
 374
 375 =cut
 376
 377 */
 378
 379 PARROT_API
 380 PARROT_IGNORABLE_RESULT
 381 FLOATVAL
 382 Parrot_runops_fromc_args_retf(PARROT_INTERP, ARGIN(PMC *sub),
 383         ARGIN(const char *sig), ...)
 384 {
 385     va_list args;
 386     parrot_context_t *ctx;
 387
 388     va_start(args, sig);
 389     ctx = runops_args(interp, sub, PMCNULL, NULL, sig, args);
 390     va_end(args);
 391     return set_retval_f(interp, *sig, ctx);
 392 }
 393
 394 /*
 395
 396 =item C<void* Parrot_run_meth_fromc_args>
 397
 398 RT#48260: Not yet documented!!!
 399
 400 =cut
 401
 402 */
 403
 404 PARROT_API
 405 PARROT_IGNORABLE_RESULT
 406 PARROT_CAN_RETURN_NULL
 407 void*
 408 Parrot_run_meth_fromc_args(PARROT_INTERP, ARGIN(PMC *sub), ARGIN_NULLOK(PMC *obj),
 409         ARGIN(STRING *meth), ARGIN(const char *sig), ...)
 410 {
 411     va_list args;
 412     parrot_context_t *ctx;
 413
 414     va_start(args, sig);
 415     ctx = runops_args(interp, sub, obj, meth, sig, args);
 416     va_end(args);
 417     return set_retval(interp, *sig, ctx);
 418 }
 419
 420 /*
 421
 422 =item C<INTVAL Parrot_run_meth_fromc_args_reti>
 423
 424 RT#48260: Not yet documented!!!
 425
 426 =cut
 427
 428 */
 429
 430 PARROT_API
 431 PARROT_IGNORABLE_RESULT
 432 INTVAL
 433 Parrot_run_meth_fromc_args_reti(PARROT_INTERP, ARGIN(PMC *sub), ARGIN_NULLOK(PMC *obj),
 434         ARGIN(STRING *meth), ARGIN(const char *sig), ...)
 435 {
 436     va_list args;
 437     parrot_context_t *ctx;
 438
 439     va_start(args, sig);
 440     ctx = runops_args(interp, sub, obj, meth, sig, args);
 441     va_end(args);
 442     return set_retval_i(interp, *sig, ctx);
 443 }
 444
 445 /*
 446
 447 =item C<FLOATVAL Parrot_run_meth_fromc_args_retf>
 448
 449 RT#48260: Not yet documented!!!
 450
 451 =cut
 452
 453 */
 454
 455 PARROT_API
 456 PARROT_IGNORABLE_RESULT
 457 FLOATVAL
 458 Parrot_run_meth_fromc_args_retf(PARROT_INTERP, ARGIN(PMC *sub), ARGIN_NULLOK(PMC *obj),
 459         ARGIN(STRING *meth), ARGIN(const char *sig), ...)
 460 {
 461     va_list args;
 462     parrot_context_t *ctx;
 463
 464     va_start(args, sig);
 465     ctx = runops_args(interp, sub, obj, meth, sig, args);
 466     va_end(args);
 467     return set_retval_f(interp, *sig, ctx);
 468 }
 469
 470 /*
 471
 472 =item C<void * Parrot_runops_fromc_arglist>
 473
 474 RT#48260: Not yet documented!!!
 475
 476 =cut
 477
 478 */
 479
 480 PARROT_API
 481 PARROT_IGNORABLE_RESULT
 482 PARROT_CAN_RETURN_NULL
 483 void *
 484 Parrot_runops_fromc_arglist(PARROT_INTERP, ARGIN(PMC *sub),
 485         ARGIN(const char *sig), va_list args)
 486 {
 487     parrot_context_t * const ctx = runops_args(interp, sub, PMCNULL, NULL, sig, args);
 488
 489     return set_retval(interp, *sig, ctx);
 490 }
 491
 492 /*
 493
 494 =item C<INTVAL Parrot_runops_fromc_arglist_reti>
 495
 496 RT#48260: Not yet documented!!!
 497
 498 =cut
 499
 500 */
 501
 502 PARROT_API
 503 PARROT_IGNORABLE_RESULT
 504 INTVAL
 505 Parrot_runops_fromc_arglist_reti(PARROT_INTERP, ARGIN(PMC *sub),
 506         ARGIN(const char *sig), va_list args)
 507 {
 508     parrot_context_t * const ctx = runops_args(interp, sub, PMCNULL, NULL, sig, args);
 509
 510     return set_retval_i(interp, *sig, ctx);
 511 }
 512
 513 /*
 514
 515 =item C<FLOATVAL Parrot_runops_fromc_arglist_retf>
 516
 517 RT#48260: Not yet documented!!!
 518
 519 =cut
 520
 521 */
 522
 523 PARROT_API
 524 PARROT_IGNORABLE_RESULT
 525 FLOATVAL
 526 Parrot_runops_fromc_arglist_retf(PARROT_INTERP, ARGIN(PMC *sub),
 527         ARGIN(const char *sig), va_list args)
 528 {
 529     parrot_context_t * const ctx = runops_args(interp, sub, PMCNULL, NULL, sig, args);
 530
 531     return set_retval_f(interp, *sig, ctx);
 532 }
 533
 534 /*
 535
 536 =item C<void* Parrot_run_meth_fromc_arglist>
 537
 538 RT#48260: Not yet documented!!!
 539
 540 =cut
 541
 542 */
 543
 544 PARROT_API
 545 PARROT_IGNORABLE_RESULT
 546 PARROT_CAN_RETURN_NULL
 547 void*
 548 Parrot_run_meth_fromc_arglist(PARROT_INTERP, ARGIN(PMC *sub), ARGIN_NULLOK(PMC *obj),
 549         ARGIN(STRING *meth), ARGIN(const char *sig), va_list args)
 550 {
 551     parrot_context_t *ctx;
 552
 553     ctx = runops_args(interp, sub, obj, meth, sig, args);
 554     return set_retval(interp, *sig, ctx);
 555 }
 556
 557 /*
 558
 559 =item C<INTVAL Parrot_run_meth_fromc_arglist_reti>
 560
 561 RT#48260: Not yet documented!!!
 562
 563 =cut
 564
 565 */
 566
 567 PARROT_API
 568 PARROT_IGNORABLE_RESULT
 569 PARROT_CAN_RETURN_NULL
 570 INTVAL
 571 Parrot_run_meth_fromc_arglist_reti(PARROT_INTERP, ARGIN(PMC *sub), ARGIN_NULLOK(PMC *obj),
 572         ARGIN(STRING *meth), ARGIN(const char *sig), va_list args)
 573 {
 574     parrot_context_t * const ctx = runops_args(interp, sub, obj, meth, sig, args);
 575
 576     return set_retval_i(interp, *sig, ctx);
 577 }
 578
 579 /*
 580
 581 =item C<FLOATVAL Parrot_run_meth_fromc_arglist_retf>
 582
 583 RT#48260: Not yet documented!!!
 584
 585 =cut
 586
 587 */
 588
 589 PARROT_API
 590 PARROT_IGNORABLE_RESULT
 591 FLOATVAL
 592 Parrot_run_meth_fromc_arglist_retf(PARROT_INTERP, ARGIN(PMC *sub), ARGIN_NULLOK(PMC *obj),
 593         ARGIN(STRING *meth), ARGIN(const char *sig), va_list args)
 594 {
 595     parrot_context_t * const ctx = runops_args(interp, sub, obj, meth, sig, args);
 596     return set_retval_f(interp, *sig, ctx);
 597 }
 598
 599 /*
 600
 601 =back
 602
 603 =head2 Helper Functions
 604
 605 =over 4
 606
 607 =item C<void new_runloop_jump_point>
 608
 609 Create a new runloop jump point, either by allocating it or by
 610 getting one from the free list.
 611
 612 =cut
 613
 614 */
 615
 616 PARROT_API
 617 void
 618 new_runloop_jump_point(PARROT_INTERP)
 619 {
 620     Parrot_runloop *jump_point;
 621
 622     if (interp->runloop_jmp_free_list) {
 623         jump_point = interp->runloop_jmp_free_list;
 624         interp->runloop_jmp_free_list = jump_point->prev;
 625     }
 626     else
 627         jump_point = mem_allocate_typed(Parrot_runloop);
 628
 629     jump_point->prev = interp->current_runloop;
 630     interp->current_runloop = jump_point;
 631 }
 632
 633 /*
 634
 635 =item C<void free_runloop_jump_point>
 636
 637 Place runloop jump point back on the free list.
 638
 639 =cut
 640
 641 */
 642
 643 PARROT_API
 644 void
 645 free_runloop_jump_point(PARROT_INTERP)
 646 {
 647     Parrot_runloop * const jump_point = interp->current_runloop;
 648     interp->current_runloop = jump_point->prev;
 649     jump_point->prev = interp->runloop_jmp_free_list;
 650     interp->runloop_jmp_free_list = jump_point;
 651 }
 652
 653 /*
 654
 655 =item C<void destroy_runloop_jump_points>
 656
 657 Destroys (and frees the memory of) the runloop jump point list and the
 658 associated free list for the specified interpreter.
 659
 660 =cut
 661
 662 */
 663
 664 void
 665 destroy_runloop_jump_points(PARROT_INTERP)
 666 {
 667     really_destroy_runloop_jump_points(interp->current_runloop);
 668     really_destroy_runloop_jump_points(interp->runloop_jmp_free_list);
 669 }
 670
 671 /*
 672
 673 =item C<void really_destroy_runloop_jump_points>
 674
 675 Takes a pointer to a runloop jump point (which had better be the last one in
 676 the list). Walks back through the list, freeing the memory of each one, until
 677 it encounters NULL. Used by C<destroy_runloop_jump_points>.
 678
 679 =cut
 680
 681 */
 682
 683 void
 684 really_destroy_runloop_jump_points(ARGIN_NULLOK(Parrot_runloop *jump_point))
 685 {
 686     while (jump_point) {
 687         Parrot_runloop * const prev = jump_point->prev;
 688         mem_sys_free(jump_point);
 689         jump_point = prev;
 690     }
 691 }
 692
 693
 694 /*
 695
 696 =back
 697
 698 =head1 SEE ALSO
 699
 700 F<include/parrot/interpreter.h>, F<src/interpreter.c>.
 701
 702 =cut
 703
 704 */
 705
 706 /*
 707  * Local variables:
 708  *   c-file-style: "parrot"
 709  * End:
 710  * vim: expandtab shiftwidth=4:
 711  */