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