src/sub.c

   1 /*
   2 Copyright (C) 2001-2006, The Perl Foundation.
   3 $Id$
   4
   5 =head1 NAME
   6
   7 src/sub.c - Subroutines
   8
   9 =head1 DESCRIPTION
  10
  11 Subroutines, continuations, co-routines and other fun stuff...
  12
  13 =head2 Functions
  14
  15 =over 4
  16
  17 =cut
  18
  19 */
  20
  21 #include "parrot/parrot.h"
  22 #include "parrot/oplib/ops.h"
  23
  24 /*
  25
  26 =item C<void
  27 mark_context(Interp* interpreter, parrot_context_t* ctx)>
  28
  29 Marks the context C<*ctx>.
  30
  31 =cut
  32
  33 */
  34
  35 void
  36 mark_context(Interp* interpreter, parrot_context_t* ctx)
  37 {
  38     PObj *obj;
  39     int i;
  40
  41     mark_stack(interpreter, ctx->user_stack);
  42     mark_register_stack(interpreter, ctx->reg_stack);
  43     obj = (PObj*)ctx->current_sub;
  44     if (obj)
  45         pobject_lives(interpreter, obj);
  46     obj = (PObj*)ctx->current_object;
  47     if (obj)
  48         pobject_lives(interpreter, obj);
  49     /* the current continuation in the interpreter has
  50      * to be marked too in the call sequence currently
  51      * as e.g. a MMD search could need resources
  52      * and GC the continuation
  53      */
  54     obj = (PObj*)interpreter->current_cont;
  55     if (obj && obj != NEED_CONTINUATION)
  56         pobject_lives(interpreter, obj);
  57     obj = (PObj*)ctx->current_cont;
  58     if (obj && !PObj_live_TEST(obj))
  59         pobject_lives(interpreter, obj);
  60     obj = (PObj*)ctx->current_method;
  61     if (obj)
  62         pobject_lives(interpreter, obj);
  63     obj = (PObj*)ctx->current_namespace;
  64     if (obj)
  65         pobject_lives(interpreter, obj);
  66     obj = (PObj*)ctx->lex_pad;
  67     if (obj)
  68         pobject_lives(interpreter, obj);
  69     for (i = 0; i < ctx->n_regs_used[REGNO_PMC]; ++i) {
  70         obj = (PObj*) CTX_REG_PMC(ctx, i);
  71         if (obj)
  72             pobject_lives(interpreter, obj);
  73     }
  74     for (i = 0; i < ctx->n_regs_used[REGNO_STR]; ++i) {
  75         obj = (PObj*) CTX_REG_STR(ctx, i);
  76         if (obj)
  77             pobject_lives(interpreter, obj);
  78     }
  79 }
  80
  81 /*
  82
  83 =item C<struct Parrot_sub *
  84 new_sub(Interp *interp)>
  85
  86 Returns a new C<Parrot_sub>.
  87
  88 =cut
  89
  90 */
  91
  92 struct Parrot_sub *
  93 new_sub(Interp *interp)
  94 {
  95     /* Using system memory until I figure out GC issues */
  96     struct Parrot_sub * const newsub =
  97         mem_sys_allocate_zeroed(sizeof(struct Parrot_sub));
  98     newsub->seg = interp->code;
  99     return newsub;
 100 }
 101
 102 /*
 103
 104 =item C<struct Parrot_sub *
 105 new_closure(Interp *interp)>
 106
 107 Returns a new C<Parrot_sub> with its own sctatchpad.
 108
 109 XXX: Need to document semantics in detail.
 110
 111 =cut
 112
 113 */
 114
 115 struct Parrot_sub *
 116 new_closure(Interp *interp)
 117 {
 118     struct Parrot_sub * const newsub = new_sub(interp);
 119     return newsub;
 120 }
 121 /*
 122
 123 =item C<struct Parrot_cont *
 124 new_continuation(Interp *interp, struct Parrot_cont *to)>
 125
 126 Returns a new C<Parrot_cont> to the context of C<to> with its own copy of the
 127 current interpreter context.  If C<to> is C<NULL>, then the C<to_ctx> is set
 128 to the current context.
 129
 130 =cut
 131
 132 */
 133
 134
 135 struct Parrot_cont *
 136 new_continuation(Interp *interp, struct Parrot_cont *to)
 137 {
 138     struct Parrot_cont * const cc =
 139         mem_sys_allocate(sizeof(struct Parrot_cont));
 140     struct Parrot_Context * const to_ctx =
 141         to ? to->to_ctx : CONTEXT(interp->ctx);
 142
 143     cc->to_ctx = to_ctx;
 144     cc->from_ctx = CONTEXT(interp->ctx);
 145     cc->dynamic_state = NULL;
 146     cc->runloop_id = 0;
 147     CONTEXT(interp->ctx)->ref_count++;
 148     if (to) {
 149         cc->seg = to->seg;
 150         cc->address = to->address;
 151     }
 152     else {
 153         cc->seg = interp->code;
 154         cc->address = NULL;
 155     }
 156     cc->current_results = to_ctx->current_results;
 157     return cc;
 158 }
 159
 160 /*
 161
 162 =item C<struct Parrot_cont *
 163 new_ret_continuation(Interp *interp)>
 164
 165 Returns a new C<Parrot_cont> pointing to the current context.
 166
 167 =cut
 168
 169 */
 170
 171 struct Parrot_cont *
 172 new_ret_continuation(Interp *interp)
 173 {
 174     struct Parrot_cont * const cc =
 175         mem_sys_allocate(sizeof(struct Parrot_cont));
 176     cc->to_ctx = CONTEXT(interp->ctx);
 177     cc->from_ctx = NULL;    /* filled in during a call */
 178     cc->dynamic_state = NULL;
 179     cc->runloop_id = 0;
 180     cc->seg = interp->code;
 181     cc->current_results = NULL;
 182     cc->address = NULL;
 183     return cc;
 184 }
 185
 186 /*
 187
 188 =item C<struct Parrot_coro *
 189 new_coroutine(Interp *interp)>
 190
 191 Returns a new C<Parrot_coro>.
 192
 193 XXX: Need to document semantics in detail.
 194
 195 =cut
 196
 197 */
 198
 199 struct Parrot_coro *
 200 new_coroutine(Interp *interp)
 201 {
 202     struct Parrot_coro * const co =
 203         mem_sys_allocate_zeroed(sizeof(struct Parrot_coro));
 204
 205     co->seg = interp->code;
 206     co->ctx = NULL;
 207     co->dynamic_state = NULL;
 208     return co;
 209 }
 210
 211 /*
 212
 213 =item C<PMC *
 214 new_ret_continuation_pmc(Interp * interp, opcode_t * address)>
 215
 216 Returns a new C<RetContinuation> PMC. Uses one from the cache,
 217 if possible; otherwise, creates a new one.
 218
 219 =cut
 220
 221 */
 222
 223 PMC *
 224 new_ret_continuation_pmc(Interp * interpreter, opcode_t * address)
 225 {
 226     PMC* const continuation = pmc_new(interpreter, enum_class_RetContinuation);
 227     VTABLE_set_pointer(interpreter, continuation, address);
 228     return continuation;
 229 }
 230
 231 /*
 232
 233 =item C< void invalidate_retc_context(Interp *, PMC *cont)>
 234
 235 Make true Continuation from all RetContinuations up the call chain.
 236
 237 =cut
 238
 239 */
 240
 241 void
 242 invalidate_retc_context(Interp *interpreter, PMC *cont)
 243 {
 244     struct Parrot_Context *ctx = PMC_cont(cont)->from_ctx;
 245
 246     Parrot_set_context_threshold(interpreter, ctx);
 247     while (1) {
 248         /*
 249          * We  stop if we encounter a true continuation, because
 250          * if one were created, everything up the chain would have been
 251          * invalidated earlier.
 252          */
 253         if (cont->vtable != interpreter->vtables[enum_class_RetContinuation])
 254             break;
 255         cont->vtable = interpreter->vtables[enum_class_Continuation];
 256         ctx->ref_count++;
 257         cont = ctx->current_cont;
 258         ctx = PMC_cont(cont)->from_ctx;
 259     }
 260
 261 }
 262
 263 /*
 264
 265 =item C<Parrot_full_sub_name>
 266
 267 Return namespace, name, and location of subroutine.
 268
 269 =cut
 270
 271 */
 272
 273 /* XXX use method lookup - create interface
 274  *                         see also pbc.c
 275  */
 276 extern PMC* Parrot_NameSpace_name(Interp* interpreter, PMC* pmc);
 277
 278 STRING*
 279 Parrot_full_sub_name(Interp* interpreter, PMC* sub)
 280 {
 281     struct Parrot_sub * s;
 282     STRING *res;
 283
 284
 285     if (!sub || !VTABLE_defined(interpreter, sub))
 286         return NULL;
 287     s = PMC_sub(sub);
 288     if (PMC_IS_NULL(s->namespace_stash)) {
 289         return s->name;
 290     }
 291     else {
 292         PMC *ns_array;
 293         STRING *j;
 294
 295         Parrot_block_DOD(interpreter);
 296         ns_array = Parrot_NameSpace_name(interpreter, s->namespace_stash);
 297         if (s->name) {
 298             VTABLE_push_string(interpreter, ns_array, s->name);
 299         }
 300         j = const_string(interpreter, ";");
 301
 302         res =  string_join(interpreter, j, ns_array);
 303         Parrot_unblock_DOD(interpreter);
 304         return res;
 305     }
 306     return NULL;
 307 }
 308
 309 int
 310 Parrot_Context_info(Interp *interpreter, parrot_context_t *ctx,
 311                     struct Parrot_Context_info *info)
 312 {
 313     struct Parrot_sub *sub;
 314
 315     /* set file/line/pc defaults */
 316     info->file = "(unknown file)";
 317     info->line = -1;
 318     info->pc = -1;
 319     info->nsname = NULL;
 320     info->subname = NULL;
 321     info->fullname = NULL;
 322
 323     /* is the current sub of the specified context valid? */
 324     if (PMC_IS_NULL(ctx->current_sub)) {
 325         info->subname = string_from_cstring(interpreter, "???", 3);
 326         info->nsname = info->subname;
 327         info->fullname = string_from_cstring(interpreter, "??? :: ???", 10);
 328         info->pc = -1;
 329         return 0;
 330     }
 331
 332     /* fetch struct Parrot_sub of the current sub in the given context */
 333     if (!VTABLE_isa(interpreter, ctx->current_sub,
 334                     const_string(interpreter, "Sub")))
 335         return 1;
 336
 337     sub = PMC_sub(ctx->current_sub);
 338     /* set the sub name */
 339     info->subname = sub->name;
 340
 341     /* set the namespace name and fullname of the sub */
 342     if (PMC_IS_NULL(sub->namespace)) {
 343         info->nsname = string_from_cstring(interpreter, "", 0);
 344         info->fullname = info->subname;
 345     }
 346     else {
 347         info->nsname = VTABLE_get_string(interpreter, sub->namespace);
 348         info->fullname = Parrot_full_sub_name(interpreter, ctx->current_sub);
 349     }
 350
 351     /* return here if there is no current pc */
 352     if (ctx->current_pc == NULL)
 353         return 1;
 354
 355     /* calculate the current pc */
 356     info->pc = ctx->current_pc - sub->seg->base.data;
 357
 358     /* determine the current source file/line */
 359     if (ctx->current_pc) {
 360         size_t offs = info->pc;
 361         size_t i, n;
 362         opcode_t *pc = sub->seg->base.data;
 363         struct PackFile_Debug *debug = sub->seg->debugs;
 364         if (!debug)
 365             return 0;
 366         for (i = n = 0; n < sub->seg->base.size; i++) {
 367             op_info_t *op_info = &interpreter->op_info_table[*pc];
 368             opcode_t var_args = 0;
 369             if (i >= debug->base.size)
 370                 return 0;
 371             if (n >= offs) {
 372                 /* set source line and file */
 373                 info->line = debug->base.data[i];
 374                 info->file = string_to_cstring(interpreter,
 375                 Parrot_debug_pc_to_filename(interpreter, debug, i));
 376                 break;
 377             }
 378             ADD_OP_VAR_PART(interpreter, sub->seg, pc, var_args);
 379             n += op_info->op_count + var_args;
 380             pc += op_info->op_count + var_args;
 381         }
 382     }
 383     return 1;
 384 }
 385
 386 STRING*
 387 Parrot_Context_infostr(Interp *interpreter, parrot_context_t *ctx)
 388 {
 389     struct Parrot_Context_info info;
 390     const char* const msg = (CONTEXT(interpreter->ctx) == ctx) ?
 391         "current instr.:":
 392         "called from Sub";
 393     STRING *res;
 394
 395     Parrot_block_DOD(interpreter);
 396     if (Parrot_Context_info(interpreter, ctx, &info)) {
 397         res = Parrot_sprintf_c(interpreter,
 398             "%s '%Ss' pc %d (%s:%d)", msg,
 399             info.fullname, info.pc, info.file, info.line);
 400     }
 401     else
 402         res = NULL;
 403     Parrot_unblock_DOD(interpreter);
 404     return res;
 405 }
 406
 407 /*
 408
 409 =item C<PMC* Parrot_find_pad(Interp*, STRING *lex_name)>
 410
 411 Locate the LexPad containing the given name. Return NULL on failure.
 412
 413 =cut
 414
 415 */
 416
 417 PMC*
 418 Parrot_find_pad(Interp* interpreter, STRING *lex_name, parrot_context_t *ctx)
 419 {
 420     while (1) {
 421         PMC * const lex_pad = ctx->lex_pad;
 422         parrot_context_t * const outer = ctx->outer_ctx;
 423
 424         if (!outer)
 425             return lex_pad;
 426         if (!PMC_IS_NULL(lex_pad)) {
 427             if (VTABLE_exists_keyed_str(interpreter, lex_pad, lex_name))
 428                 return lex_pad;
 429         }
 430 #if CTX_LEAK_DEBUG
 431         if (outer == ctx) {
 432             /* This is a bug; a context can never be its own :outer context.
 433              * Detecting it avoids an unbounded loop, which is difficult to
 434              * debug, though we'd rather not pay the cost of detection in a
 435              * production release.
 436              */
 437             real_exception(interpreter, NULL, INVALID_OPERATION,
 438                            "Bug:  Context %p :outer points back to itself.",
 439                            ctx);
 440         }
 441 #endif
 442         ctx = outer;
 443     }
 444     return NULL;
 445 }
 446
 447 PMC*
 448 parrot_new_closure(Interp *interpreter, PMC *sub_pmc)
 449 {
 450     PMC *clos_pmc;
 451     struct Parrot_sub *clos, *sub;
 452     PMC *cont;
 453     parrot_context_t *ctx;
 454
 455     clos_pmc = VTABLE_clone(interpreter, sub_pmc);
 456     sub = PMC_sub(sub_pmc);
 457     clos = PMC_sub(clos_pmc);
 458     /*
 459      * the given sub_pmc has to have an :outer(sub) that is
 460      * this subroutine
 461      */
 462     ctx = CONTEXT(interpreter->ctx);
 463     if (PMC_IS_NULL(sub->outer_sub)) {
 464         real_exception(interpreter, NULL, INVALID_OPERATION,
 465                 "'%Ss' isn't a closure (no :outer)", sub->name);
 466     }
 467     /* if (sub->outer_sub != ctx->current_sub) - fails if outer
 468      * is a closure too e.g. test 'closure 4'
 469      */
 470     if (0 == string_equal(interpreter,
 471                 (PMC_sub(ctx->current_sub))->name,
 472                 sub->name)) {
 473         real_exception(interpreter, NULL, INVALID_OPERATION,
 474                 "'%Ss' isn't the :outer of '%Ss')",
 475                 (PMC_sub(ctx->current_sub))->name,
 476                 sub->name);
 477     }
 478     cont = ctx->current_cont;
 479     /* preserve this frame by converting the continuation */
 480     cont->vtable = interpreter->vtables[enum_class_Continuation];
 481     /* remember this (the :outer) ctx in the closure */
 482     clos->outer_ctx = ctx;
 483     /* the closure refs now this context too */
 484     ctx->ref_count++;
 485 #if CTX_LEAK_DEBUG
 486     if (Interp_debug_TEST(interpreter, PARROT_CTX_DESTROY_DEBUG_FLAG)) {
 487         fprintf(stderr, "[alloc closure  %p, outer_ctx %p, ref_count=%d]\n",
 488                 clos_pmc, ctx, (int) ctx->ref_count);
 489     }
 490 #endif
 491     return clos_pmc;
 492 }
 493 /*
 494
 495 =back
 496
 497 =head1 SEE ALSO
 498
 499 F<include/parrot/sub.h>.
 500
 501 =head1 HISTORY
 502
 503 Initial version by Melvin on 2002/06/6.
 504
 505 =cut
 506
 507 */
 508
 509
 510 /*
 511  * Local variables:
 512  *   c-file-style: "parrot"
 513  * End:
 514  * vim: expandtab shiftwidth=4:
 515  */