src/pmc/sub.pmc

   1 /*
   2 Copyright (C) 2001-2009, Parrot Foundation.
   3 $Id$
   4
   5 =head1 NAME
   6
   7 src/pmc/sub.pmc - Subroutine
   8
   9 =head1 DESCRIPTION
  10
  11 These are the vtable functions for the Sub (subroutine) base class
  12
  13 =head2 Functions
  14
  15 =over 4
  16
  17 =cut
  18
  19 */
  20
  21 #include "parrot/oplib/ops.h"
  22 #include "sub.str"
  23
  24 static void
  25 print_sub_name(PARROT_INTERP, ARGIN_NULLOK(PMC *sub))
  26 {
  27     Interp * const tracer = (interp->pdb && interp->pdb->debugger) ?
  28         interp->pdb->debugger :
  29         interp;
  30
  31     /* sub was located via globals */
  32     Parrot_io_eprintf(tracer, "# Calling sub '%Ss'\n# ",
  33         Parrot_full_sub_name(interp, sub));
  34
  35     print_pbc_location(interp);
  36 }
  37
  38 pmclass Sub auto_attrs {
  39     ATTR PackFile_ByteCode *seg;     /* bytecode segment */
  40     ATTR size_t   start_offs;        /* sub entry in ops from seg->base.data */
  41     ATTR size_t   end_offs;
  42
  43     ATTR INTVAL   HLL_id;             /* see src/hll.c XXX or per segment? */
  44     ATTR PMC      *namespace_name;    /* where this Sub is in - this is either
  45                                   * a String or a [Key] and describes
  46                                   * the relative path in the NameSpace
  47                                   */
  48     ATTR PMC      *namespace_stash;   /* the actual hash, HLL::namespace */
  49     ATTR STRING   *name;              /* name of the sub */
  50     ATTR STRING   *method_name;       /* method name of the sub */
  51     ATTR STRING   *ns_entry_name;     /* ns entry name of the sub */
  52     ATTR STRING   *subid;             /* The ID of the sub. */
  53     ATTR INTVAL   vtable_index;       /* index in Parrot_vtable_slot_names */
  54     ATTR PMC      *multi_signature;   /* list of types for MMD */
  55     ATTR INTVAL   n_regs_used[4];     /* INSP in PBC */
  56
  57     ATTR PMC      *lex_info;          /* LexInfo PMC */
  58     ATTR PMC      *outer_sub;         /* :outer for closures */
  59     ATTR PMC      *eval_pmc;          /* eval container / NULL */
  60     ATTR PMC      *ctx;               /* the context this sub is in */
  61     ATTR UINTVAL  comp_flags;         /* compile time and additional flags */
  62     ATTR Parrot_sub_arginfo *arg_info;/* Argument counts and flags. */
  63
  64     /* - end common */
  65     ATTR PMC      *outer_ctx;         /* outer context, if a closure */
  66
  67 /*
  68
  69 =item C<void init()>
  70
  71 Initializes the subroutine.
  72
  73 =cut
  74
  75 */
  76
  77     /*
  78      * Sub PMC's flags usage:
  79      * - private0 ... Coroutine flip/flop - C exception handler
  80      * - private1 ... _IS_OUTER - have to preserve context
  81      *                as some other sub has :outer(this)
  82      * - private2 ... tailcall invoked this Sub
  83      * - private3 ... pythonic coroutine generator flag
  84      * - private4 ... :main (originally @MAIN)
  85      * - private5 ... :load (originally @LOAD)
  86      * - private6 ... :immediate (originally @IMMEDIATE)
  87      * - private7 ... :postcomp (originally @POSTCOMP)
  88      *
  89      * see also the enum in include/parrot/sub.h
  90      */
  91     VTABLE void init() {
  92         Parrot_Sub_attributes * const attrs =
  93             (Parrot_Sub_attributes *) PMC_data(SELF);
  94
  95         attrs->seg = INTERP->code;
  96
  97         PObj_custom_mark_destroy_SETALL(SELF);
  98     }
  99
 100 /*
 101
 102 =item C<void destroy()>
 103
 104 Destroys the subroutine.
 105
 106 =cut
 107
 108 */
 109
 110     VTABLE void destroy() {
 111         Parrot_Sub_attributes *sub = PARROT_SUB(SELF);
 112
 113         if (sub) {
 114             if (sub->arg_info)
 115                 mem_sys_free(sub->arg_info);
 116         }
 117     }
 118
 119 /*
 120
 121 =item C<STRING *get_string()>
 122
 123 Returns the name of the subroutine.
 124
 125 =item C<void set_string_native(STRING *subname)>
 126
 127 Sets the name of the subroutine.
 128
 129 =cut
 130
 131 */
 132
 133     VTABLE STRING *get_string() {
 134         STRING *name;
 135         Parrot_Sub_attributes *sub;
 136         PMC_get_sub(INTERP, SELF, sub);
 137
 138         if (sub->name)
 139             return Parrot_str_copy(INTERP, sub->name);
 140
 141         return NULL;
 142     }
 143
 144     VTABLE void set_string_native(STRING *subname) {
 145         Parrot_Sub_attributes *sub;
 146         PMC_get_sub(INTERP, SELF, sub);
 147         sub->name = Parrot_str_copy(INTERP, subname);
 148     }
 149
 150 /*
 151
 152 =item C<void set_pointer(void *value)>
 153
 154 Sets the pointer to the actual subroutine.
 155
 156 *** Don't use that - use C<.const 'Sub'> in PIR instead ***
 157
 158 =cut
 159
 160 */
 161
 162     VTABLE void set_pointer(void *value) {
 163         UNUSED(value)
 164         Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_INVALID_OPERATION,
 165             "Don't set the address of a sub\nuse .const 'Sub' instead");
 166     }
 167
 168 /*
 169
 170 =item C<void *get_pointer()>
 171
 172 Returns the address of the actual subroutine.
 173
 174 =cut
 175
 176 */
 177
 178     VTABLE void *get_pointer() {
 179         Parrot_Sub_attributes *sub;
 180         PMC_get_sub(INTERP, SELF, sub);
 181         return sub->seg->base.data + sub->start_offs;
 182     }
 183
 184 /*
 185
 186 =item C<INTVAL get_integer_keyed(PMC *key)>
 187
 188 I<This just unconditionally returns the start of bytecode. It's wrong,
 189 wrong, wrong, *WRONG*. And there's no other good way, so it's here for
 190 now.> -DRS
 191
 192 =cut
 193
 194 */
 195
 196     VTABLE INTVAL get_integer_keyed(PMC *key) {
 197         Parrot_Sub_attributes *sub;
 198         UNUSED(key)
 199         PMC_get_sub(INTERP, SELF, sub);
 200
 201         return (INTVAL) (sub->seg->base.data);
 202     }
 203
 204 /*
 205
 206 =item C<INTVAL defined()>
 207
 208 =item C<INTVAL get_bool()>
 209
 210 Returns True.
 211
 212 =cut
 213
 214 */
 215
 216     VTABLE INTVAL defined() {
 217         return 1;
 218     }
 219
 220     VTABLE INTVAL get_bool() {
 221         return 1;
 222     }
 223
 224 /*
 225
 226 =item C<opcode_t *invoke(void *next)>
 227
 228 Invokes the subroutine.
 229
 230 =cut
 231
 232 */
 233
 234     VTABLE opcode_t *invoke(void *next) {
 235         Parrot_Sub_attributes *sub;
 236         PMC                   *caller_ctx;
 237         PMC                   *context;
 238         PMC                   *ccont;
 239         opcode_t              *pc;
 240
 241         PMC_get_sub(INTERP, SELF, sub);
 242         if (Interp_trace_TEST(INTERP, PARROT_TRACE_SUB_CALL_FLAG))
 243             print_sub_name(INTERP, SELF);
 244
 245         /*
 246          * A remark WRT tail calls
 247          *
 248          * we have:
 249          * sub A:
 250          *    ...
 251          *    B()
 252          *    ...
 253          * sub B:
 254          *    ...
 255          *    .return C(...)
 256          *
 257          * that is the sub B() returns whatever C() returns.
 258          *
 259          * We are just calling the sub C().
 260          * If the private2 flag is set, this code is called by a
 261          * tailcall opcode.
 262          *
 263          * We allocate a new register frame and recycle it
 264          * immediately after argument passing.
 265          *
 266          */
 267         pc                   = sub->seg->base.data + sub->start_offs;
 268         caller_ctx           = CURRENT_CONTEXT(interp);
 269         ccont                = INTERP->current_cont;
 270         INTERP->current_cont = NULL;
 271
 272         if (ccont == NEED_CONTINUATION)
 273             ccont = new_ret_continuation_pmc(interp, (opcode_t *)next);
 274
 275         PARROT_ASSERT(!PMC_IS_NULL(ccont));
 276
 277         /* plain subroutine call
 278          * create new context, place it in interpreter */
 279         context               = Parrot_set_new_context(INTERP, sub->n_regs_used);
 280         Parrot_pcc_set_sub(interp, context, SELF);
 281         Parrot_pcc_set_caller_ctx(interp, context, caller_ctx);
 282         Parrot_pcc_set_pc(interp, context, pc);
 283         Parrot_pcc_set_continuation(interp, context, ccont);
 284
 285         /* check recursion/call depth */
 286         if (Parrot_pcc_inc_recursion_depth(INTERP, context) > INTERP->recursion_limit)
 287             Parrot_ex_throw_from_c_args(INTERP, next, CONTROL_ERROR,
 288                     "maximum recursion depth exceeded");
 289
 290         /* and copy set context variables */
 291         PARROT_CONTINUATION(ccont)->from_ctx = context;
 292
 293         /* if this is an outer sub, then we need to set sub->ctx
 294          * to the new context (refcounted) and convert the
 295          * retcontinuation to a normal continuation.  */
 296         if (PObj_get_FLAGS(SELF) & SUB_FLAG_IS_OUTER) {
 297             sub->ctx = context;
 298             /* convert retcontinuation to a continuation */
 299             ccont->vtable = interp->vtables[enum_class_Continuation];
 300         }
 301
 302         if (!PMC_IS_NULL(INTERP->current_object)) {
 303             Parrot_pcc_set_object(interp, context, INTERP->current_object);
 304             INTERP->current_object  = NULL;
 305         }
 306
 307         Parrot_pcc_set_HLL(interp, context, sub->HLL_id);
 308         Parrot_pcc_set_namespace(interp, context, sub->namespace_stash);
 309
 310         /* create pad if needed
 311          * TODO move this up in front of argument passing
 312          *      and factor out common code with coroutine pmc
 313          */
 314         if (!PMC_IS_NULL(sub->lex_info)) {
 315             Parrot_pcc_set_lex_pad(interp, context, pmc_new_init(INTERP,
 316                     Parrot_get_ctx_HLL_type(interp, enum_class_LexPad),
 317                     sub->lex_info));
 318             VTABLE_set_pointer(INTERP, Parrot_pcc_get_lex_pad(interp, context), context);
 319         }
 320
 321         if (!PMC_IS_NULL(sub->outer_ctx)) {
 322             /* set outer context */
 323             Parrot_pcc_set_outer_ctx(interp, context, sub->outer_ctx);
 324         }
 325         else {
 326             /* autoclose */
 327             PMC *c = context;
 328             PMC *outer_c = Parrot_pcc_get_outer_ctx(interp, c);
 329             for (c = context; PMC_IS_NULL(outer_c); c = outer_c) {
 330
 331                 PMC         *outer_pmc;
 332                 Parrot_Sub_attributes *current_sub, *outer_sub;
 333
 334                 PMC_get_sub(INTERP, Parrot_pcc_get_sub(interp, c), current_sub);
 335                 outer_pmc   = current_sub->outer_sub;
 336
 337                 if (PMC_IS_NULL(outer_pmc))
 338                     break;
 339
 340                 PMC_get_sub(INTERP, outer_pmc, outer_sub);
 341
 342                 if (PMC_IS_NULL(outer_sub->ctx)) {
 343                     PMC * const dummy = Parrot_alloc_context(INTERP,
 344                                                 outer_sub->n_regs_used, NULL);
 345                     Parrot_pcc_set_sub(interp, dummy, outer_pmc);
 346
 347                     if (!PMC_IS_NULL(outer_sub->lex_info)) {
 348                         Parrot_pcc_set_lex_pad(interp, dummy, pmc_new_init(INTERP,
 349                                Parrot_get_ctx_HLL_type(interp, enum_class_LexPad),
 350                                outer_sub->lex_info));
 351                         VTABLE_set_pointer(INTERP, Parrot_pcc_get_lex_pad(interp, dummy), dummy);
 352                     }
 353
 354                     if (!PMC_IS_NULL(outer_sub->outer_ctx))
 355                         Parrot_pcc_set_outer_ctx(interp, dummy, outer_sub->outer_ctx);
 356                     outer_sub->ctx = dummy;
 357                 }
 358
 359                 Parrot_pcc_set_outer_ctx(interp, c, outer_sub->ctx);
 360                 outer_c = outer_sub->ctx;
 361             }
 362         }
 363
 364         /* switch code segment if needed */
 365         if (INTERP->code != sub->seg)
 366             Parrot_switch_to_cs(INTERP, sub->seg, 1);
 367
 368         if (PObj_get_FLAGS(ccont) & SUB_FLAG_TAILCALL) {
 369             if (!(*pc == PARROT_OP_get_params_pc
 370             ||    (*pc    == PARROT_OP_push_eh_ic
 371             &&     pc[2] == PARROT_OP_get_params_pc))) {
 372
 373                 /* TODO keep it or resize it */
 374                 Parrot_pcc_dec_recursion_depth(INTERP, context);
 375
 376                 PObj_get_FLAGS(ccont) &= ~SUB_FLAG_TAILCALL;
 377                 Parrot_pcc_set_caller_ctx(interp, context,
 378                         Parrot_pcc_get_caller_ctx(interp, caller_ctx));
 379             }
 380         }
 381
 382         return pc;
 383     }
 384
 385 /*
 386
 387 =item C<PMC *clone()>
 388
 389 Creates and returns a clone of the subroutine.
 390
 391 =cut
 392
 393 */
 394
 395     VTABLE PMC *clone() {
 396         PMC        * const ret = pmc_new(INTERP, SELF->vtable->base_type);
 397         Parrot_Sub_attributes *dest_sub;
 398         Parrot_Sub_attributes *sub;
 399
 400         /* XXX Why? */
 401         /* we have to mark it ourselves */
 402         PObj_custom_mark_destroy_SETALL(ret);
 403
 404         PMC_get_sub(INTERP, SELF, dest_sub);
 405         PMC_get_sub(INTERP, ret, sub);
 406
 407         /* first set the sub struct, Parrot_str_copy may cause GC */
 408         *sub = *dest_sub;
 409
 410         if (sub->name)
 411             sub->name = Parrot_str_copy(INTERP, sub->name);
 412
 413         /* Be sure not to share arg_info. */
 414         dest_sub->arg_info = NULL;
 415
 416         return ret;
 417     }
 418
 419 /*
 420
 421 =item C<void assign_pmc(PMC *other)>
 422
 423 Set SELF to the data in other.
 424
 425 =cut
 426
 427 */
 428
 429     VTABLE void set_pmc(PMC *other) {
 430         SELF.assign_pmc(other);
 431     }
 432
 433     VTABLE void assign_pmc(PMC *other) {
 434         /* only handle the case where the other PMC is the same type */
 435         if (other->vtable->base_type == SELF->vtable->base_type) {
 436             Parrot_Sub_attributes *my_sub;
 437             Parrot_Sub_attributes *other_sub;
 438
 439             PMC_get_sub(INTERP, SELF, my_sub);
 440             PMC_get_sub(INTERP, other, other_sub);
 441
 442             /* copy the sub struct */
 443             memmove(my_sub, other_sub, sizeof (Parrot_Sub_attributes));
 444
 445             /* copy the name so it's a different string in memory */
 446             if (my_sub->name)
 447                 my_sub->name = Parrot_str_copy(INTERP, my_sub->name);
 448         }
 449         else
 450             Parrot_ex_throw_from_c_args(INTERP, NULL,
 451                 EXCEPTION_INVALID_OPERATION,
 452                 "Can't assign a non-Sub type to a Sub");
 453     }
 454
 455 /*
 456
 457 =item C<void mark()>
 458
 459 Marks the sub as live.
 460
 461 =cut
 462
 463 */
 464
 465     VTABLE void mark() {
 466         Parrot_Sub_attributes *sub = PARROT_SUB(SELF);
 467
 468         if (!sub)
 469             return;
 470
 471         if (sub->name)
 472             Parrot_gc_mark_PObj_alive(INTERP, (PObj *) sub->name);
 473         if (sub->method_name)
 474             Parrot_gc_mark_PObj_alive(INTERP, (PObj *) sub->method_name);
 475         if (sub->ns_entry_name)
 476             Parrot_gc_mark_PObj_alive(INTERP, (PObj *) sub->ns_entry_name);
 477         if (!PMC_IS_NULL(sub->namespace_name))
 478             Parrot_gc_mark_PObj_alive(INTERP, (PObj *) sub->namespace_name);
 479         if (!PMC_IS_NULL(sub->namespace_stash))
 480             Parrot_gc_mark_PObj_alive(INTERP, (PObj *) sub->namespace_stash);
 481         if (!PMC_IS_NULL(sub->multi_signature))
 482             Parrot_gc_mark_PObj_alive(INTERP, (PObj *) sub->multi_signature);
 483         if (!PMC_IS_NULL(sub->lex_info))
 484             Parrot_gc_mark_PObj_alive(INTERP, (PObj *) sub->lex_info);
 485         if (!PMC_IS_NULL(sub->outer_sub))
 486             Parrot_gc_mark_PObj_alive(INTERP, (PObj *) sub->outer_sub);
 487         if (!PMC_IS_NULL(sub->eval_pmc))
 488             Parrot_gc_mark_PObj_alive(INTERP, (PObj *) sub->eval_pmc);
 489         if (sub->subid)
 490             Parrot_gc_mark_PObj_alive(INTERP, (PObj *) sub->subid);
 491         if (sub->ctx)
 492             Parrot_gc_mark_PObj_alive(interp, (PObj *) sub->ctx);
 493         if (sub->outer_ctx)
 494             Parrot_gc_mark_PObj_alive(interp, (PObj *) sub->outer_ctx);
 495     }
 496
 497 /*
 498
 499 =item C<INTVAL is_equal(PMC *value)>
 500
 501 Returns whether the two subroutines are equal.
 502
 503 =cut
 504
 505 */
 506
 507     MULTI INTVAL is_equal(PMC *value) {
 508         Parrot_Sub_attributes *my_sub;
 509         Parrot_Sub_attributes *value_sub;
 510
 511         PMC_get_sub(INTERP, SELF, my_sub);
 512         PMC_get_sub(INTERP, value, value_sub);
 513
 514         return SELF->vtable         == value->vtable
 515         &&     (my_sub)->start_offs == (value_sub)->start_offs
 516         &&     (my_sub)->seg        == (value_sub)->seg;
 517     }
 518
 519 /*
 520
 521 =item C<void visit(visit_info *info)>
 522
 523 This is used by freeze/thaw to visit the contents of the sub.
 524
 525 =item C<void freeze(visit_info *info)>
 526
 527 Archives the subroutine.
 528
 529 =cut
 530
 531 */
 532
 533     VTABLE void visit(visit_info *info) {
 534         Parrot_Sub_attributes *sub;
 535
 536         PMC_get_sub(INTERP, SELF, sub);
 537
 538         info->thaw_ptr = &sub->namespace_name;
 539         (info->visit_pmc_now)(INTERP, sub->namespace_name, info);
 540
 541         info->thaw_ptr = &sub->multi_signature;
 542         (info->visit_pmc_now)(INTERP, sub->multi_signature, info);
 543
 544         info->thaw_ptr = &sub->outer_sub;
 545         (info->visit_pmc_now)(INTERP, sub->outer_sub, info);
 546
 547         /*
 548          * XXX visit_pmc_now is wrong, because it breaks
 549          *     depth-first visit inside the todo list
 550          * TODO change all user visit functions to use
 551          *    visit_pmc (the todo renamed visit_pm_later)
 552          *
 553          * Therefore the hash must be last during visit for now.
 554          */
 555         info->thaw_ptr = &sub->lex_info;
 556         (info->visit_pmc_now)(INTERP, sub->lex_info, info);
 557         SUPER(info);
 558     }
 559
 560     VTABLE void freeze(visit_info *info) {
 561         IMAGE_IO       * const io  = info->image_io;
 562         Parrot_Sub_attributes *sub;
 563         STRING                *hll_name;
 564         int i;
 565
 566         SUPER(info);
 567         PMC_get_sub(INTERP, SELF, sub);
 568         /*
 569          * we currently need to write these items:
 570          * - start offset in byte-code segment
 571          * - end   offset in byte-code segment
 572          * - segment TODO ???
 573          * - flags  (i.e. :load pragma and such)
 574          * - name of the sub's label
 575          * - method name
 576          * - ns entry name
 577          * - namespace
 578          * - HLL_id
 579          * - multi_signature
 580          * - n_regs_used[i]
 581          * - lex_info
 582          * - vtable_index
 583          * - subid
 584          */
 585
 586         VTABLE_push_integer(INTERP, io, (INTVAL) sub->start_offs);
 587         VTABLE_push_integer(INTERP, io, (INTVAL) sub->end_offs);
 588         VTABLE_push_integer(INTERP, io,
 589             (INTVAL)(PObj_get_FLAGS(pmc) & SUB_FLAG_PF_MASK));
 590
 591         VTABLE_push_string(INTERP, io, sub->name);
 592
 593         if (!sub->method_name)
 594             sub->method_name = CONST_STRING(INTERP, "");
 595         VTABLE_push_string(INTERP, io, sub->method_name);
 596
 597         if (!sub->ns_entry_name)
 598             sub->ns_entry_name = CONST_STRING(INTERP, "");
 599         VTABLE_push_string(INTERP, io, sub->ns_entry_name);
 600
 601         hll_name = Parrot_get_HLL_name(INTERP, sub->HLL_id);
 602         if (!hll_name)
 603             hll_name = CONST_STRING(INTERP, "");
 604         VTABLE_push_string(INTERP, io, hll_name);
 605
 606         VTABLE_push_integer(INTERP, io, (INTVAL)sub->comp_flags);
 607         VTABLE_push_integer(INTERP, io, sub->vtable_index);
 608
 609         for (i = 0; i < 4; ++i)
 610             VTABLE_push_integer(INTERP, io, sub->n_regs_used[i]);
 611
 612         if (!sub->subid)
 613             sub->subid = CONST_STRING(INTERP, "");
 614         VTABLE_push_string(INTERP, io, sub->subid);
 615     }
 616
 617 /*
 618
 619 =item C<void thaw(visit_info *info)>
 620
 621 Unarchives the subroutine.
 622
 623 =cut
 624
 625 */
 626
 627     VTABLE void thaw(visit_info *info) {
 628         IMAGE_IO * const io = info->image_io;
 629         SUPER(info);
 630
 631         if (info->extra_flags == EXTRA_IS_NULL) {
 632             Parrot_Sub_attributes *sub;
 633             INTVAL flags;
 634             int    i;
 635
 636             PMC_get_sub(INTERP, SELF, sub);
 637
 638             /* we get relative offsets */
 639             sub->start_offs   = (size_t) VTABLE_shift_integer(INTERP, io);
 640             sub->end_offs     = (size_t) VTABLE_shift_integer(INTERP, io);
 641             flags             = VTABLE_shift_integer(INTERP, io);
 642
 643             PObj_get_FLAGS(SELF) |= flags & SUB_FLAG_PF_MASK;
 644
 645             sub->name           = VTABLE_shift_string(INTERP, io);
 646             sub->method_name    = VTABLE_shift_string(INTERP, io);
 647             sub->ns_entry_name  = VTABLE_shift_string(INTERP, io);
 648             sub->HLL_id         = Parrot_get_HLL_id(INTERP,
 649                 VTABLE_shift_string(INTERP, io));
 650             sub->comp_flags     = VTABLE_shift_integer(INTERP, io);
 651             sub->vtable_index   = VTABLE_shift_integer(INTERP, io);
 652
 653             for (i = 0; i < 4; ++i)
 654                 sub->n_regs_used[i] = VTABLE_shift_integer(INTERP, io);
 655
 656             sub->subid        = VTABLE_shift_string(INTERP, io);
 657         }
 658     }
 659
 660 /*
 661
 662 =item C<PMC *inspect()>
 663
 664 Returns the full set of meta-data about the sub.
 665
 666 =cut
 667
 668 */
 669
 670     VTABLE PMC *inspect()
 671     {
 672         /* Create a hash, then use inspect_str to get all of the data to
 673          * fill it up with. */
 674         PMC    * const metadata          = pmc_new(interp, enum_class_Hash);
 675         STRING * const pos_required_str  = CONST_STRING(interp, "pos_required");
 676         STRING * const pos_optional_str  = CONST_STRING(interp, "pos_optional");
 677         STRING * const named_required_str = CONST_STRING(interp, "named_required");
 678         STRING * const named_optional_str = CONST_STRING(interp, "named_optional");
 679         STRING * const pos_slurpy_str    = CONST_STRING(interp, "pos_slurpy");
 680         STRING * const named_slurpy_str  = CONST_STRING(interp, "named_slurpy");
 681
 682         VTABLE_set_pmc_keyed_str(interp, metadata, pos_required_str,
 683             VTABLE_inspect_str(interp, SELF, pos_required_str));
 684
 685         VTABLE_set_pmc_keyed_str(interp, metadata, pos_optional_str,
 686             VTABLE_inspect_str(interp, SELF, pos_optional_str));
 687
 688         VTABLE_set_pmc_keyed_str(interp, metadata, named_required_str,
 689             VTABLE_inspect_str(interp, SELF, named_required_str));
 690
 691         VTABLE_set_pmc_keyed_str(interp, metadata, named_optional_str,
 692             VTABLE_inspect_str(interp, SELF, named_optional_str));
 693
 694         VTABLE_set_pmc_keyed_str(interp, metadata, pos_slurpy_str,
 695             VTABLE_inspect_str(interp, SELF, pos_slurpy_str));
 696
 697         VTABLE_set_pmc_keyed_str(interp, metadata, named_slurpy_str,
 698             VTABLE_inspect_str(interp, SELF, named_slurpy_str));
 699
 700         return metadata;
 701     }
 702
 703 /*
 704
 705 =item C<PMC *inspect_str(STRING *what)>
 706
 707 Returns the specified item of metadata about the sub. Allowable
 708 values are:
 709
 710 =over 4
 711
 712 =item pos_required
 713
 714 The number of required positional arguments
 715
 716 =item pos_optional
 717
 718 The number of optional positional arguments
 719
 720 =item named_required
 721
 722 The number of required named arguments
 723
 724 =item named_optional
 725
 726 The number of optional named arguments
 727
 728 =item pos_slurpy
 729
 730 1 if it takes slurpy positional arguments, 0 if not
 731
 732 =item named_slurpy
 733
 734 1 if it takes slurpy named arguments, 0 if not
 735
 736 =back
 737
 738 =cut
 739
 740 */
 741
 742     VTABLE PMC *inspect_str(STRING *what)
 743     {
 744         Parrot_Sub_attributes *sub;
 745         PMC                   *retval;
 746         INTVAL                 count_found = -1;
 747
 748         PMC_get_sub(INTERP, SELF, sub);
 749
 750         /* If the argument info hasn't been generated yet, generate it. */
 751         if (!sub->arg_info) {
 752             /* Get pointer into the bytecode where this sub starts. */
 753             const opcode_t *pc = sub->seg->base.data + sub->start_offs;
 754
 755             /* Allocate structure to store argument information in. */
 756             sub->arg_info = mem_allocate_zeroed_typed(Parrot_sub_arginfo);
 757
 758             /* If the first instruction is a get_params... */
 759             if (*pc == PARROT_OP_get_params_pc) {
 760                 PMC    *sig;
 761                 int     i, sig_length;
 762
 763                 /* Get the signature (the next thing in the bytecode). */
 764                 pc++;
 765                 sig = PF_CONST(sub->seg, *pc)->u.key;
 766                 ASSERT_SIG_PMC(sig);
 767
 768                 /* Iterate over the signature and compute argument counts. */
 769                 sig_length = VTABLE_elements(INTERP, sig);
 770
 771                 for (i = 0; i < sig_length; i++) {
 772                     int sig_item = VTABLE_get_integer_keyed_int(INTERP, sig, i);;
 773                     if (PARROT_ARG_SLURPY_ARRAY_ISSET(sig_item)){
 774                         if (PARROT_ARG_NAME_ISSET(sig_item))
 775                             sub->arg_info->named_slurpy = 1;
 776                         else
 777                             sub->arg_info->pos_slurpy = 1;
 778                     }
 779                     else if (PARROT_ARG_NAME_ISSET(sig_item)) {
 780                         i++;
 781                         sig_item = VTABLE_get_integer_keyed_int(INTERP, sig, i);;
 782                         if (PARROT_ARG_OPTIONAL_ISSET(sig_item))
 783                             sub->arg_info->named_optional++;
 784                         else
 785                             sub->arg_info->named_required++;
 786                     }
 787                     else if (!PARROT_ARG_OPT_FLAG_ISSET(sig_item)) {
 788                         if (PARROT_ARG_OPTIONAL_ISSET(sig_item))
 789                             sub->arg_info->pos_optional++;
 790                         else
 791                             sub->arg_info->pos_required++;
 792                     }
 793                 }
 794             }
 795         }
 796
 797         /* Return the argument information that was requested. */
 798         if (Parrot_str_equal(interp, what, CONST_STRING(interp, "pos_required"))) {
 799             count_found = (INTVAL)sub->arg_info->pos_required;
 800         }
 801         else if (Parrot_str_equal(interp, what, CONST_STRING(interp, "pos_optional"))) {
 802             count_found = (INTVAL)sub->arg_info->pos_optional;
 803         }
 804         else if (Parrot_str_equal(interp, what, CONST_STRING(interp, "pos_slurpy"))) {
 805             count_found = (INTVAL)sub->arg_info->pos_slurpy;
 806         }
 807         else if (Parrot_str_equal(interp, what, CONST_STRING(interp, "named_required"))) {
 808             count_found = (INTVAL)sub->arg_info->named_required;
 809         }
 810         else if (Parrot_str_equal(interp, what, CONST_STRING(interp, "named_optional"))) {
 811             count_found = (INTVAL)sub->arg_info->named_optional;
 812         }
 813         else if (Parrot_str_equal(interp, what, CONST_STRING(interp, "named_slurpy"))) {
 814             count_found = (INTVAL)sub->arg_info->named_slurpy;
 815         }
 816         else {
 817             Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
 818                 "Unknown introspection value '%S'", what);
 819         }
 820
 821         retval = pmc_new(INTERP, enum_class_Integer);
 822         VTABLE_set_integer_native(INTERP, retval, count_found);
 823         return retval;
 824     }
 825
 826 /*
 827
 828 =back
 829
 830 =head2 METHODS
 831
 832 =over 4
 833
 834 =item C<PMC *get_namespace()>
 835
 836 Return the namespace PMC, where the Sub is defined.
 837
 838 TODO return C<namespace_stash> instead.
 839
 840 =item C<INTVAL __get_regs_used(char *kind)>
 841
 842 Return amount of used registers for register kinds "I", "S", "P", "N".
 843
 844 =item C<PMC *get_lexinfo()>
 845
 846 Return the LexInfo PMC, if any or a Null PMC.
 847
 848 =item C<PMC *get_multisig()>
 849
 850 Return the MMD signature PMC, if any or a Null PMC.
 851
 852 =item C<PMC *get_outer()>
 853
 854 Gets the sub that is the outer of this one, if any or a Null PMC.
 855
 856 =item C<void set_outer(PMC *outer)>
 857
 858 Sets the sub that is the outer of this one.
 859
 860 =item C<INTVAL arity()>
 861
 862 Return the arity of the Sub (the number of arguments, excluding optional and
 863 slurpy arguments).
 864
 865 =cut
 866
 867 */
 868
 869     METHOD get_namespace() {
 870         PMC *_namespace;
 871         Parrot_Sub_attributes *sub;
 872         PMC_get_sub(INTERP, SELF, sub);
 873         /*
 874         XXX Rakudo's failing with with this code on ASSERT. Why???
 875         GET_ATTR_namespace_stash(INTERP, SELF, _namespace);
 876         PARROT_ASSERT(_namespace == sub->namespace_stash || !"consistency!!!");
 877         */
 878         _namespace = sub->namespace_stash;
 879         RETURN(PMC *_namespace);
 880     }
 881
 882     METHOD __get_regs_used(STRING *reg) {
 883
 884         /* TODO switch to canonical NiSP order
 885          * see also imcc/reg_alloc.c */
 886         static const char types[] = "INSP";
 887         char *p;
 888         Parrot_Sub_attributes *sub;
 889         char          * const kind = Parrot_str_to_cstring(interp, reg);
 890         INTVAL                regs_used;
 891
 892         PMC_get_sub(INTERP, SELF, sub);
 893         PARROT_ASSERT(sub->n_regs_used);
 894
 895         if (!*kind || kind[1]) {
 896             Parrot_str_free_cstring(kind);
 897             Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_INVALID_OPERATION,
 898                 "illegal register kind '%Ss'", reg);
 899         }
 900
 901         p = strchr(types, *kind);
 902         Parrot_str_free_cstring(kind);
 903
 904         if (!p)
 905             Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_INVALID_OPERATION,
 906                 "illegal register kind '%Ss'", reg);
 907
 908         regs_used = sub->n_regs_used[p - types];
 909         RETURN(INTVAL regs_used);
 910     }
 911
 912     METHOD get_lexinfo() {
 913         PMC        *lexinfo;
 914         Parrot_Sub_attributes *sub;
 915         PMC_get_sub(INTERP, SELF, sub);
 916
 917         lexinfo = sub->lex_info ? sub->lex_info: PMCNULL;
 918
 919         RETURN(PMC *lexinfo);
 920     }
 921
 922     METHOD get_subid() {
 923         STRING     *subid;
 924         Parrot_Sub_attributes *sub;
 925         PMC_get_sub(INTERP, SELF, sub);
 926
 927         subid = sub->subid ? sub->subid : CONST_STRING(interp, "");
 928
 929         RETURN(STRING *subid);
 930     }
 931
 932     METHOD get_outer() {
 933         PMC                   *outersub;
 934         Parrot_Sub_attributes *sub;
 935         PMC_get_sub(INTERP, SELF, sub);
 936
 937         outersub = sub->outer_sub ? sub->outer_sub : PMCNULL;
 938
 939         RETURN(PMC *outersub);
 940     }
 941
 942     METHOD set_outer(PMC *outer) {
 943         /* Set outer sub. */
 944         Parrot_Sub_attributes *sub;
 945         PMC *tmp1, *tmp2;
 946         PMC_get_sub(INTERP, SELF, sub);
 947
 948         sub->outer_sub = outer;
 949
 950         /* Make sure outer flag of that sub is set. */
 951         PObj_get_FLAGS(outer) |= SUB_FLAG_IS_OUTER;
 952
 953         /* Ensure we have lex info. */
 954         if (PMC_IS_NULL(sub->lex_info)) {
 955             const INTVAL lex_info_id = Parrot_get_ctx_HLL_type(interp,
 956                                            enum_class_LexInfo);
 957             sub->lex_info = pmc_new_init(interp, lex_info_id, SELF);
 958         }
 959
 960         /* If we've got a context around for the outer sub, set it as the
 961          * outer context. */
 962
 963         /* XXX This code looks very suspicious. */
 964         /* (CONTEXT(interp)->caller_ctx->caller_ctx->current_sub */
 965         tmp1 = Parrot_pcc_get_caller_ctx(interp, CURRENT_CONTEXT(interp));
 966         tmp2 = Parrot_pcc_get_caller_ctx(interp, tmp1);
 967         if (Parrot_pcc_get_sub(interp, tmp2) == outer)
 968             sub->outer_ctx = tmp2;
 969         /* else if (CONTEXT(interp)->caller_ctx->current_sub == outer) */
 970         else if (Parrot_pcc_get_sub(interp, tmp1) == outer)
 971             sub->outer_ctx = tmp1;
 972     }
 973
 974     METHOD get_multisig() {
 975         PMC                 *multisig;
 976         Parrot_Sub_attributes *sub;
 977         PMC_get_sub(INTERP, SELF, sub);
 978
 979         multisig = sub->multi_signature ? sub->multi_signature : PMCNULL;
 980
 981         RETURN(PMC *multisig);
 982     }
 983
 984     METHOD arity() {
 985         PMC * const pos_required   = VTABLE_inspect_str(interp, SELF, CONST_STRING(interp, "pos_required"));
 986         PMC * const named_required = VTABLE_inspect_str(interp, SELF, CONST_STRING(interp, "named_required"));
 987
 988         const INTVAL arity = VTABLE_get_integer(INTERP, pos_required) +
 989             VTABLE_get_integer(INTERP, named_required);
 990
 991         RETURN(INTVAL arity);
 992     }
 993 }
 994
 995 /*
 996  * Local variables:
 997  *   c-file-style: "parrot"
 998  * End:
 999  * vim: expandtab shiftwidth=4:
1000  */