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