src/sub.c

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