2 Copyright (C) 2001-2006, The Perl Foundation.
7 src/sub.c - Subroutines
11 Subroutines, continuations, co-routines and other fun stuff...
21 #include "parrot/parrot.h"
22 #include "parrot/oplib/ops.h"
27 mark_context(Interp* interpreter, parrot_context_t* ctx)>
29 Marks the context C<*ctx>.
36 mark_context(Interp
* interpreter
, parrot_context_t
* ctx
)
41 mark_stack(interpreter
, ctx
->user_stack
);
42 mark_register_stack(interpreter
, ctx
->reg_stack
);
43 obj
= (PObj
*)ctx
->current_sub
;
45 pobject_lives(interpreter
, obj
);
46 obj
= (PObj
*)ctx
->current_object
;
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
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
;
62 pobject_lives(interpreter
, obj
);
63 obj
= (PObj
*)ctx
->current_namespace
;
65 pobject_lives(interpreter
, obj
);
66 obj
= (PObj
*)ctx
->lex_pad
;
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
);
72 pobject_lives(interpreter
, obj
);
74 for (i
= 0; i
< ctx
->n_regs_used
[REGNO_STR
]; ++i
) {
75 obj
= (PObj
*) CTX_REG_STR(ctx
, i
);
77 pobject_lives(interpreter
, obj
);
83 =item C<struct Parrot_sub *
84 new_sub(Interp *interp)>
86 Returns a new C<Parrot_sub>.
93 new_sub(Interp
*interp
)
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
;
104 =item C<struct Parrot_sub *
105 new_closure(Interp *interp)>
107 Returns a new C<Parrot_sub> with its own sctatchpad.
109 XXX: Need to document semantics in detail.
116 new_closure(Interp
*interp
)
118 struct Parrot_sub
* const newsub
= new_sub(interp
);
123 =item C<struct Parrot_cont *
124 new_continuation(Interp *interp, struct Parrot_cont *to)>
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.
136 new_continuation(Interp
*interp
, struct Parrot_cont
*to
)
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
);
144 cc
->from_ctx
= CONTEXT(interp
->ctx
);
145 cc
->dynamic_state
= NULL
;
147 CONTEXT(interp
->ctx
)->ref_count
++;
150 cc
->address
= to
->address
;
153 cc
->seg
= interp
->code
;
156 cc
->current_results
= to_ctx
->current_results
;
162 =item C<struct Parrot_cont *
163 new_ret_continuation(Interp *interp)>
165 Returns a new C<Parrot_cont> pointing to the current context.
172 new_ret_continuation(Interp
*interp
)
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
;
180 cc
->seg
= interp
->code
;
181 cc
->current_results
= NULL
;
188 =item C<struct Parrot_coro *
189 new_coroutine(Interp *interp)>
191 Returns a new C<Parrot_coro>.
193 XXX: Need to document semantics in detail.
200 new_coroutine(Interp
*interp
)
202 struct Parrot_coro
* const co
=
203 mem_sys_allocate_zeroed(sizeof(struct Parrot_coro
));
205 co
->seg
= interp
->code
;
207 co
->dynamic_state
= NULL
;
214 new_ret_continuation_pmc(Interp * interp, opcode_t * address)>
216 Returns a new C<RetContinuation> PMC. Uses one from the cache,
217 if possible; otherwise, creates a new one.
224 new_ret_continuation_pmc(Interp
* interpreter
, opcode_t
* address
)
226 PMC
* const continuation
= pmc_new(interpreter
, enum_class_RetContinuation
);
227 VTABLE_set_pointer(interpreter
, continuation
, address
);
233 =item C< void invalidate_retc_context(Interp *, PMC *cont)>
235 Make true Continuation from all RetContinuations up the call chain.
242 invalidate_retc_context(Interp
*interpreter
, PMC
*cont
)
244 struct Parrot_Context
*ctx
= PMC_cont(cont
)->from_ctx
;
246 Parrot_set_context_threshold(interpreter
, ctx
);
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.
253 if (cont
->vtable
!= interpreter
->vtables
[enum_class_RetContinuation
])
255 cont
->vtable
= interpreter
->vtables
[enum_class_Continuation
];
257 cont
= ctx
->current_cont
;
258 ctx
= PMC_cont(cont
)->from_ctx
;
265 =item C<Parrot_full_sub_name>
267 Return namespace, name, and location of subroutine.
273 /* XXX use method lookup - create interface
276 extern PMC
* Parrot_NameSpace_name(Interp
* interpreter
, PMC
* pmc
);
279 Parrot_full_sub_name(Interp
* interpreter
, PMC
* sub
)
281 struct Parrot_sub
* s
;
285 if (!sub
|| !VTABLE_defined(interpreter
, sub
))
288 if (PMC_IS_NULL(s
->namespace_stash
)) {
295 Parrot_block_DOD(interpreter
);
296 ns_array
= Parrot_NameSpace_name(interpreter
, s
->namespace_stash
);
298 VTABLE_push_string(interpreter
, ns_array
, s
->name
);
300 j
= const_string(interpreter
, ";");
302 res
= string_join(interpreter
, j
, ns_array
);
303 Parrot_unblock_DOD(interpreter
);
310 Parrot_Context_info(Interp
*interpreter
, parrot_context_t
*ctx
,
311 struct Parrot_Context_info
*info
)
313 struct Parrot_sub
*sub
;
315 /* set file/line/pc defaults */
316 info
->file
= "(unknown file)";
320 info
->subname
= NULL
;
321 info
->fullname
= NULL
;
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);
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")))
337 sub
= PMC_sub(ctx
->current_sub
);
338 /* set the sub name */
339 info
->subname
= sub
->name
;
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
;
347 info
->nsname
= VTABLE_get_string(interpreter
, sub
->namespace);
348 info
->fullname
= Parrot_full_sub_name(interpreter
, ctx
->current_sub
);
351 /* return here if there is no current pc */
352 if (ctx
->current_pc
== NULL
)
355 /* calculate the current pc */
356 info
->pc
= ctx
->current_pc
- sub
->seg
->base
.data
;
358 /* determine the current source file/line */
359 if (ctx
->current_pc
) {
360 size_t offs
= info
->pc
;
362 opcode_t
*pc
= sub
->seg
->base
.data
;
363 struct PackFile_Debug
*debug
= sub
->seg
->debugs
;
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
)
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
));
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
;
387 Parrot_Context_infostr(Interp
*interpreter
, parrot_context_t
*ctx
)
389 struct Parrot_Context_info info
;
390 const char* const msg
= (CONTEXT(interpreter
->ctx
) == ctx
) ?
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
);
403 Parrot_unblock_DOD(interpreter
);
409 =item C<PMC* Parrot_find_pad(Interp*, STRING *lex_name)>
411 Locate the LexPad containing the given name. Return NULL on failure.
418 Parrot_find_pad(Interp
* interpreter
, STRING
*lex_name
, parrot_context_t
*ctx
)
421 PMC
* const lex_pad
= ctx
->lex_pad
;
422 parrot_context_t
* const outer
= ctx
->outer_ctx
;
426 if (!PMC_IS_NULL(lex_pad
)) {
427 if (VTABLE_exists_keyed_str(interpreter
, lex_pad
, lex_name
))
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.
437 real_exception(interpreter
, NULL
, INVALID_OPERATION
,
438 "Bug: Context %p :outer points back to itself.",
448 parrot_new_closure(Interp
*interpreter
, PMC
*sub_pmc
)
451 struct Parrot_sub
*clos
, *sub
;
453 parrot_context_t
*ctx
;
455 clos_pmc
= VTABLE_clone(interpreter
, sub_pmc
);
456 sub
= PMC_sub(sub_pmc
);
457 clos
= PMC_sub(clos_pmc
);
459 * the given sub_pmc has to have an :outer(sub) that is
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
);
467 /* if (sub->outer_sub != ctx->current_sub) - fails if outer
468 * is a closure too e.g. test 'closure 4'
470 if (0 == string_equal(interpreter
,
471 (PMC_sub(ctx
->current_sub
))->name
,
473 real_exception(interpreter
, NULL
, INVALID_OPERATION
,
474 "'%Ss' isn't the :outer of '%Ss')",
475 (PMC_sub(ctx
->current_sub
))->name
,
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 */
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
);
499 F<include/parrot/sub.h>.
503 Initial version by Melvin on 2002/06/6.
512 * c-file-style: "parrot"
514 * vim: expandtab shiftwidth=4: