src/pmc/sub.pmc

   1 /*
   2 Copyright (C) 2001-2007, The Perl 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/parrot.h"
  22 #include "parrot/oplib/ops.h"
  23 #include "sub.str"
  24 #include <assert.h>
  25
  26 static void
  27 print_sub_name(Interp* interp, PMC* sub)
  28 {
  29     Interp * const tracer =
  30         interp->debugger ? interp->debugger : interp;
  31
  32         /* sub was located via globals */
  33     PIO_eprintf(tracer, "# Calling sub '%Ss'\n# ",
  34         Parrot_full_sub_name(interp, sub));
  35     print_pbc_location(interp);
  36 }
  37
  38 /*
  39  * A sub now contains more data like namespace, which makes it
  40  * effectively a container. Therefore need_ext has to be set
  41  */
  42 pmclass Sub need_ext {
  43
  44 /*
  45
  46 =item C<void init()>
  47
  48 Initializes the subroutine.
  49
  50 =cut
  51
  52 */
  53
  54     /*
  55      * Sub PMC's flags usage:
  56      * - private0 ... Coroutine flip/flop - C exception handler
  57      * - private1 ... _IS_OUTER - have to preserve context
  58      *                as some other sub has :outer(this)
  59      * - private2 ... tailcall invoked this Sub
  60      * - private3 ... pythonic coroutine generator flag
  61      * - private4 ... :main (see @MAIN)
  62      * - private5 ... :load (see @LOAD)
  63      * - private6 ... :immediate (see @IMMEDIATE)
  64      * - private7 ... :postcomp (see @POSTCOMP)
  65      *
  66      * see also the enum in include/parrot/sub.h
  67      *
  68      * Data used:
  69      *   PMC_struct_val ... Parrot_sub structure
  70      *   PMC_pmc_val    ... unused / bound object in Bound_Meth PMC
  71      */
  72     void init() {
  73         PMC_struct_val(SELF) = new_sub(INTERP);
  74         PMC_pmc_val(SELF) = NULL;
  75         PObj_custom_mark_destroy_SETALL(SELF);
  76 #if 0
  77         if (Interp_flags_TEST(INTERP, PARROT_DEBUG_FLAG))
  78             printf("Address of base segment is %p\n",
  79                 ((struct Parrot_sub *)PMC_sub(SELF))->seg->base.pf->base.data);
  80 #endif
  81     }
  82
  83 /*
  84
  85 =item C<void destroy()>
  86
  87 Destroys the subroutine.
  88
  89 =cut
  90
  91 */
  92
  93     void destroy() {
  94         struct Parrot_sub * const sub = PMC_sub(SELF);
  95         if (!sub)
  96             return;
  97 #if 0
  98         {
  99             STRING *n = Parrot_full_sub_name(INTERP, SELF);
 100             fprintf(stderr, "DESTROY sub %p %s\n", SELF,
 101                     n && n->strstart ? (char*)n->strstart : "???");
 102         }
 103 #endif
 104         mem_sys_free(sub);
 105         PMC_struct_val(SELF) = NULL;
 106     }
 107
 108 /*
 109
 110 =item C<STRING *get_string()>
 111
 112 Returns the name of the subroutine.
 113
 114 =item C<void set_string_native(STRING *subname)>
 115
 116 Sets the name of the subroutine.
 117
 118 =cut
 119
 120 */
 121
 122     STRING* get_string() {
 123         const struct Parrot_sub * const sub = PMC_sub(SELF);
 124         return Parrot_make_COW_reference(INTERP, sub->name);
 125     }
 126
 127     void set_string_native(STRING *subname) {
 128         struct Parrot_sub * const sub = PMC_sub(SELF);
 129         sub->name = string_copy(INTERP, subname);
 130     }
 131
 132 /*
 133
 134 =item C<void set_pointer(void *value)>
 135
 136 Sets the pointer to the actual subroutine.
 137
 138 *** Don't use that - use .Sub constants instead ***
 139
 140 =cut
 141
 142 */
 143
 144     void set_pointer(void* value) {
 145         real_exception(INTERP, NULL, E_NotImplementedError,
 146                 "Don't set the address of a sub\n"
 147                 "use .Sub constants instead");
 148     }
 149
 150 /*
 151
 152 =item C<void *get_pointer()>
 153
 154 Returns the address of the actual subroutine.
 155
 156 =cut
 157
 158 */
 159
 160     void* get_pointer() {
 161         const struct Parrot_sub * const sub = PMC_sub(SELF);
 162         return sub->seg->base.data + sub->start_offs;
 163     }
 164
 165 /*
 166
 167 =item C<INTVAL get_integer_keyed(PMC *key)>
 168
 169 I<This just unconditionally returns the start of bytecode. It's wrong,
 170 wrong, wrong, *WRONG*. And there's no other good way, so it's here for
 171 now.> -DRS
 172
 173 =cut
 174
 175 */
 176
 177     INTVAL get_integer_keyed(PMC* key) {
 178         return (INTVAL) ((PMC_sub(SELF))->seg->base.data);
 179     }
 180
 181 /*
 182
 183 =item C<INTVAL defined()>
 184
 185 =item C<INTVAL get_bool()>
 186
 187 Returns True.
 188
 189 =cut
 190
 191 */
 192
 193     INTVAL defined() {
 194         return 1;
 195     }
 196
 197     INTVAL get_bool() {
 198         return 1;
 199     }
 200
 201 /*
 202
 203 =item C<opcode_t *invoke(void *next)>
 204
 205 Invokes the subroutine.
 206
 207 =cut
 208
 209 */
 210
 211     opcode_t* invoke(void *next) {
 212         struct Parrot_sub     * const sub = PMC_sub(SELF);
 213         parrot_context_t      *caller_ctx;
 214         Parrot_Context        *context;
 215         PMC                   *ccont;
 216         opcode_t              *pc;
 217
 218         if (Interp_trace_TEST(INTERP, PARROT_TRACE_SUB_CALL_FLAG))
 219             print_sub_name(INTERP, SELF);
 220
 221         /*
 222          * A remark WRT tail calls
 223          *
 224          * we have:
 225          * sub A:
 226          *    ...
 227          *    B()
 228          *    ...
 229          * sub B:
 230          *    ...
 231          *    .return C(...)
 232          *
 233          * that is the sub B() returns whatever C() returns.
 234          *
 235          * We are just calling the sub C().
 236          * If the private2 flag is set, this code is called by a
 237          * tailcall opcode.
 238          *
 239          * We allocate a new register frame and recycle it
 240          * immediately after argument passing.
 241          *
 242          */
 243         pc                   = sub->seg->base.data + sub->start_offs;
 244         caller_ctx           = CONTEXT(INTERP->ctx);
 245         ccont                = INTERP->current_cont;
 246         INTERP->current_cont = NULL;
 247
 248         if (ccont == NEED_CONTINUATION)
 249             ccont = new_ret_continuation_pmc(interp, (opcode_t *)next);
 250
 251         assert(!PMC_IS_NULL(ccont));
 252
 253         /*
 254          * plain subroutine call
 255          * create new context, place it in interpreter
 256          */
 257 #define PREMATURE_OPT
 258 #ifdef PREMATURE_OPT
 259         if (caller_ctx->current_sub == SELF)
 260             context = Parrot_dup_context(INTERP, caller_ctx);
 261         else
 262 #endif
 263         context               = Parrot_alloc_context(INTERP, sub->n_regs_used);
 264         context->current_sub  = SELF;
 265         context->caller_ctx   = caller_ctx;
 266         context->current_pc   = pc;
 267         context->current_cont = ccont;
 268
 269         /* check recursion/call depth */
 270         if (++context->recursion_depth >
 271                 INTERP->recursion_limit) {
 272             real_exception(INTERP, next, E_RuntimeError,
 273                     "maximum recursion depth exceeded");
 274         }
 275
 276         /* and copy set context variables */
 277         PMC_cont(ccont)->from_ctx = context;
 278
 279         /* set context of the sub */
 280         sub->ctx = context;
 281
 282         /* don't destroy context */
 283         if (PObj_get_FLAGS(SELF) & SUB_FLAG_IS_OUTER)
 284             ccont->vtable = interp->vtables[enum_class_Continuation];
 285
 286         /* reference counting should work */
 287         context->ref_count++;
 288
 289         if (!PMC_IS_NULL(INTERP->current_object)) {
 290             context->current_object = INTERP->current_object;
 291             INTERP->current_object = NULL;
 292         }
 293
 294         context->current_HLL       = sub->HLL_id;
 295         context->current_namespace = sub->namespace_stash;
 296
 297         /* create pad if needed
 298          * TODO move this up in front of argument passing
 299          *      and factor out common code with coroutine pmc
 300          */
 301         if (!PMC_IS_NULL(sub->lex_info)) {
 302             context->lex_pad = pmc_new_init(INTERP,
 303                     Parrot_get_ctx_HLL_type(interp,
 304                         enum_class_LexPad),
 305                     sub->lex_info);
 306             VTABLE_set_pointer(INTERP, context->lex_pad, context);
 307         }
 308
 309         /* switch code segment if needed */
 310         if (INTERP->code != sub->seg)
 311             Parrot_switch_to_cs(INTERP, sub->seg, 1);
 312
 313         if (PObj_get_FLAGS(ccont) & SUB_FLAG_TAILCALL) {
 314             if (!(*pc == PARROT_OP_get_params_pc ||
 315                         (*pc == PARROT_OP_push_eh_ic &&
 316                          pc[2] == PARROT_OP_get_params_pc))) {
 317
 318                 /* TODO keep it or resize it */
 319                 --context->recursion_depth;
 320
 321                 PObj_get_FLAGS(ccont) &= ~SUB_FLAG_TAILCALL;
 322                 context->caller_ctx    = caller_ctx->caller_ctx;
 323
 324                 Parrot_free_context(INTERP, caller_ctx, 0);
 325             }
 326         }
 327
 328         return pc;
 329     }
 330
 331 /*
 332
 333 =item C<PMC *clone()>
 334
 335 Creates and returns a clone of the subroutine.
 336
 337 =cut
 338
 339 */
 340
 341     PMC* clone() {
 342         struct Parrot_sub *sub;
 343         PMC * const ret = pmc_new_noinit(INTERP, SELF->vtable->base_type);
 344
 345         /* we have to mark it ourselves */
 346         PObj_custom_mark_destroy_SETALL(ret);
 347         sub = mem_allocate_typed(struct Parrot_sub);
 348
 349         /* first set the sub struct, string_copy may cause GC */
 350         PMC_struct_val(ret) = sub;
 351         PMC_pmc_val(ret)    = NULL;
 352         memcpy(sub, PMC_sub(SELF), sizeof (struct Parrot_sub));
 353         sub->name           = string_copy(INTERP, sub->name);
 354
 355         return ret;
 356     }
 357
 358 /*
 359
 360 =item C<void assign_pmc(PMC* other)>
 361
 362 Set SELF to the data in other.
 363
 364 =cut
 365
 366 */
 367
 368     void set_pmc(PMC* other) {
 369         DYNSELF.assign_pmc(other);
 370     }
 371
 372     void assign_pmc(PMC* other) {
 373         /* only handle the case where the other PMC is the same type */
 374         if (other->vtable->base_type == SELF->vtable->base_type) {
 375             /* copy the sub struct */
 376             memcpy(PMC_sub(SELF), PMC_sub(other), sizeof (struct Parrot_sub));
 377             /* copy the name so it's a different string in memory */
 378             PMC_sub(SELF)->name = string_copy(INTERP, PMC_sub(SELF)->name);
 379         }
 380         else {
 381             real_exception(INTERP, NULL, E_TypeError,
 382                            "Can't assign a non-Sub type to a Sub");
 383         }
 384     }
 385
 386 /*
 387
 388 =item C<void mark()>
 389
 390 Marks the sub as live.
 391
 392 =cut
 393
 394 */
 395
 396     void mark() {
 397         const struct Parrot_sub * const sub = PMC_sub(SELF);
 398         if (!sub)
 399             return;
 400         if (sub->name)
 401             pobject_lives(INTERP, (PObj *) sub->name);
 402         if (!PMC_IS_NULL(sub->namespace_name))
 403             pobject_lives(INTERP, (PObj *) sub->namespace_name);
 404         if (!PMC_IS_NULL(sub->multi_signature))
 405             pobject_lives(INTERP, (PObj *) sub->multi_signature);
 406         if (!PMC_IS_NULL(sub->eval_pmc))
 407             pobject_lives(INTERP, (PObj *) sub->eval_pmc);
 408     }
 409
 410 /*
 411
 412 =item C<INTVAL is_equal(PMC *value)>
 413
 414 Returns whether the two subroutines are equal.
 415
 416 =cut
 417
 418 */
 419
 420     INTVAL is_equal(PMC* value) {
 421         return SELF->vtable == value->vtable &&
 422             (PMC_sub(SELF))->start_offs == (PMC_sub(value))->start_offs &&
 423             (PMC_sub(SELF))->seg == (PMC_sub(value))->seg;
 424     }
 425
 426 /*
 427
 428 =item C<void visit(visit_info *info)>
 429
 430 This is used by freeze/thaw to visit the contents of the sub.
 431
 432 =item C<void freeze(visit_info *info)>
 433
 434 Archives the subroutine.
 435
 436 =cut
 437
 438 */
 439
 440     void visit(visit_info *info) {
 441         struct Parrot_sub * const sub = PMC_sub(SELF);
 442
 443         info->thaw_ptr = &sub->namespace_name;
 444         (info->visit_pmc_now)(INTERP, sub->namespace_name, info);
 445         info->thaw_ptr = &sub->multi_signature;
 446         (info->visit_pmc_now)(INTERP, sub->multi_signature, info);
 447         info->thaw_ptr = &sub->outer_sub;
 448         (info->visit_pmc_now)(INTERP, sub->outer_sub, info);
 449         /*
 450          * XXX visit_pmc_now is wrong, because it breaks
 451          *     depth-first visit inside the todo list
 452          * TODO change all user visit functions to use
 453          *    visit_pmc (the todo renamed visit_pm_later)
 454          *
 455          * Therefore the hash must be last during visit for now.
 456          */
 457         info->thaw_ptr = &sub->lex_info;
 458         (info->visit_pmc_now)(INTERP, sub->lex_info, info);
 459         SUPER(info);
 460     }
 461
 462     void freeze(visit_info *info) {
 463         IMAGE_IO * const io = info->image_io;
 464         struct Parrot_sub * const sub = PMC_sub(SELF);
 465         int i;
 466
 467         SUPER(info);
 468         /*
 469          * we currently need to write these items:
 470          * - start offset in byte-code segment
 471          * - end   offset in byte-code segment
 472          * - segment TODO ???
 473          * - flags  (i.e. :load pragma and such)
 474          * - name of the sub's label
 475          * - namespace
 476          * - HLL_id
 477          * - multi_signature
 478          * - n_regs_used[i]
 479          * - lex_info
 480          * - vtable_index
 481          */
 482
 483         io->vtable->push_integer(INTERP, io, (INTVAL) sub->start_offs);
 484         io->vtable->push_integer(INTERP, io, (INTVAL) sub->end_offs);
 485         io->vtable->push_integer(INTERP, io, PObj_get_FLAGS(pmc) & SUB_FLAG_PF_MASK);
 486         io->vtable->push_string(INTERP, io, sub->name);
 487         io->vtable->push_integer(INTERP, io, sub->HLL_id);
 488         io->vtable->push_integer(INTERP, io, sub->comp_flags);
 489         io->vtable->push_integer(INTERP, io, sub->vtable_index);
 490         for (i = 0; i < 4; ++i)
 491             io->vtable->push_integer(INTERP, io, sub->n_regs_used[i]);
 492     }
 493
 494 /*
 495
 496 =item C<void thaw(visit_info *info)>
 497
 498 Unarchives the subroutine.
 499
 500 =cut
 501
 502 */
 503
 504     void thaw(visit_info *info) {
 505         IMAGE_IO * const io = info->image_io;
 506         SUPER(info);
 507
 508         if (info->extra_flags == EXTRA_IS_NULL) {
 509             struct Parrot_sub * const sub = PMC_sub(SELF);
 510             INTVAL flags;
 511             int i;
 512             /*
 513              * we get relative offsets
 514              */
 515             sub->start_offs = (size_t) io->vtable->shift_integer(INTERP, io);
 516             sub->end_offs   = (size_t) io->vtable->shift_integer(INTERP, io);
 517             flags = io->vtable->shift_integer(INTERP, io);
 518             PObj_get_FLAGS(SELF) |= flags & SUB_FLAG_PF_MASK;
 519             sub->name = io->vtable->shift_string(INTERP, io);
 520             sub->HLL_id  = io->vtable->shift_integer(INTERP, io);
 521             sub->comp_flags = io->vtable->shift_integer(INTERP, io);
 522             sub->vtable_index = io->vtable->shift_integer(INTERP, io);
 523             for (i = 0; i < 4; ++i)
 524                 sub->n_regs_used[i] = io->vtable->shift_integer(INTERP, io);
 525         }
 526     }
 527
 528 /*
 529
 530 =back
 531
 532 =head2 METHODS
 533
 534 =over 4
 535
 536 =item C<METHOD PMC* get_namespace()>
 537
 538 Return the namespace PMC, where the Sub is defined.
 539
 540 TODO return C<namespace_stash> instead.
 541
 542 =item C<METHOD INTVAL __get_regs_used(char *kind)>
 543
 544 Return amount of used registers for register kinds "I", "S", "P", "N".
 545
 546 =item C<METHOD PMC* get_lexinfo()>
 547
 548 Return the LexInfo PMC, if any or a Null PMC.
 549
 550 =item C<METHOD PMC* get_multisig()>
 551
 552 Return the MMD signature PMC, if any or a Null PMC.
 553
 554 =cut
 555
 556 */
 557
 558
 559     METHOD PMC* get_namespace() {
 560         struct Parrot_sub * const sub = PMC_sub(SELF);
 561
 562         return sub->namespace_stash;
 563     }
 564
 565     METHOD INTVAL __get_regs_used(char *kind) {
 566         struct Parrot_sub * const sub = PMC_sub(SELF);
 567         /* TODO switch to canonical NiSP order
 568          * see also imcc/reg_alloc.c
 569          */
 570         static const char types[] = "INSP";
 571         char *p;
 572
 573         assert(sub->n_regs_used);
 574         if (!*kind || kind[1])
 575             real_exception(INTERP, NULL, E_ValueError,
 576                 "illegal register kind '%s'", kind);
 577         p = strchr(types, *kind);
 578         if (!p)
 579             real_exception(INTERP, NULL, E_ValueError,
 580                 "illegal register kind '%s'", kind);
 581         return sub->n_regs_used[p - types];
 582     }
 583
 584     METHOD PMC* get_lexinfo() {
 585         const struct Parrot_sub * const sub = PMC_sub(SELF);
 586         return sub->lex_info ? sub->lex_info : PMCNULL;
 587     }
 588
 589     METHOD PMC* get_outer() {
 590         const struct Parrot_sub * const sub = PMC_sub(SELF);
 591         return sub->outer_sub ? sub->outer_sub : PMCNULL;
 592     }
 593
 594     METHOD PMC* get_multisig() {
 595         const struct Parrot_sub * const sub = PMC_sub(SELF);
 596         return sub->multi_signature ? sub->multi_signature : PMCNULL;
 597     }
 598 }
 599
 600 /*
 601
 602 =back
 603
 604 =head1 HISTORY
 605
 606 Initial version by Melvin on 2002/06/06.
 607
 608 =cut
 609
 610 */
 611
 612 /*
 613  * Local variables:
 614  *   c-file-style: "parrot"
 615  * End:
 616  * vim: expandtab shiftwidth=4:
 617  */