src/sub.c

   1 /*
   2 Copyright (C) 2001-2009, Parrot Foundation.
   3 $Id$
   4
   5 =head1 NAME
   6
   7 src/sub.c - Subroutines
   8
   9 =head1 DESCRIPTION
  10
  11 Subroutines, continuations, co-routines and other fun stuff...
  12
  13 =head2 Functions
  14
  15 =over 4
  16
  17 =cut
  18
  19 */
  20
  21 #include "parrot/parrot.h"
  22 #include "parrot/oplib/ops.h"
  23 #include "sub.str"
  24 #include "pmc/pmc_sub.h"
  25 #include "pmc/pmc_continuation.h"
  26
  27 /* HEADERIZER HFILE: include/parrot/sub.h */
  28
  29
  30 /*
  31
  32 =item C<void mark_context_start(void)>
  33
  34 Indicate that a new round of context marking is about to take place.
  35
  36 =cut
  37
  38 */
  39
  40 static int context_gc_mark = 0;
  41
  42 void
  43 mark_context_start(void)
  44 {
  45     ASSERT_ARGS(mark_context_start)
  46     if (++context_gc_mark == 0) context_gc_mark = 1;
  47 }
  48
  49
  50 /*
  51
  52 =item C<PMC * new_ret_continuation_pmc(PARROT_INTERP, opcode_t *address)>
  53
  54 Returns a new C<RetContinuation> PMC, and sets address field to C<address>
  55
  56 =cut
  57
  58 */
  59
  60 PARROT_EXPORT
  61 PARROT_MALLOC
  62 PARROT_CANNOT_RETURN_NULL
  63 PMC *
  64 new_ret_continuation_pmc(PARROT_INTERP, ARGIN_NULLOK(opcode_t *address))
  65 {
  66     ASSERT_ARGS(new_ret_continuation_pmc)
  67     PMC* const continuation = pmc_new(interp, enum_class_RetContinuation);
  68     VTABLE_set_pointer(interp, continuation, address);
  69     return continuation;
  70 }
  71
  72 /*
  73
  74 =item C<void invalidate_retc_context(PARROT_INTERP, PMC *cont)>
  75
  76 Make true Continuations from all RetContinuations up the call chain.
  77
  78 =cut
  79
  80 */
  81
  82 void
  83 invalidate_retc_context(PARROT_INTERP, ARGMOD(PMC *cont))
  84 {
  85     ASSERT_ARGS(invalidate_retc_context)
  86
  87     PMC *ctx = PARROT_CONTINUATION(cont)->from_ctx;
  88     cont = Parrot_pcc_get_continuation(interp, ctx);
  89
  90     while (1) {
  91         /*
  92          * We  stop if we encounter a true continuation, because
  93          * if one were created, everything up the chain would have been
  94          * invalidated earlier.
  95          */
  96         if (!cont || cont->vtable != interp->vtables[enum_class_RetContinuation])
  97             break;
  98         cont->vtable = interp->vtables[enum_class_Continuation];
  99         ctx  = Parrot_pcc_get_caller_ctx(interp, ctx);
 100         cont = Parrot_pcc_get_continuation(interp, ctx);
 101     }
 102 }
 103
 104 /*
 105
 106 =item C<STRING* Parrot_full_sub_name(PARROT_INTERP, PMC* sub_pmc)>
 107
 108 Return namespace, name, and location of subroutine.
 109
 110 =cut
 111
 112 */
 113
 114 PARROT_EXPORT
 115 PARROT_CAN_RETURN_NULL
 116 PARROT_WARN_UNUSED_RESULT
 117 STRING*
 118 Parrot_full_sub_name(PARROT_INTERP, ARGIN_NULLOK(PMC* sub_pmc))
 119 {
 120     ASSERT_ARGS(Parrot_full_sub_name)
 121     if (sub_pmc && VTABLE_defined(interp, sub_pmc)) {
 122         Parrot_Sub_attributes *sub;
 123
 124         PMC_get_sub(interp, sub_pmc, sub);
 125
 126         if (PMC_IS_NULL(sub->namespace_stash)) {
 127             return sub->name;
 128         }
 129         else {
 130             PMC    *ns_array;
 131             STRING * const semicolon = CONST_STRING(interp, ";");
 132             STRING *res;
 133
 134             /*
 135              * When running with -t4, the invoke done in
 136              * Parrot_ns_get_name stomps on settings in interp; we
 137              * have to save these and restore them to avoid affecting
 138              * the running program.
 139              */
 140             PMC      * const saved_ccont       = interp->current_cont;
 141             opcode_t * const current_args      = interp->current_args;
 142             opcode_t * const current_params    = interp->current_params;
 143             opcode_t * const current_returns   = interp->current_returns;
 144             PMC      * const args_signature    = interp->args_signature;
 145             PMC      * const params_signature  = interp->params_signature;
 146             PMC      * const returns_signature = interp->returns_signature;
 147
 148             Parrot_block_GC_mark(interp);
 149
 150             ns_array = Parrot_ns_get_name(interp, sub->namespace_stash);
 151
 152             /* Restore stuff that might have got overwritten */
 153             interp->current_cont      = saved_ccont;
 154             interp->current_args      = current_args;
 155             interp->current_params    = current_params;
 156             interp->current_returns   = current_returns;
 157             interp->args_signature    = args_signature;
 158             interp->params_signature  = params_signature;
 159             interp->returns_signature = returns_signature;
 160
 161             if (sub->name)
 162                 VTABLE_push_string(interp, ns_array, sub->name);
 163
 164             res = Parrot_str_join(interp, semicolon, ns_array);
 165             Parrot_unblock_GC_mark(interp);
 166             return res;
 167         }
 168     }
 169     return NULL;
 170 }
 171
 172 /*
 173
 174 =item C<int Parrot_Context_get_info(PARROT_INTERP, PMC *ctx, Parrot_Context_info
 175 *info)>
 176
 177 Takes pointers to a context and its information table.
 178 Populates the table and returns 0 or 1. XXX needs explanation
 179 Used by Parrot_Context_infostr.
 180
 181 =cut
 182
 183 */
 184
 185 PARROT_EXPORT
 186 int
 187 Parrot_Context_get_info(PARROT_INTERP, ARGIN(PMC *ctx),
 188     ARGOUT(Parrot_Context_info *info))
 189 {
 190     ASSERT_ARGS(Parrot_Context_get_info)
 191     PMC                   *subpmc;
 192     Parrot_Sub_attributes *sub;
 193
 194     /* set file/line/pc defaults */
 195     info->file     = CONST_STRING(interp, "(unknown file)");
 196     info->line     = -1;
 197     info->pc       = -1;
 198     info->nsname   = NULL;
 199     info->subname  = NULL;
 200     info->fullname = NULL;
 201
 202     subpmc = Parrot_pcc_get_sub(interp, ctx);
 203
 204     /* is the current sub of the specified context valid? */
 205     if (PMC_IS_NULL(subpmc)) {
 206         info->subname  = Parrot_str_new(interp, "???", 3);
 207         info->nsname   = info->subname;
 208         info->fullname = Parrot_str_new(interp, "??? :: ???", 10);
 209         info->pc       = -1;
 210         return 0;
 211     }
 212
 213     /* fetch Parrot_sub of the current sub in the given context */
 214     if (!VTABLE_isa(interp, subpmc, CONST_STRING(interp, "Sub")))
 215         return 1;
 216
 217     PMC_get_sub(interp, subpmc, sub);
 218     /* set the sub name */
 219     info->subname = sub->name;
 220
 221     /* set the namespace name and fullname of the sub */
 222     if (PMC_IS_NULL(sub->namespace_name)) {
 223         info->nsname   = CONST_STRING(interp, "");
 224         info->fullname = info->subname;
 225     }
 226     else {
 227         info->nsname   = VTABLE_get_string(interp, sub->namespace_name);
 228         info->fullname = Parrot_full_sub_name(interp, subpmc);
 229     }
 230
 231     /* return here if there is no current pc */
 232     if (Parrot_pcc_get_pc(interp, ctx) == NULL)
 233         return 1;
 234
 235     /* calculate the current pc */
 236     info->pc = Parrot_pcc_get_pc(interp, ctx) - sub->seg->base.data;
 237
 238     /* determine the current source file/line */
 239     if (Parrot_pcc_get_pc(interp, ctx)) {
 240         const size_t offs = info->pc;
 241         size_t i, n;
 242         opcode_t *pc = sub->seg->base.data;
 243         PackFile_Debug * const debug = sub->seg->debugs;
 244
 245         if (!debug)
 246             return 0;
 247         for (i = n = 0; n < sub->seg->base.size; i++) {
 248             op_info_t * const op_info = &interp->op_info_table[*pc];
 249             opcode_t var_args = 0;
 250
 251             if (i >= debug->base.size)
 252                 return 0;
 253             if (n >= offs) {
 254                 /* set source line and file */
 255                 info->line = debug->base.data[i];
 256                 info->file = Parrot_debug_pc_to_filename(interp, debug, i);
 257                 break;
 258             }
 259             ADD_OP_VAR_PART(interp, sub->seg, pc, var_args);
 260             n  += op_info->op_count + var_args;
 261             pc += op_info->op_count + var_args;
 262         }
 263     }
 264     return 1;
 265 }
 266
 267 /*
 268
 269 =item C<STRING* Parrot_Context_infostr(PARROT_INTERP, PMC *ctx)>
 270
 271 Formats context information for display.  Takes a context pointer and
 272 returns a pointer to the text.  Used in debug.c and warnings.c
 273
 274 =cut
 275
 276 */
 277
 278 PARROT_EXPORT
 279 PARROT_CAN_RETURN_NULL
 280 PARROT_WARN_UNUSED_RESULT
 281 STRING*
 282 Parrot_Context_infostr(PARROT_INTERP, ARGIN(PMC *ctx))
 283 {
 284     ASSERT_ARGS(Parrot_Context_infostr)
 285     Parrot_Context_info info;
 286     STRING             *res = NULL;
 287     const char * const  msg = (CURRENT_CONTEXT(interp) == ctx)
 288         ? "current instr.:"
 289         : "called from Sub";
 290
 291     Parrot_block_GC_mark(interp);
 292     if (Parrot_Context_get_info(interp, ctx, &info)) {
 293
 294         res = Parrot_sprintf_c(interp,
 295             "%s '%Ss' pc %d (%Ss:%d)", msg,
 296             info.fullname, info.pc, info.file, info.line);
 297     }
 298
 299     Parrot_unblock_GC_mark(interp);
 300     return res;
 301 }
 302
 303 /*
 304
 305 =item C<PMC* Parrot_find_pad(PARROT_INTERP, STRING *lex_name, PMC *ctx)>
 306
 307 Locate the LexPad containing the given name. Return NULL on failure.
 308
 309 =cut
 310
 311 */
 312
 313 PARROT_CAN_RETURN_NULL
 314 PARROT_WARN_UNUSED_RESULT
 315 PMC*
 316 Parrot_find_pad(PARROT_INTERP, ARGIN(STRING *lex_name), ARGIN(PMC *ctx))
 317 {
 318     ASSERT_ARGS(Parrot_find_pad)
 319     while (1) {
 320         PMC * const lex_pad = Parrot_pcc_get_lex_pad(interp, ctx);
 321         PMC * outer         = Parrot_pcc_get_outer_ctx(interp, ctx);
 322
 323         if (!outer)
 324             return lex_pad;
 325
 326         if (!PMC_IS_NULL(lex_pad))
 327             if (VTABLE_exists_keyed_str(interp, lex_pad, lex_name))
 328                 return lex_pad;
 329
 330         ctx = outer;
 331     }
 332 }
 333
 334
 335 /*
 336
 337 =item C<PMC* Parrot_find_dynamic_pad(PARROT_INTERP, STRING *lex_name, PMC *ctx)>
 338
 339 Locate the LexPad containing the given C<lex_name> in C<ctx> and
 340 its caller pads.  Return PMCNULL on failure.
 341
 342 =cut
 343
 344 */
 345
 346 PARROT_CAN_RETURN_NULL
 347 PARROT_WARN_UNUSED_RESULT
 348 PMC*
 349 Parrot_find_dynamic_pad(PARROT_INTERP, ARGIN(STRING *lex_name), ARGIN(PMC *ctx))
 350 {
 351     ASSERT_ARGS(Parrot_find_dynamic_pad)
 352     while (1) {
 353         PMC * const lex_pad = Parrot_pcc_get_lex_pad(interp, ctx);
 354         PMC * caller        = Parrot_pcc_get_caller_ctx(interp, ctx);
 355
 356         if (!caller)
 357             return lex_pad;
 358
 359         if (!PMC_IS_NULL(lex_pad))
 360             if (VTABLE_exists_keyed_str(interp, lex_pad, lex_name))
 361                 return lex_pad;
 362
 363         ctx = caller;
 364     }
 365 }
 366
 367
 368 /*
 369
 370 =item C<void Parrot_capture_lex(PARROT_INTERP, PMC *sub_pmc)>
 371
 372 Capture the current lexical environment of a sub.
 373
 374 =cut
 375
 376 */
 377
 378 void
 379 Parrot_capture_lex(PARROT_INTERP, ARGMOD(PMC *sub_pmc))
 380 {
 381     ASSERT_ARGS(Parrot_capture_lex)
 382     PMC            * const ctx          = CURRENT_CONTEXT(interp);
 383     Parrot_Sub_attributes *current_sub;
 384     Parrot_Sub_attributes *sub;
 385
 386     PMC_get_sub(interp, Parrot_pcc_get_sub(interp, ctx), current_sub);
 387
 388     /* MultiSub gets special treatment */
 389     if (VTABLE_isa(interp, sub_pmc, CONST_STRING(interp, "MultiSub"))) {
 390
 391         PMC * const iter = VTABLE_get_iter(interp, sub_pmc);
 392
 393         while (VTABLE_get_bool(interp, iter)) {
 394
 395             PMC        * const child_pmc = VTABLE_shift_pmc(interp, iter);
 396             Parrot_Sub_attributes *child_sub, *child_outer_sub;
 397
 398             PMC_get_sub(interp, child_pmc, child_sub);
 399
 400             if (!PMC_IS_NULL(child_sub->outer_sub)) {
 401                 PMC_get_sub(interp, child_sub->outer_sub, child_outer_sub);
 402                 if (Parrot_str_equal(interp, current_sub->subid,
 403                                       child_outer_sub->subid)) {
 404                     child_sub->outer_ctx = ctx;
 405                 }
 406             }
 407         }
 408         return;
 409     }
 410
 411     /* the sub_pmc has to have an outer_sub that is the caller */
 412     PMC_get_sub(interp, sub_pmc, sub);
 413     if (PMC_IS_NULL(sub->outer_sub))
 414         return;
 415
 416 #if 0
 417     /* verify that the current sub is sub_pmc's :outer */
 418     PMC_get_sub(interp, sub->outer_sub, outer_sub);
 419     if (Parrot_str_not_equal(interp, current_sub->subid,
 420                          outer_sub->subid)) {
 421         Parrot_ex_throw_from_c_args(interp, NULL,
 422             EXCEPTION_INVALID_OPERATION, "'%Ss' isn't the :outer of '%Ss'",
 423             current_sub->name, sub->name);
 424         return;
 425     }
 426 #endif
 427
 428     /* set the sub's outer context to the current context */
 429     sub->outer_ctx = ctx;
 430 }
 431
 432
 433 /*
 434
 435 =item C<PMC* parrot_new_closure(PARROT_INTERP, PMC *sub_pmc)>
 436
 437 Used where? XXX
 438
 439 Creates a new closure, saving the context information.  Takes a pointer
 440 to a subroutine.
 441
 442 Returns a pointer to the closure, (or throws exceptions if invalid).
 443
 444 =cut
 445
 446 */
 447
 448 PARROT_EXPORT
 449 PARROT_CANNOT_RETURN_NULL
 450 PARROT_WARN_UNUSED_RESULT
 451 PMC*
 452 parrot_new_closure(PARROT_INTERP, ARGIN(PMC *sub_pmc))
 453 {
 454     ASSERT_ARGS(parrot_new_closure)
 455     PMC * const clos_pmc = VTABLE_clone(interp, sub_pmc);
 456     Parrot_capture_lex(interp, clos_pmc);
 457     return clos_pmc;
 458 }
 459
 460
 461 /*
 462
 463 =item C<void Parrot_continuation_check(PARROT_INTERP, const PMC *pmc)>
 464
 465 Verifies that the provided continuation is sane.
 466
 467 =cut
 468
 469 */
 470
 471 void
 472 Parrot_continuation_check(PARROT_INTERP, ARGIN(const PMC *pmc))
 473 {
 474     ASSERT_ARGS(Parrot_continuation_check)
 475     PMC * const to_ctx       = PARROT_CONTINUATION(pmc)->to_ctx;
 476     if (PMC_IS_NULL(to_ctx))
 477         Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
 478                        "Continuation invoked after deactivation.");
 479 }
 480
 481 /*
 482
 483 =item C<void Parrot_continuation_rewind_environment(PARROT_INTERP, PMC *pmc)>
 484
 485 Restores the appropriate context for the continuation.
 486
 487 =cut
 488
 489 */
 490
 491 void
 492 Parrot_continuation_rewind_environment(PARROT_INTERP, ARGIN(PMC *pmc))
 493 {
 494     ASSERT_ARGS(Parrot_continuation_rewind_environment)
 495
 496     PMC * const to_ctx = PARROT_CONTINUATION(pmc)->to_ctx;
 497
 498     /* debug print before context is switched */
 499     if (Interp_trace_TEST(interp, PARROT_TRACE_SUB_CALL_FLAG)) {
 500         PMC * const sub = Parrot_pcc_get_sub(interp, to_ctx);
 501
 502         Parrot_io_eprintf(interp, "# Back in sub '%Ss', env %p\n",
 503                     Parrot_full_sub_name(interp, sub),
 504                     interp->dynamic_env);
 505     }
 506
 507     /* set context */
 508     CURRENT_CONTEXT(interp) = to_ctx;
 509 }
 510
 511
 512 /*
 513
 514 =item C<void * Parrot_get_sub_pmc_from_subclass(PARROT_INTERP, PMC *subclass)>
 515
 516 Gets a Parrot_sub structure from something that isn't a Sub PMC, but rather a
 517 subclass.
 518
 519 =cut
 520
 521 */
 522
 523 PARROT_EXPORT
 524 PARROT_CANNOT_RETURN_NULL
 525 void *
 526 Parrot_get_sub_pmc_from_subclass(PARROT_INTERP, ARGIN(PMC *subclass)) {
 527     ASSERT_ARGS(Parrot_get_sub_pmc_from_subclass)
 528     PMC *key, *sub_pmc;
 529
 530     /* Ensure we really do have a subclass of sub. */
 531     if (VTABLE_isa(interp, subclass, CONST_STRING(interp, "Sub"))) {
 532         /* If it's actually a PMC still, probably does the same structure
 533          * underneath. */
 534         if (!PObj_is_object_TEST(subclass)) {
 535             return PARROT_SUB(subclass);
 536         }
 537
 538         /* Get the Sub PMC itself. */
 539         key = pmc_new(interp, enum_class_String);
 540         VTABLE_set_string_native(interp, key, CONST_STRING(interp, "Sub"));
 541         sub_pmc = VTABLE_get_attr_keyed(interp, subclass, key, CONST_STRING(interp, "proxy"));
 542         if (sub_pmc->vtable->base_type == enum_class_Sub) {
 543             return PARROT_SUB(sub_pmc);
 544         }
 545     }
 546     Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
 547             "Attempting to do sub operation on non-Sub.");
 548 }
 549
 550 /*
 551
 552 =back
 553
 554 =head1 SEE ALSO
 555
 556 F<include/parrot/sub.h>.
 557
 558 =head1 HISTORY
 559
 560 Initial version by Melvin on 2002/06/6.
 561
 562 =cut
 563
 564 */
 565
 566
 567 /*
 568  * Local variables:
 569  *   c-file-style: "parrot"
 570  * End:
 571  * vim: expandtab shiftwidth=4:
 572  */