1 /*
2 Copyright (C) 2001-2014, Parrot Foundation.
3
4 =head1 NAME
5
6 src/sub.c - Subroutines
7
8 =head1 DESCRIPTION
9
10 Subroutines, continuations, co-routines and other fun stuff...
11
12 =head2 Functions
13
14 =over 4
15
16 =cut
17
18 */
19
20 #include "parrot/parrot.h"
21 #include "parrot/oplib/ops.h"
22 #include "sub.str"
23 #include "pmc/pmc_sub.h"
24 #include "pmc/pmc_continuation.h"
25 #include "pmc/pmc_coroutine.h"
26 #include "parrot/oplib/core_ops.h"
27
28 /* HEADERIZER HFILE: include/parrot/sub.h */
29
30
31 /*
32
33 =item C<STRING* Parrot_sub_full_sub_name(PARROT_INTERP, PMC* sub_pmc)>
34
35 Return namespace, name, and location of subroutine.
36
37 =cut
38
39 */
40
41 PARROT_EXPORT
42 PARROT_CAN_RETURN_NULL
43 PARROT_WARN_UNUSED_RESULT
44 STRING*
Parrot_sub_full_sub_name(PARROT_INTERP,ARGIN_NULLOK (PMC * sub_pmc))45 Parrot_sub_full_sub_name(PARROT_INTERP, ARGIN_NULLOK(PMC* sub_pmc))
46 {
47 ASSERT_ARGS(Parrot_sub_full_sub_name)
48 if (sub_pmc && VTABLE_defined(interp, sub_pmc)) {
49 Parrot_Sub_attributes *sub;
50
51 PMC_get_sub(interp, sub_pmc, sub);
52
53 if (PMC_IS_NULL(sub->namespace_stash)) {
54 return sub->name;
55 }
56 else {
57 PMC *ns_array;
58 STRING * const semicolon = CONST_STRING(interp, ";");
59 STRING *res;
60
61 /*
62 * When running with -t4, the invoke done in
63 * Parrot_ns_get_name stomps on settings in interp; we
64 * have to save these and restore them to avoid affecting
65 * the running program.
66 */
67 PMC * const saved_ccont = interp->current_cont;
68
69 Parrot_block_GC_mark(interp);
70
71 ns_array = Parrot_ns_get_name(interp, sub->namespace_stash);
72
73 /* Restore stuff that might have got overwritten */
74 interp->current_cont = saved_ccont;
75
76 if (sub->name)
77 VTABLE_push_string(interp, ns_array, sub->name);
78
79 res = Parrot_str_join(interp, semicolon, ns_array);
80 Parrot_unblock_GC_mark(interp);
81 return res;
82 }
83 }
84 return NULL;
85 }
86
87 /*
88
89 =item C<int Parrot_sub_context_get_info(PARROT_INTERP, PMC *ctx,
90 Parrot_Context_info *info)>
91
92 Takes pointers to a context and its information table.
93 Populates the table and returns 0 or 1. XXX needs explanation
94 Used by Parrot_sub_Context_infostr.
95
96 =cut
97
98 */
99
100 PARROT_EXPORT
101 int
Parrot_sub_context_get_info(PARROT_INTERP,ARGIN (PMC * ctx),ARGOUT (Parrot_Context_info * info))102 Parrot_sub_context_get_info(PARROT_INTERP, ARGIN(PMC *ctx),
103 ARGOUT(Parrot_Context_info *info))
104 {
105 ASSERT_ARGS(Parrot_sub_context_get_info)
106 PMC *subpmc;
107 Parrot_Sub_attributes *sub;
108 opcode_t *pc;
109
110 /* set file/line/pc defaults */
111 info->file = CONST_STRING(interp, "(unknown file)");
112 info->line = -1;
113 info->pc = -1;
114 info->nsname = NULL;
115 info->subname = NULL;
116 info->fullname = NULL;
117
118 subpmc = Parrot_pcc_get_sub(interp, ctx);
119
120 /* is the current sub of the specified context valid? */
121 if (PMC_IS_NULL(subpmc)) {
122 info->subname = Parrot_str_new(interp, "???", 3);
123 info->nsname = info->subname;
124 info->fullname = Parrot_str_new(interp, "??? :: ???", 10);
125 info->pc = -1;
126 return 0;
127 }
128
129 /* fetch Parrot_sub of the current sub in the given context */
130 if (!VTABLE_isa(interp, subpmc, CONST_STRING(interp, "Sub")))
131 return 1;
132
133 PMC_get_sub(interp, subpmc, sub);
134 /* set the sub name */
135 info->subname = sub->name;
136
137 /* set the namespace name and fullname of the sub */
138 if (PMC_IS_NULL(sub->namespace_name)) {
139 info->nsname = CONST_STRING(interp, "");
140 info->fullname = info->subname;
141 }
142 else {
143 info->nsname = VTABLE_get_string(interp, sub->namespace_name);
144 info->fullname = Parrot_sub_full_sub_name(interp, subpmc);
145 }
146
147 pc = Parrot_pcc_get_pc(interp, ctx);
148
149 /* return here if there is no current pc */
150 if (!pc)
151 return 1;
152
153 /* calculate the current pc */
154 info->pc = pc - sub->seg->base.data;
155
156 /* determine the current source file/line */
157 if (pc) {
158 const size_t offs = info->pc;
159 size_t i, n;
160 PackFile_Debug * const debug = sub->seg->debugs;
161 pc = sub->seg->base.data;
162
163 if (!debug)
164 return 0;
165 for (i = n = 0; n < sub->seg->base.size; ++i) {
166 op_info_t * const op_info = sub->seg->op_info_table[*pc];
167 opcode_t var_args = 0;
168
169 if (i >= debug->base.size)
170 return 0;
171 if (n >= offs) {
172 /* set source line and file */
173 info->line = debug->base.data[i];
174 info->file = Parrot_pf_debug_pc_to_filename(interp, debug, i);
175 break;
176 }
177 ADD_OP_VAR_PART(interp, sub->seg, pc, var_args);
178 n += op_info->op_count + var_args;
179 pc += op_info->op_count + var_args;
180 }
181 }
182
183 return 1;
184 }
185
186
187 /*
188
189 =item C<INTVAL Parrot_sub_get_line_from_pc(PARROT_INTERP, PMC *subpmc, opcode_t
190 *pc)>
191
192 Given a PMC sub and the current opcode, returns the corresponding PIR line
193 number.
194
195 =cut
196
197 */
198
199 INTVAL
Parrot_sub_get_line_from_pc(PARROT_INTERP,ARGIN_NULLOK (PMC * subpmc),ARGIN_NULLOK (opcode_t * pc))200 Parrot_sub_get_line_from_pc(PARROT_INTERP, ARGIN_NULLOK(PMC *subpmc), ARGIN_NULLOK(opcode_t *pc))
201 {
202 ASSERT_ARGS(Parrot_sub_get_line_from_pc)
203 Parrot_Sub_attributes *sub;
204 opcode_t *base_pc, *debug_ops;
205 size_t i, op, current_annotation, debug_size, code_size;
206
207 if (!subpmc || !pc)
208 return -1;
209
210 PMC_get_sub(interp, subpmc, sub);
211
212 debug_ops = sub->seg->debugs->base.data;
213 debug_size = sub->seg->debugs->base.size;
214 code_size = sub->seg->base.size;
215 base_pc = sub->seg->base.data;
216 current_annotation = pc - base_pc;
217
218 /* assert pc is in correct segment */
219 PARROT_ASSERT(base_pc <= pc && pc <= base_pc + code_size);
220
221 for (i = op = 0; op < code_size; ++i) {
222 op_info_t * const op_info = sub->seg->op_info_table[*base_pc];
223 opcode_t var_args = 0;
224
225 if (i >= debug_size)
226 return -1;
227
228 if (op >= current_annotation)
229 return debug_ops[i];
230
231 ADD_OP_VAR_PART(interp, sub->seg, base_pc, var_args);
232 op += op_info->op_count + var_args;
233 base_pc += op_info->op_count + var_args;
234 }
235
236 return -1;
237 }
238
239
240 /*
241
242 =item C<STRING * Parrot_sub_get_filename_from_pc(PARROT_INTERP, PMC *subpmc,
243 opcode_t *pc)>
244
245 Given a PMC sub and the current opcode, returns the corresponding PIR file
246 name.
247
248 =cut
249
250 */
251
252 PARROT_CANNOT_RETURN_NULL
253 STRING *
Parrot_sub_get_filename_from_pc(PARROT_INTERP,ARGIN_NULLOK (PMC * subpmc),ARGIN_NULLOK (opcode_t * pc))254 Parrot_sub_get_filename_from_pc(PARROT_INTERP, ARGIN_NULLOK(PMC *subpmc),
255 ARGIN_NULLOK(opcode_t *pc))
256 {
257 ASSERT_ARGS(Parrot_sub_get_filename_from_pc)
258 Parrot_Sub_attributes *sub;
259 PackFile_Debug *debug;
260 int position;
261
262 if (!subpmc || !pc)
263 return CONST_STRING(interp, "unknown file");
264
265 PMC_get_sub(interp, subpmc, sub);
266
267 debug = sub->seg->debugs;
268 position = pc - sub->seg->base.data;
269
270 return Parrot_pf_debug_pc_to_filename(interp, debug, position);
271 }
272
273 /*
274
275 =item C<STRING* Parrot_sub_Context_infostr(PARROT_INTERP, PMC *ctx, int is_top)>
276
277 Formats context information for display. Takes a context pointer and
278 returns a pointer to the text. Used in debug.c and warnings.c
279
280 =cut
281
282 */
283
284 PARROT_EXPORT
285 PARROT_CAN_RETURN_NULL
286 PARROT_WARN_UNUSED_RESULT
287 STRING*
Parrot_sub_Context_infostr(PARROT_INTERP,ARGIN (PMC * ctx),int is_top)288 Parrot_sub_Context_infostr(PARROT_INTERP, ARGIN(PMC *ctx), int is_top)
289 {
290 ASSERT_ARGS(Parrot_sub_Context_infostr)
291 Parrot_Context_info info;
292 STRING *res = NULL;
293 const char * const msg = is_top ? "current instr.:" : "called from Sub";
294
295 Parrot_block_GC_mark(interp);
296 if (Parrot_sub_context_get_info(interp, ctx, &info)) {
297
298 res = Parrot_sprintf_c(interp,
299 "%s '%Ss' pc %d (%Ss:%d)", msg,
300 info.fullname, info.pc, info.file, info.line);
301 }
302
303 Parrot_unblock_GC_mark(interp);
304 return res;
305 }
306
307 /*
308
309 =item C<PMC* Parrot_sub_find_pad(PARROT_INTERP, STRING *lex_name, PMC *ctx)>
310
311 Locate the LexPad containing the given name. Return NULL on failure.
312
313 =cut
314
315 */
316
317 PARROT_CAN_RETURN_NULL
318 PARROT_WARN_UNUSED_RESULT
319 PMC*
Parrot_sub_find_pad(PARROT_INTERP,ARGIN (STRING * lex_name),ARGIN (PMC * ctx))320 Parrot_sub_find_pad(PARROT_INTERP, ARGIN(STRING *lex_name), ARGIN(PMC *ctx))
321 {
322 ASSERT_ARGS(Parrot_sub_find_pad)
323 while (1) {
324 PMC * const lex_pad = Parrot_pcc_get_lex_pad(interp, ctx);
325 PMC * outer = Parrot_pcc_get_outer_ctx(interp, ctx);
326
327 if (PMC_IS_NULL(outer))
328 return lex_pad;
329
330 PARROT_ASSERT(outer->vtable->base_type == enum_class_CallContext);
331
332 if (!PMC_IS_NULL(lex_pad))
333 if (VTABLE_exists_keyed_str(interp, lex_pad, lex_name))
334 return lex_pad;
335
336 ctx = outer;
337 }
338 }
339
340
341 /*
342
343 =item C<PMC* Parrot_sub_find_dynamic_pad(PARROT_INTERP, STRING *lex_name, PMC
344 *ctx)>
345
346 Locate the LexPad containing the given C<lex_name> in C<ctx> and
347 its caller pads. Return PMCNULL on failure.
348
349 =cut
350
351 */
352
353 PARROT_CAN_RETURN_NULL
354 PARROT_WARN_UNUSED_RESULT
355 PMC*
Parrot_sub_find_dynamic_pad(PARROT_INTERP,ARGIN (STRING * lex_name),ARGIN (PMC * ctx))356 Parrot_sub_find_dynamic_pad(PARROT_INTERP, ARGIN(STRING *lex_name), ARGIN(PMC *ctx))
357 {
358 ASSERT_ARGS(Parrot_sub_find_dynamic_pad)
359 while (1) {
360 PMC * const lex_pad = Parrot_pcc_get_lex_pad(interp, ctx);
361 PMC * caller = Parrot_pcc_get_caller_ctx(interp, ctx);
362
363 if (PMC_IS_NULL(caller))
364 return lex_pad;
365
366 if (!PMC_IS_NULL(lex_pad))
367 if (VTABLE_exists_keyed_str(interp, lex_pad, lex_name))
368 return lex_pad;
369
370 ctx = caller;
371 }
372 }
373
374
375 /*
376
377 =item C<void Parrot_sub_capture_lex(PARROT_INTERP, PMC *sub_pmc)>
378
379 Capture the current lexical environment of a sub.
380
381 =cut
382
383 */
384
385 PARROT_EXPORT
386 void
Parrot_sub_capture_lex(PARROT_INTERP,ARGMOD (PMC * sub_pmc))387 Parrot_sub_capture_lex(PARROT_INTERP, ARGMOD(PMC *sub_pmc))
388 {
389 ASSERT_ARGS(Parrot_sub_capture_lex)
390 PMC * const ctx = CURRENT_CONTEXT(interp);
391 Parrot_Sub_attributes *current_sub;
392 Parrot_Sub_attributes *sub;
393
394 PMC_get_sub(interp, Parrot_pcc_get_sub(interp, ctx), current_sub);
395
396 /* MultiSub gets special treatment */
397 if (VTABLE_isa(interp, sub_pmc, CONST_STRING(interp, "MultiSub"))) {
398
399 PMC * const iter = VTABLE_get_iter(interp, sub_pmc);
400
401 while (VTABLE_get_bool(interp, iter)) {
402
403 PMC * const child_pmc = VTABLE_shift_pmc(interp, iter);
404 Parrot_Sub_attributes *child_sub, *child_outer_sub;
405
406 PMC_get_sub(interp, child_pmc, child_sub);
407
408 if (!PMC_IS_NULL(child_sub->outer_sub)) {
409 PMC_get_sub(interp, child_sub->outer_sub, child_outer_sub);
410 if (STRING_equal(interp, current_sub->subid,
411 child_outer_sub->subid)) {
412 PARROT_GC_WRITE_BARRIER(interp, child_pmc);
413 child_sub->outer_ctx = ctx;
414 }
415 }
416 }
417 return;
418 }
419
420 /* the sub_pmc has to have an outer_sub that is the caller */
421 PMC_get_sub(interp, sub_pmc, sub);
422 if (PMC_IS_NULL(sub->outer_sub))
423 return;
424
425 /* set the sub's outer context to the current context */
426 PARROT_GC_WRITE_BARRIER(interp, sub_pmc);
427 sub->outer_ctx = ctx;
428 }
429
430
431 /*
432
433 =item C<PMC* Parrot_sub_new_closure(PARROT_INTERP, PMC *sub_pmc)>
434
435 Used where? XXX
436
437 Creates a new closure, saving the context information. Takes a pointer
438 to a subroutine.
439
440 Returns a pointer to the closure, (or throws exceptions if invalid).
441
442 =cut
443
444 */
445
446 PARROT_EXPORT
447 PARROT_CANNOT_RETURN_NULL
448 PARROT_WARN_UNUSED_RESULT
449 PMC*
Parrot_sub_new_closure(PARROT_INTERP,ARGIN (PMC * sub_pmc))450 Parrot_sub_new_closure(PARROT_INTERP, ARGIN(PMC *sub_pmc))
451 {
452 ASSERT_ARGS(Parrot_sub_new_closure)
453 PMC * const clos_pmc = VTABLE_clone(interp, sub_pmc);
454 Parrot_sub_capture_lex(interp, clos_pmc);
455 return clos_pmc;
456 }
457
458
459 /*
460
461 =item C<void Parrot_sub_continuation_check(PARROT_INTERP, const PMC *pmc)>
462
463 Verifies that the provided continuation is sane.
464
465 =cut
466
467 */
468
469 void
Parrot_sub_continuation_check(PARROT_INTERP,ARGIN (const PMC * pmc))470 Parrot_sub_continuation_check(PARROT_INTERP, ARGIN(const PMC *pmc))
471 {
472 ASSERT_ARGS(Parrot_sub_continuation_check)
473 PMC * const to_ctx = PARROT_CONTINUATION(pmc)->to_ctx;
474 if (PMC_IS_NULL(to_ctx))
475 Parrot_ex_throw_from_c_noargs(interp, EXCEPTION_INVALID_OPERATION,
476 "Continuation invoked after deactivation");
477 }
478
479 /*
480
481 =item C<void Parrot_sub_continuation_rewind_environment(PARROT_INTERP, PMC
482 *pmc)>
483
484 Restores the appropriate context for the continuation.
485
486 =cut
487
488 */
489
490 void
Parrot_sub_continuation_rewind_environment(PARROT_INTERP,ARGIN (PMC * pmc))491 Parrot_sub_continuation_rewind_environment(PARROT_INTERP, ARGIN(PMC *pmc))
492 {
493 ASSERT_ARGS(Parrot_sub_continuation_rewind_environment)
494
495 PMC * const ctx = CURRENT_CONTEXT(interp);
496 PMC * const to_ctx = PARROT_CONTINUATION(pmc)->to_ctx;
497 PMC * const sig = Parrot_pcc_get_signature(interp, ctx);
498 PMC * const from_sub = Parrot_pcc_get_sub(interp, ctx);
499
500 /* A yield could not bring us here */
501 if (from_sub && from_sub->vtable->base_type == enum_class_Coroutine) {
502 INTVAL autoreset;
503 GETATTR_Coroutine_autoreset(interp, from_sub, autoreset);
504 if (autoreset) {
505 #ifndef NDEBUG
506 if (Interp_trace_TEST(interp, PARROT_TRACE_SUB_CALL_FLAG))
507 Parrot_io_eprintf(interp, "# Coroutine autoreset '%Ss'\n",
508 Parrot_sub_full_sub_name(interp, from_sub));
509 #endif
510 SETATTR_Coroutine_ctx(interp, from_sub, PMCNULL);
511 }
512 #ifndef NDEBUG
513 else {
514 if (Interp_trace_TEST(interp, PARROT_TRACE_SUB_CALL_FLAG))
515 Parrot_io_eprintf(interp, "# Coroutine no autoreset '%Ss'\n",
516 Parrot_sub_full_sub_name(interp, from_sub));
517 }
518 #endif
519 }
520
521 #ifndef NDEBUG
522 /* debug print before context is switched */
523 if (Interp_trace_TEST(interp, PARROT_TRACE_SUB_CALL_FLAG)) {
524 PMC * const sub = Parrot_pcc_get_sub(interp, to_ctx);
525 Parrot_io_eprintf(interp, "# Back in sub '%Ss\n",
526 Parrot_sub_full_sub_name(interp, sub));
527 }
528 #endif
529
530 /* set context */
531 Parrot_pcc_set_context(interp, to_ctx);
532 Parrot_pcc_set_signature(interp, to_ctx, sig);
533 }
534
535
536 /*
537
538 =item C<void * Parrot_get_sub_pmc_from_subclass(PARROT_INTERP, PMC *subclass)>
539
540 Gets a Parrot_sub structure from something that isn't a Sub PMC, but rather a
541 subclass.
542
543 =cut
544
545 */
546
547 PARROT_EXPORT
548 PARROT_CANNOT_RETURN_NULL
549 void *
Parrot_get_sub_pmc_from_subclass(PARROT_INTERP,ARGIN (PMC * subclass))550 Parrot_get_sub_pmc_from_subclass(PARROT_INTERP, ARGIN(PMC *subclass)) {
551 ASSERT_ARGS(Parrot_get_sub_pmc_from_subclass)
552
553 /* Ensure we really do have a subclass of sub. */
554 if (VTABLE_isa(interp, subclass, CONST_STRING(interp, "Sub"))) {
555 PMC *key, *sub_pmc;
556
557 /* If it's actually a PMC still, probably does the same structure
558 * underneath. */
559 if (!PObj_is_object_TEST(subclass)) {
560 return PARROT_SUB(subclass);
561 }
562
563 /* Get the Sub PMC itself. */
564 key = Parrot_pmc_new(interp, enum_class_String);
565 VTABLE_set_string_native(interp, key, CONST_STRING(interp, "Sub"));
566 sub_pmc = VTABLE_get_attr_keyed(interp, subclass, key, CONST_STRING(interp, "proxy"));
567 if (sub_pmc->vtable->base_type == enum_class_Sub) {
568 return PARROT_SUB(sub_pmc);
569 }
570 }
571 Parrot_ex_throw_from_c_noargs(interp, EXCEPTION_INVALID_OPERATION,
572 "Attempting to do sub operation on non-Sub");
573 }
574
575 /*
576
577 =back
578
579 =head1 SEE ALSO
580
581 F<include/parrot/sub.h>.
582
583 =cut
584
585 */
586
587
588 /*
589 * Local variables:
590 * c-file-style: "parrot"
591 * End:
592 * vim: expandtab shiftwidth=4 cinoptions='\:2=2' :
593 */
594