src/pmc/sub.pmc

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