2 Copyright (C) 2001-2009, Parrot 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"
24 #include "pmc/pmc_sub.h"
25 #include "pmc/pmc_continuation.h"
26 #include "pmc/pmc_context.h"
28 /* HEADERIZER HFILE: include/parrot/sub.h */
33 =item C<void mark_context_start(void)>
35 Indicate that a new round of context marking is about to take place.
41 static int context_gc_mark
= 0;
44 mark_context_start(void)
46 ASSERT_ARGS(mark_context_start
)
47 if (++context_gc_mark
== 0) context_gc_mark
= 1;
53 =item C<PMC * new_ret_continuation_pmc(PARROT_INTERP, opcode_t *address)>
55 Returns a new C<RetContinuation> PMC, and sets address field to C<address>
63 PARROT_CANNOT_RETURN_NULL
65 new_ret_continuation_pmc(PARROT_INTERP
, ARGIN_NULLOK(opcode_t
*address
))
67 ASSERT_ARGS(new_ret_continuation_pmc
)
68 PMC
* const continuation
= pmc_new(interp
, enum_class_RetContinuation
);
69 VTABLE_set_pointer(interp
, continuation
, address
);
75 =item C<void invalidate_retc_context(PARROT_INTERP, PMC *cont)>
77 Make true Continuations from all RetContinuations up the call chain.
84 invalidate_retc_context(PARROT_INTERP
, ARGMOD(PMC
*cont
))
86 ASSERT_ARGS(invalidate_retc_context
)
88 PMC
*ctx
= PARROT_CONTINUATION(cont
)->from_ctx
;
89 cont
= Parrot_pcc_get_continuation(interp
, ctx
);
93 * We stop if we encounter a true continuation, because
94 * if one were created, everything up the chain would have been
95 * invalidated earlier.
97 if (!cont
|| cont
->vtable
!= interp
->vtables
[enum_class_RetContinuation
])
99 cont
->vtable
= interp
->vtables
[enum_class_Continuation
];
100 ctx
= Parrot_pcc_get_caller_ctx(interp
, ctx
);
101 cont
= Parrot_pcc_get_continuation(interp
, ctx
);
107 =item C<STRING* Parrot_full_sub_name(PARROT_INTERP, PMC* sub_pmc)>
109 Return namespace, name, and location of subroutine.
116 PARROT_CAN_RETURN_NULL
117 PARROT_WARN_UNUSED_RESULT
119 Parrot_full_sub_name(PARROT_INTERP
, ARGIN_NULLOK(PMC
* sub_pmc
))
121 ASSERT_ARGS(Parrot_full_sub_name
)
122 if (sub_pmc
&& VTABLE_defined(interp
, sub_pmc
)) {
123 Parrot_Sub_attributes
*sub
;
125 PMC_get_sub(interp
, sub_pmc
, sub
);
127 if (PMC_IS_NULL(sub
->namespace_stash
)) {
132 STRING
* const semicolon
= CONST_STRING(interp
, ";");
136 * When running with -t4, the invoke done in
137 * Parrot_ns_get_name stomps on settings in interp; we
138 * have to save these and restore them to avoid affecting
139 * the running program.
141 PMC
* const saved_ccont
= interp
->current_cont
;
143 Parrot_block_GC_mark(interp
);
145 ns_array
= Parrot_ns_get_name(interp
, sub
->namespace_stash
);
147 /* Restore stuff that might have got overwritten */
148 interp
->current_cont
= saved_ccont
;
151 VTABLE_push_string(interp
, ns_array
, sub
->name
);
153 res
= Parrot_str_join(interp
, semicolon
, ns_array
);
154 Parrot_unblock_GC_mark(interp
);
163 =item C<int Parrot_Context_get_info(PARROT_INTERP, PMC *ctx, Parrot_Context_info
166 Takes pointers to a context and its information table.
167 Populates the table and returns 0 or 1. XXX needs explanation
168 Used by Parrot_Context_infostr.
176 Parrot_Context_get_info(PARROT_INTERP
, ARGIN(PMC
*ctx
),
177 ARGOUT(Parrot_Context_info
*info
))
179 ASSERT_ARGS(Parrot_Context_get_info
)
181 Parrot_Sub_attributes
*sub
;
184 /* set file/line/pc defaults */
185 info
->file
= CONST_STRING(interp
, "(unknown file)");
189 info
->subname
= NULL
;
190 info
->fullname
= NULL
;
192 subpmc
= Parrot_pcc_get_sub(interp
, ctx
);
194 /* is the current sub of the specified context valid? */
195 if (PMC_IS_NULL(subpmc
)) {
196 info
->subname
= Parrot_str_new(interp
, "???", 3);
197 info
->nsname
= info
->subname
;
198 info
->fullname
= Parrot_str_new(interp
, "??? :: ???", 10);
203 /* fetch Parrot_sub of the current sub in the given context */
204 if (!VTABLE_isa(interp
, subpmc
, CONST_STRING(interp
, "Sub")))
207 PMC_get_sub(interp
, subpmc
, sub
);
208 /* set the sub name */
209 info
->subname
= sub
->name
;
211 /* set the namespace name and fullname of the sub */
212 if (PMC_IS_NULL(sub
->namespace_name
)) {
213 info
->nsname
= CONST_STRING(interp
, "");
214 info
->fullname
= info
->subname
;
217 info
->nsname
= VTABLE_get_string(interp
, sub
->namespace_name
);
218 info
->fullname
= Parrot_full_sub_name(interp
, subpmc
);
221 pc
= Parrot_pcc_get_pc(interp
, ctx
);
223 /* return here if there is no current pc */
227 /* calculate the current pc */
228 info
->pc
= pc
- sub
->seg
->base
.data
;
230 /* determine the current source file/line */
232 const size_t offs
= info
->pc
;
234 opcode_t
*pc
= sub
->seg
->base
.data
;
235 PackFile_Debug
* const debug
= sub
->seg
->debugs
;
239 for (i
= n
= 0; n
< sub
->seg
->base
.size
; i
++) {
240 op_info_t
* const op_info
= &interp
->op_info_table
[*pc
];
241 opcode_t var_args
= 0;
243 if (i
>= debug
->base
.size
)
246 /* set source line and file */
247 info
->line
= debug
->base
.data
[i
];
248 info
->file
= Parrot_debug_pc_to_filename(interp
, debug
, i
);
251 ADD_OP_VAR_PART(interp
, sub
->seg
, pc
, var_args
);
252 n
+= op_info
->op_count
+ var_args
;
253 pc
+= op_info
->op_count
+ var_args
;
263 =item C<INTVAL Parrot_Sub_get_line_from_pc(PARROT_INTERP, PMC *subpmc, opcode_t
266 Given a PMC sub and the current opcode, returns the corresponding PIR line
274 Parrot_Sub_get_line_from_pc(PARROT_INTERP
, ARGIN_NULLOK(PMC
*subpmc
), ARGIN_NULLOK(opcode_t
*pc
))
276 ASSERT_ARGS(Parrot_Sub_get_line_from_pc
)
277 Parrot_Sub_attributes
*sub
;
278 opcode_t
*base_pc
, *debug_ops
;
279 size_t i
, op
, current_annotation
, debug_size
;
284 PMC_get_sub(interp
, subpmc
, sub
);
286 debug_ops
= sub
->seg
->debugs
->base
.data
;
287 debug_size
= sub
->seg
->debugs
->base
.size
;
288 base_pc
= sub
->seg
->base
.data
;
289 current_annotation
= pc
- base_pc
;
291 for (i
= op
= 0; op
< debug_size
; i
++) {
292 op_info_t
* const op_info
= &interp
->op_info_table
[*base_pc
];
293 opcode_t var_args
= 0;
298 if (op
>= current_annotation
)
301 ADD_OP_VAR_PART(interp
, sub
->seg
, base_pc
, var_args
);
302 op
+= op_info
->op_count
+ var_args
;
303 base_pc
+= op_info
->op_count
+ var_args
;
312 =item C<STRING * Parrot_Sub_get_filename_from_pc(PARROT_INTERP, PMC *subpmc,
315 Given a PMC sub and the current opcode, returns the corresponding PIR file
322 PARROT_CANNOT_RETURN_NULL
324 Parrot_Sub_get_filename_from_pc(PARROT_INTERP
, ARGIN_NULLOK(PMC
*subpmc
),
325 ARGIN_NULLOK(opcode_t
*pc
))
327 ASSERT_ARGS(Parrot_Sub_get_filename_from_pc
)
328 Parrot_Sub_attributes
*sub
;
329 PackFile_Debug
*debug
;
333 return CONST_STRING(interp
, "unknown file");
335 PMC_get_sub(interp
, subpmc
, sub
);
337 debug
= sub
->seg
->debugs
;
338 position
= pc
- sub
->seg
->base
.data
;
340 return Parrot_debug_pc_to_filename(interp
, debug
, position
);
345 =item C<STRING* Parrot_Context_infostr(PARROT_INTERP, PMC *ctx)>
347 Formats context information for display. Takes a context pointer and
348 returns a pointer to the text. Used in debug.c and warnings.c
355 PARROT_CAN_RETURN_NULL
356 PARROT_WARN_UNUSED_RESULT
358 Parrot_Context_infostr(PARROT_INTERP
, ARGIN(PMC
*ctx
))
360 ASSERT_ARGS(Parrot_Context_infostr
)
361 Parrot_Context_info info
;
363 const char * const msg
= (CURRENT_CONTEXT(interp
) == ctx
)
367 Parrot_block_GC_mark(interp
);
368 if (Parrot_Context_get_info(interp
, ctx
, &info
)) {
370 res
= Parrot_sprintf_c(interp
,
371 "%s '%Ss' pc %d (%Ss:%d)", msg
,
372 info
.fullname
, info
.pc
, info
.file
, info
.line
);
375 Parrot_unblock_GC_mark(interp
);
381 =item C<PMC* Parrot_find_pad(PARROT_INTERP, STRING *lex_name, PMC *ctx)>
383 Locate the LexPad containing the given name. Return NULL on failure.
389 PARROT_CAN_RETURN_NULL
390 PARROT_WARN_UNUSED_RESULT
392 Parrot_find_pad(PARROT_INTERP
, ARGIN(STRING
*lex_name
), ARGIN(PMC
*ctx
))
394 ASSERT_ARGS(Parrot_find_pad
)
396 PMC
* const lex_pad
= Parrot_pcc_get_lex_pad(interp
, ctx
);
397 PMC
* outer
= Parrot_pcc_get_outer_ctx(interp
, ctx
);
402 if (!PMC_IS_NULL(lex_pad
))
403 if (VTABLE_exists_keyed_str(interp
, lex_pad
, lex_name
))
413 =item C<PMC* Parrot_find_dynamic_pad(PARROT_INTERP, STRING *lex_name, PMC *ctx)>
415 Locate the LexPad containing the given C<lex_name> in C<ctx> and
416 its caller pads. Return PMCNULL on failure.
422 PARROT_CAN_RETURN_NULL
423 PARROT_WARN_UNUSED_RESULT
425 Parrot_find_dynamic_pad(PARROT_INTERP
, ARGIN(STRING
*lex_name
), ARGIN(PMC
*ctx
))
427 ASSERT_ARGS(Parrot_find_dynamic_pad
)
429 PMC
* const lex_pad
= Parrot_pcc_get_lex_pad(interp
, ctx
);
430 PMC
* caller
= Parrot_pcc_get_caller_ctx(interp
, ctx
);
435 if (!PMC_IS_NULL(lex_pad
))
436 if (VTABLE_exists_keyed_str(interp
, lex_pad
, lex_name
))
446 =item C<void Parrot_capture_lex(PARROT_INTERP, PMC *sub_pmc)>
448 Capture the current lexical environment of a sub.
456 Parrot_capture_lex(PARROT_INTERP
, ARGMOD(PMC
*sub_pmc
))
458 ASSERT_ARGS(Parrot_capture_lex
)
459 PMC
* const ctx
= CURRENT_CONTEXT(interp
);
460 Parrot_Sub_attributes
*current_sub
;
461 Parrot_Sub_attributes
*sub
;
463 PMC_get_sub(interp
, Parrot_pcc_get_sub(interp
, ctx
), current_sub
);
465 /* MultiSub gets special treatment */
466 if (VTABLE_isa(interp
, sub_pmc
, CONST_STRING(interp
, "MultiSub"))) {
468 PMC
* const iter
= VTABLE_get_iter(interp
, sub_pmc
);
470 while (VTABLE_get_bool(interp
, iter
)) {
472 PMC
* const child_pmc
= VTABLE_shift_pmc(interp
, iter
);
473 Parrot_Sub_attributes
*child_sub
, *child_outer_sub
;
475 PMC_get_sub(interp
, child_pmc
, child_sub
);
477 if (!PMC_IS_NULL(child_sub
->outer_sub
)) {
478 PMC_get_sub(interp
, child_sub
->outer_sub
, child_outer_sub
);
479 if (Parrot_str_equal(interp
, current_sub
->subid
,
480 child_outer_sub
->subid
)) {
481 child_sub
->outer_ctx
= ctx
;
488 /* the sub_pmc has to have an outer_sub that is the caller */
489 PMC_get_sub(interp
, sub_pmc
, sub
);
490 if (PMC_IS_NULL(sub
->outer_sub
))
494 /* verify that the current sub is sub_pmc's :outer */
495 PMC_get_sub(interp
, sub
->outer_sub
, outer_sub
);
496 if (Parrot_str_not_equal(interp
, current_sub
->subid
,
498 Parrot_ex_throw_from_c_args(interp
, NULL
,
499 EXCEPTION_INVALID_OPERATION
, "'%Ss' isn't the :outer of '%Ss'",
500 current_sub
->name
, sub
->name
);
505 /* set the sub's outer context to the current context */
506 sub
->outer_ctx
= ctx
;
512 =item C<PMC* parrot_new_closure(PARROT_INTERP, PMC *sub_pmc)>
516 Creates a new closure, saving the context information. Takes a pointer
519 Returns a pointer to the closure, (or throws exceptions if invalid).
526 PARROT_CANNOT_RETURN_NULL
527 PARROT_WARN_UNUSED_RESULT
529 parrot_new_closure(PARROT_INTERP
, ARGIN(PMC
*sub_pmc
))
531 ASSERT_ARGS(parrot_new_closure
)
532 PMC
* const clos_pmc
= VTABLE_clone(interp
, sub_pmc
);
533 Parrot_capture_lex(interp
, clos_pmc
);
540 =item C<void Parrot_continuation_check(PARROT_INTERP, const PMC *pmc)>
542 Verifies that the provided continuation is sane.
549 Parrot_continuation_check(PARROT_INTERP
, ARGIN(const PMC
*pmc
))
551 ASSERT_ARGS(Parrot_continuation_check
)
552 PMC
* const to_ctx
= PARROT_CONTINUATION(pmc
)->to_ctx
;
553 if (PMC_IS_NULL(to_ctx
))
554 Parrot_ex_throw_from_c_args(interp
, NULL
, EXCEPTION_INVALID_OPERATION
,
555 "Continuation invoked after deactivation.");
560 =item C<void Parrot_continuation_rewind_environment(PARROT_INTERP, PMC *pmc)>
562 Restores the appropriate context for the continuation.
569 Parrot_continuation_rewind_environment(PARROT_INTERP
, ARGIN(PMC
*pmc
))
571 ASSERT_ARGS(Parrot_continuation_rewind_environment
)
573 PMC
* const to_ctx
= PARROT_CONTINUATION(pmc
)->to_ctx
;
575 /* debug print before context is switched */
576 if (Interp_trace_TEST(interp
, PARROT_TRACE_SUB_CALL_FLAG
)) {
577 PMC
* const sub
= Parrot_pcc_get_sub(interp
, to_ctx
);
579 Parrot_io_eprintf(interp
, "# Back in sub '%Ss', env %p\n",
580 Parrot_full_sub_name(interp
, sub
),
581 interp
->dynamic_env
);
585 CURRENT_CONTEXT(interp
) = to_ctx
;
591 =item C<void * Parrot_get_sub_pmc_from_subclass(PARROT_INTERP, PMC *subclass)>
593 Gets a Parrot_sub structure from something that isn't a Sub PMC, but rather a
601 PARROT_CANNOT_RETURN_NULL
603 Parrot_get_sub_pmc_from_subclass(PARROT_INTERP
, ARGIN(PMC
*subclass
)) {
604 ASSERT_ARGS(Parrot_get_sub_pmc_from_subclass
)
607 /* Ensure we really do have a subclass of sub. */
608 if (VTABLE_isa(interp
, subclass
, CONST_STRING(interp
, "Sub"))) {
609 /* If it's actually a PMC still, probably does the same structure
611 if (!PObj_is_object_TEST(subclass
)) {
612 return PARROT_SUB(subclass
);
615 /* Get the Sub PMC itself. */
616 key
= pmc_new(interp
, enum_class_String
);
617 VTABLE_set_string_native(interp
, key
, CONST_STRING(interp
, "Sub"));
618 sub_pmc
= VTABLE_get_attr_keyed(interp
, subclass
, key
, CONST_STRING(interp
, "proxy"));
619 if (sub_pmc
->vtable
->base_type
== enum_class_Sub
) {
620 return PARROT_SUB(sub_pmc
);
623 Parrot_ex_throw_from_c_args(interp
, NULL
, EXCEPTION_INVALID_OPERATION
,
624 "Attempting to do sub operation on non-Sub.");
633 F<include/parrot/sub.h>.
637 Initial version by Melvin on 2002/06/6.
646 * c-file-style: "parrot"
648 * vim: expandtab shiftwidth=4: