2 Copyright (C) 2001-2007, The Perl Foundation.
7 src/pmc/sub.pmc - Subroutine
11 These are the vtable functions for the Sub (subroutine) base class
21 #include "parrot/parrot.h"
22 #include "parrot/oplib/ops.h"
27 print_sub_name(Interp* interp, PMC* sub)
29 Interp * const tracer =
30 interp->debugger ? interp->debugger : interp;
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);
39 * A sub now contains more data like namespace, which makes it
40 * effectively a container. Therefore need_ext has to be set
42 pmclass Sub need_ext {
48 Initializes the subroutine.
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)
66 * see also the enum in include/parrot/sub.h
69 * PMC_struct_val ... Parrot_sub structure
70 * PMC_pmc_val ... unused / bound object in Bound_Meth PMC
73 PMC_struct_val(SELF) = new_sub(INTERP);
74 PMC_pmc_val(SELF) = NULL;
75 PObj_custom_mark_destroy_SETALL(SELF);
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);
85 =item C<void destroy()>
87 Destroys the subroutine.
94 struct Parrot_sub * const sub = PMC_sub(SELF);
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 : "???");
105 PMC_struct_val(SELF) = NULL;
110 =item C<STRING *get_string()>
112 Returns the name of the subroutine.
114 =item C<void set_string_native(STRING *subname)>
116 Sets the name of the subroutine.
122 STRING* get_string() {
123 const struct Parrot_sub * const sub = PMC_sub(SELF);
124 return Parrot_make_COW_reference(INTERP, sub->name);
127 void set_string_native(STRING *subname) {
128 struct Parrot_sub * const sub = PMC_sub(SELF);
129 sub->name = string_copy(INTERP, subname);
134 =item C<void set_pointer(void *value)>
136 Sets the pointer to the actual subroutine.
138 *** Don't use that - use .Sub constants instead ***
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");
152 =item C<void *get_pointer()>
154 Returns the address of the actual subroutine.
160 void* get_pointer() {
161 const struct Parrot_sub * const sub = PMC_sub(SELF);
162 return sub->seg->base.data + sub->start_offs;
167 =item C<INTVAL get_integer_keyed(PMC *key)>
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
177 INTVAL get_integer_keyed(PMC* key) {
178 return (INTVAL) ((PMC_sub(SELF))->seg->base.data);
183 =item C<INTVAL defined()>
185 =item C<INTVAL get_bool()>
203 =item C<opcode_t *invoke(void *next)>
205 Invokes the subroutine.
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;
218 if (Interp_trace_TEST(INTERP, PARROT_TRACE_SUB_CALL_FLAG))
219 print_sub_name(INTERP, SELF);
222 * A remark WRT tail calls
233 * that is the sub B() returns whatever C() returns.
235 * We are just calling the sub C().
236 * If the private2 flag is set, this code is called by a
239 * We allocate a new register frame and recycle it
240 * immediately after argument passing.
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;
248 if (ccont == NEED_CONTINUATION)
249 ccont = new_ret_continuation_pmc(interp, (opcode_t *)next);
251 assert(!PMC_IS_NULL(ccont));
254 * plain subroutine call
255 * create new context, place it in interpreter
257 #define PREMATURE_OPT
259 if (caller_ctx->current_sub == SELF)
260 context = Parrot_dup_context(INTERP, caller_ctx);
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;
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");
276 /* and copy set context variables */
277 PMC_cont(ccont)->from_ctx = context;
279 /* set context of the sub */
282 /* don't destroy context */
283 if (PObj_get_FLAGS(SELF) & SUB_FLAG_IS_OUTER)
284 ccont->vtable = interp->vtables[enum_class_Continuation];
286 /* reference counting should work */
287 context->ref_count++;
289 if (!PMC_IS_NULL(INTERP->current_object)) {
290 context->current_object = INTERP->current_object;
291 INTERP->current_object = NULL;
294 context->current_HLL = sub->HLL_id;
295 context->current_namespace = sub->namespace_stash;
297 /* create pad if needed
298 * TODO move this up in front of argument passing
299 * and factor out common code with coroutine pmc
301 if (!PMC_IS_NULL(sub->lex_info)) {
302 context->lex_pad = pmc_new_init(INTERP,
303 Parrot_get_ctx_HLL_type(interp,
306 VTABLE_set_pointer(INTERP, context->lex_pad, context);
309 /* switch code segment if needed */
310 if (INTERP->code != sub->seg)
311 Parrot_switch_to_cs(INTERP, sub->seg, 1);
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))) {
318 /* TODO keep it or resize it */
319 --context->recursion_depth;
321 PObj_get_FLAGS(ccont) &= ~SUB_FLAG_TAILCALL;
322 context->caller_ctx = caller_ctx->caller_ctx;
324 Parrot_free_context(INTERP, caller_ctx, 0);
333 =item C<PMC *clone()>
335 Creates and returns a clone of the subroutine.
342 struct Parrot_sub *sub;
343 PMC * const ret = pmc_new_noinit(INTERP, SELF->vtable->base_type);
345 /* we have to mark it ourselves */
346 PObj_custom_mark_destroy_SETALL(ret);
347 sub = mem_allocate_typed(struct Parrot_sub);
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);
360 =item C<void assign_pmc(PMC* other)>
362 Set SELF to the data in other.
368 void set_pmc(PMC* other) {
369 DYNSELF.assign_pmc(other);
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);
381 real_exception(INTERP, NULL, E_TypeError,
382 "Can't assign a non-Sub type to a Sub");
390 Marks the sub as live.
397 const struct Parrot_sub * const sub = PMC_sub(SELF);
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);
412 =item C<INTVAL is_equal(PMC *value)>
414 Returns whether the two subroutines are equal.
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;
428 =item C<void visit(visit_info *info)>
430 This is used by freeze/thaw to visit the contents of the sub.
432 =item C<void freeze(visit_info *info)>
434 Archives the subroutine.
440 void visit(visit_info *info) {
441 struct Parrot_sub * const sub = PMC_sub(SELF);
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);
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)
455 * Therefore the hash must be last during visit for now.
457 info->thaw_ptr = &sub->lex_info;
458 (info->visit_pmc_now)(INTERP, sub->lex_info, info);
462 void freeze(visit_info *info) {
463 IMAGE_IO * const io = info->image_io;
464 struct Parrot_sub * const sub = PMC_sub(SELF);
469 * we currently need to write these items:
470 * - start offset in byte-code segment
471 * - end offset in byte-code segment
473 * - flags (i.e. :load pragma and such)
474 * - name of the sub's label
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]);
496 =item C<void thaw(visit_info *info)>
498 Unarchives the subroutine.
504 void thaw(visit_info *info) {
505 IMAGE_IO * const io = info->image_io;
508 if (info->extra_flags == EXTRA_IS_NULL) {
509 struct Parrot_sub * const sub = PMC_sub(SELF);
513 * we get relative offsets
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);
536 =item C<METHOD PMC* get_namespace()>
538 Return the namespace PMC, where the Sub is defined.
540 TODO return C<namespace_stash> instead.
542 =item C<METHOD INTVAL __get_regs_used(char *kind)>
544 Return amount of used registers for register kinds "I", "S", "P", "N".
546 =item C<METHOD PMC* get_lexinfo()>
548 Return the LexInfo PMC, if any or a Null PMC.
550 =item C<METHOD PMC* get_multisig()>
552 Return the MMD signature PMC, if any or a Null PMC.
559 METHOD PMC* get_namespace() {
560 struct Parrot_sub * const sub = PMC_sub(SELF);
562 return sub->namespace_stash;
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
570 static const char types[] = "INSP";
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);
579 real_exception(INTERP, NULL, E_ValueError,
580 "illegal register kind '%s'", kind);
581 return sub->n_regs_used[p - types];
584 METHOD PMC* get_lexinfo() {
585 const struct Parrot_sub * const sub = PMC_sub(SELF);
586 return sub->lex_info ? sub->lex_info : PMCNULL;
589 METHOD PMC* get_outer() {
590 const struct Parrot_sub * const sub = PMC_sub(SELF);
591 return sub->outer_sub ? sub->outer_sub : PMCNULL;
594 METHOD PMC* get_multisig() {
595 const struct Parrot_sub * const sub = PMC_sub(SELF);
596 return sub->multi_signature ? sub->multi_signature : PMCNULL;
606 Initial version by Melvin on 2002/06/06.
614 * c-file-style: "parrot"
616 * vim: expandtab shiftwidth=4: