?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
tagged release 0.7.1
[parrot.git] / compilers / imcc / pbc.c
blob2e3636078ce9cf1ab241bf62bed63b956db510f6
1 /*
2 * Copyright (C) 2002-2008, The Perl Foundation.
3 * $Id$
4 */
5
6 #include "imc.h"
7 #include "pbc.h"
8 #include "parrot/packfile.h"
9
10 /* HEADERIZER HFILE: compilers/imcc/pbc.h */
11
12 /*
13
14 =head1 NAME
15
16 compilers/imcc/pbc.c
17
18 =head1 DESCRIPTION
19
20 emit imcc instructions into Parrot interpreter
21
22 the e_pbc_emit function is called per instruction
23
24 Notes:
25
26 I'm using existing data structures here (SymReg*) to store
27 various global items (currently only PMC constants).
28 The index in the constant table is in SymReg* ->color
29 data member. This looks odd, but the register number
30 from imc.c:allocate is also there for variables,
31 so it's a little bit consistent at least.
32
33 So when reading color here it's either a constant table index
34 or a Parrot register number, depending on data type.
35
36 TODO memory clean up
37
38 -lt
39
40 =head2 Functions
41
42 =over 4
43
44 =cut
45
46 */
47
48 /*
49 * globals store the state between individual e_pbc_emit calls
50 */
51
52 typedef struct subs_t {
53 size_t size; /* code size in ops */
54 int ins_line; /* line number for debug */
55 int n_basic_blocks; /* block count */
56 SymHash fixup; /* currently set_p_pc sub names only */
57 IMC_Unit *unit;
58 int pmc_const; /* index in const table */
59 struct subs_t *prev;
60 struct subs_t *next;
61 } subs_t;
62
63 /* subs are kept per code segment */
64 typedef struct code_segment_t {
65 PackFile_ByteCode *seg; /* bytecode segment */
66 PackFile_Segment *jit_info; /* bblocks, register usage */
67 subs_t *subs; /* current sub data */
68 subs_t *first; /* first sub of code segment */
69 struct code_segment_t *prev; /* previous code segment */
70 struct code_segment_t *next; /* next code segment */
71 SymHash key_consts; /* this seg's cached key constants */
72 int pic_idx; /* next index of PIC */
73 } code_segment_t;
74
75 static struct globals {
76 code_segment_t *cs; /* current code segment */
77 code_segment_t *first; /* first code segment */
78 int inter_seg_n;
79 } globals;
80
81
82 /* HEADERIZER BEGIN: static */
83 /* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */
84
85 static void add_1_const(PARROT_INTERP, ARGMOD(SymReg *r))
86 __attribute__nonnull__(1)
87 __attribute__nonnull__(2)
88 FUNC_MODIFIES(*r);
89
90 static int add_const_key(PARROT_INTERP,
91 ARGIN(const opcode_t *key),
92 int size,
93 ARGIN(const char *s_key))
94 __attribute__nonnull__(1)
95 __attribute__nonnull__(2)
96 __attribute__nonnull__(4);
97
98 PARROT_WARN_UNUSED_RESULT
99 static int add_const_num(PARROT_INTERP, ARGIN_NULLOK(const char *buf))
100 __attribute__nonnull__(1);
101
102 static int add_const_pmc_sub(PARROT_INTERP,
103 ARGMOD(SymReg *r),
104 int offs,
105 int end)
106 __attribute__nonnull__(1)
107 __attribute__nonnull__(2)
108 FUNC_MODIFIES(*r);
109
110 PARROT_WARN_UNUSED_RESULT
111 static int add_const_str(PARROT_INTERP, ARGIN(const SymReg *r))
112 __attribute__nonnull__(1)
113 __attribute__nonnull__(2);
114
115 static int add_const_table(PARROT_INTERP)
116 __attribute__nonnull__(1);
117
118 static int add_const_table_key(PARROT_INTERP, PMC *key)
119 __attribute__nonnull__(1);
120
121 static int add_const_table_pmc(PARROT_INTERP, PMC *pmc)
122 __attribute__nonnull__(1);
123
124 static opcode_t build_key(PARROT_INTERP, ARGIN(SymReg *key_reg))
125 __attribute__nonnull__(1)
126 __attribute__nonnull__(2);
127
128 static void constant_folding(PARROT_INTERP, ARGIN(const IMC_Unit *unit))
129 __attribute__nonnull__(1)
130 __attribute__nonnull__(2);
131
132 PARROT_WARN_UNUSED_RESULT
133 PARROT_CANNOT_RETURN_NULL
134 static PMC* create_lexinfo(PARROT_INTERP,
135 ARGMOD(IMC_Unit *unit),
136 ARGIN(PMC *sub),
137 int need_lex)
138 __attribute__nonnull__(1)
139 __attribute__nonnull__(2)
140 __attribute__nonnull__(3)
141 FUNC_MODIFIES(*unit);
142
143 PARROT_WARN_UNUSED_RESULT
144 PARROT_CAN_RETURN_NULL
145 static subs_t * find_global_label(
146 ARGIN(const char *name),
147 ARGIN(const subs_t *sym),
148 ARGOUT(int *pc))
149 __attribute__nonnull__(1)
150 __attribute__nonnull__(2)
151 __attribute__nonnull__(3)
152 FUNC_MODIFIES(*pc);
153
154 PARROT_WARN_UNUSED_RESULT
155 PARROT_CAN_RETURN_NULL
156 static PMC* find_outer(PARROT_INTERP, ARGIN(const IMC_Unit *unit))
157 __attribute__nonnull__(1)
158 __attribute__nonnull__(2);
159
160 static void fixup_globals(PARROT_INTERP)
161 __attribute__nonnull__(1);
162
163 PARROT_WARN_UNUSED_RESULT
164 static int get_codesize(PARROT_INTERP,
165 ARGIN(const IMC_Unit *unit),
166 ARGOUT(int *src_lines))
167 __attribute__nonnull__(1)
168 __attribute__nonnull__(2)
169 __attribute__nonnull__(3)
170 FUNC_MODIFIES(*src_lines);
171
172 PARROT_WARN_UNUSED_RESULT
173 static int get_old_size(PARROT_INTERP, ARGOUT(int *ins_line))
174 __attribute__nonnull__(1)
175 __attribute__nonnull__(2)
176 FUNC_MODIFIES(*ins_line);
177
178 static void imcc_globals_destroy(SHIM_INTERP,
179 SHIM(int ex),
180 SHIM(void *param));
181
182 static void make_new_sub(ARGIN(IMC_Unit *unit))
183 __attribute__nonnull__(1);
184
185 static void make_pmc_const(PARROT_INTERP, ARGMOD(SymReg *r))
186 __attribute__nonnull__(1)
187 __attribute__nonnull__(2)
188 FUNC_MODIFIES(*r);
189
190 PARROT_CANNOT_RETURN_NULL
191 PARROT_MALLOC
192 static PMC* mk_multi_sig(PARROT_INTERP, ARGIN(const SymReg *r))
193 __attribute__nonnull__(1)
194 __attribute__nonnull__(2);
195
196 PARROT_WARN_UNUSED_RESULT
197 static int old_blocks(void);
198
199 PARROT_CONST_FUNCTION
200 PARROT_WARN_UNUSED_RESULT
201 PARROT_CANNOT_RETURN_NULL
202 static const char * slice_deb(int bits);
203
204 static void store_fixup(PARROT_INTERP,
205 ARGIN(const SymReg *r),
206 int pc,
207 int offset)
208 __attribute__nonnull__(1)
209 __attribute__nonnull__(2);
210
211 static void store_key_const(ARGIN(const char *str), int idx)
212 __attribute__nonnull__(1);
213
214 static void store_sub_size(size_t size, size_t ins_line);
215 static void verify_signature(PARROT_INTERP,
216 ARGIN(const Instruction *ins),
217 ARGIN(opcode_t *pc))
218 __attribute__nonnull__(1)
219 __attribute__nonnull__(2)
220 __attribute__nonnull__(3);
221
222 /* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */
223 /* HEADERIZER END: static */
224
225 #ifdef HAS_JIT
226
227 PARROT_WARN_UNUSED_RESULT
228 static int old_blocks(void);
229
230 #endif /* HAS_JIT */
231
232 /*
233
234 =item C<static void imcc_globals_destroy>
235
236 RT #48260: Not yet documented!!!
237
238 =cut
239
240 */
241
242 static void
243 imcc_globals_destroy(SHIM_INTERP, SHIM(int ex), SHIM(void *param))
244 {
245 code_segment_t *cs = globals.cs;
246
247 while (cs) {
248 subs_t *s = cs->subs;
249 code_segment_t *prev_cs = cs->prev;
250
251 while (s) {
252 subs_t * const prev_s = s->prev;
253 clear_sym_hash(&s->fixup);
254 mem_sys_free(s);
255 s = prev_s;
256 }
257
258 clear_sym_hash(&cs->key_consts);
259 mem_sys_free(cs);
260 cs = prev_cs;
261 }
262
263 globals.cs = NULL;
264 }
265
266
267 /*
268
269 =item C<static int add_const_table>
270
271 Adds an empty item to constant table, returning its position.
272
273 =cut
274
275 */
276
277 static int
278 add_const_table(PARROT_INTERP)
279 {
280 const size_t oldcount = interp->code->const_table->const_count;
281 const size_t newcount = oldcount + 1;
282
283 /* Allocate a new constant */
284 PackFile_Constant * new_constant = PackFile_Constant_new(interp);
285
286 /* Update the constant count and reallocate */
287 if (interp->code->const_table->constants) {
288 interp->code->const_table->constants =
289 (PackFile_Constant **)mem_sys_realloc(interp->code->const_table->constants,
290 newcount * sizeof (PackFile_Constant *));
291 }
292 else {
293 interp->code->const_table->constants =
294 (PackFile_Constant **)mem_sys_allocate(newcount * sizeof (PackFile_Constant *));
295 }
296
297 interp->code->const_table->constants[newcount - 1] = new_constant;
298 interp->code->const_table->const_count = newcount;
299
300 return oldcount;
301 }
302
303
304 /*
305
306 =item C<static int add_const_table_pmc>
307
308 Adds a PMC to the const table, returning its position.
309
310 =cut
311
312 */
313
314 static int
315 add_const_table_pmc(PARROT_INTERP, PMC *pmc)
316 {
317 int newitem = add_const_table(interp);
318
319 interp->code->const_table->constants[newitem]->type = PFC_PMC;
320 interp->code->const_table->constants[newitem]->u.key = pmc;
321
322 return newitem;
323 }
324
325
326 /*
327
328 =item C<static int add_const_table_key>
329
330 Adds a key to the const table, returning its position.
331
332 =cut
333
334 */
335
336 static int
337 add_const_table_key(PARROT_INTERP, PMC *key)
338 {
339 int newitem = add_const_table(interp);
340
341 interp->code->const_table->constants[newitem]->type = PFC_KEY;
342 interp->code->const_table->constants[newitem]->u.key = key;
343
344 return newitem;
345 }
346
347
348 /*
349
350 =item C<int e_pbc_open>
351
352 RT #48260: Not yet documented!!!
353
354 =cut
355
356 */
357
358 int
359 e_pbc_open(PARROT_INTERP, SHIM(void *param))
360 {
361 code_segment_t *cs = mem_allocate_zeroed_typed(code_segment_t);
362
363 /* register cleanup code */
364 if (!globals.cs)
365 Parrot_on_exit(interp, imcc_globals_destroy, NULL);
366
367 cs->prev = globals.cs;
368
369 /* free previous cached key constants if any */
370 if (globals.cs)
371 clear_sym_hash(&globals.cs->key_consts);
372
373 create_symhash(&cs->key_consts);
374
375 cs->next = NULL;
376 cs->subs = NULL;
377 cs->first = NULL;
378 cs->jit_info = NULL;
379
380 if (!globals.first)
381 globals.first = cs;
382 else
383 cs->prev->next = cs;
384
385 /* we need some segments */
386 if (!interp->code) {
387 PMC *self;
388
389 cs->seg = interp->code =
390 PF_create_default_segs(interp,
391 IMCC_INFO(interp)->state->file, 1);
392
393 /*
394 * create a PMC constant holding the interpreter state
395 *
396 * see also ParrotInterpreter.thaw and .thawfinish
397 * currently just HLL_info is saved/restored
398 */
399 self = VTABLE_get_pmc_keyed_int(interp, interp->iglobals,
400 IGLOBALS_INTERPRETER);
401 (void) add_const_table_pmc(interp, self);
402 }
403
404 globals.cs = cs;
405
406 return 0;
407 }
408
409 #ifdef HAS_JIT
410
411 /*
412
413 =item C<static int old_blocks>
414
415 get size/line of bytecode in ops till now
416
417 =cut
418
419 */
420
421 PARROT_WARN_UNUSED_RESULT
422 static int
423 old_blocks(void)
424 {
425 size_t size = 0;
426 const subs_t *s;
427
428 for (s = globals.cs->subs; s; s = s->prev) {
429 size += s->n_basic_blocks;
430 }
431
432 return size;
433 }
434
435 /*
436
437 =item C<opcode_t * make_jit_info>
438
439 RT #48260: Not yet documented!!!
440
441 =cut
442
443 */
444
445 PARROT_WARN_UNUSED_RESULT
446 PARROT_CANNOT_RETURN_NULL
447 opcode_t *
448 make_jit_info(PARROT_INTERP, ARGIN(const IMC_Unit *unit))
449 {
450 const size_t old = old_blocks();
451 const size_t size = unit->n_basic_blocks + old;
452
453 if (!globals.cs->jit_info) {
454 const size_t len = strlen(globals.cs->seg->base.name) + 5;
455 char * const name = mem_allocate_n_typed(len, char);
456
457 snprintf(name, len, "%s_JIT", globals.cs->seg->base.name);
458 globals.cs->jit_info = PackFile_Segment_new_seg(interp,
459 interp->code->base.dir, PF_UNKNOWN_SEG, name, 1);
460
461 mem_sys_free(name);
462 }
463
464 /* store current size */
465 globals.cs->subs->n_basic_blocks = unit->n_basic_blocks;
466
467 /* offset of block start and end, 4 * registers_used */
468 globals.cs->jit_info->data =
469 mem_realloc_n_typed(globals.cs->jit_info->data, size * 4, opcode_t);
470
471 globals.cs->jit_info->size = size * 4;
472
473 return globals.cs->jit_info->data + old * 4;
474 }
475
476 #endif /* HAS_JIT */
477
478 /*
479
480 =item C<static void make_new_sub>
481
482 allocate a new globals.cs->subs structure
483
484 =cut
485
486 */
487
488 static void
489 make_new_sub(ARGIN(IMC_Unit *unit))
490 {
491 subs_t * const s = mem_allocate_zeroed_typed(subs_t);
492
493 s->prev = globals.cs->subs;
494 s->unit = unit;
495 s->pmc_const = -1;
496
497 if (globals.cs->subs)
498 globals.cs->subs->next = s;
499
500 if (!globals.cs->first)
501 globals.cs->first = s;
502
503 globals.cs->subs = s;
504
505 create_symhash(&s->fixup);
506 }
507
508 /*
509
510 =item C<static int get_old_size>
511
512 get size/line of bytecode in ops till now
513
514 =cut
515
516 */
517
518 PARROT_WARN_UNUSED_RESULT
519 static int
520 get_old_size(PARROT_INTERP, ARGOUT(int *ins_line))
521 {
522 size_t size = 0;
523
524 *ins_line = 0;
525
526 if (globals.cs && interp->code->base.data) {
527 subs_t *s;
528 for (s = globals.cs->subs; s; s = s->prev) {
529 size += s->size;
530 *ins_line += s->ins_line;
531 }
532 }
533
534 return size;
535 }
536
537 /*
538
539 =item C<static void store_sub_size>
540
541 RT #48260: Not yet documented!!!
542
543 =cut
544
545 */
546
547 static void
548 store_sub_size(size_t size, size_t ins_line)
549 {
550 globals.cs->subs->size = size;
551 globals.cs->subs->ins_line = ins_line;
552 }
553
554 /*
555
556 =item C<static void store_fixup>
557
558 RT #48260: Not yet documented!!!
559
560 =cut
561
562 */
563
564 static void
565 store_fixup(PARROT_INTERP, ARGIN(const SymReg *r), int pc, int offset)
566 {
567 SymReg * const fixup = _mk_address(interp, &globals.cs->subs->fixup,
568 r->name, U_add_all);
569
570 if (r->set == 'p')
571 fixup->set = 'p';
572
573 if (r->type & VT_ENCODED)
574 fixup->type |= VT_ENCODED;
575
576 /* set_p_pc = 2 */
577 fixup->color = pc;
578 fixup->offset = offset;
579 }
580
581 /*
582
583 =item C<static void store_key_const>
584
585 RT #48260: Not yet documented!!!
586
587 =cut
588
589 */
590
591 static void
592 store_key_const(ARGIN(const char *str), int idx)
593 {
594 SymReg * const c = _mk_const(&globals.cs->key_consts, str, 0);
595 c->color = idx;
596 }
597
598 /*
599
600 =item C<static int get_codesize>
601
602 store globals for later fixup
603 return size in ops
604
605 =cut
606
607 */
608
609 PARROT_WARN_UNUSED_RESULT
610 static int
611 get_codesize(PARROT_INTERP, ARGIN(const IMC_Unit *unit), ARGOUT(int *src_lines))
612 {
613 Instruction *ins = unit->instructions;
614 int code_size;
615
616 /* run through instructions:
617 * - sanity check
618 * - calc code size
619 * - calc nr of src lines for debug info
620 * - remember addr of labels
621 * - remember set_p_pc for global fixup
622 */
623
624 *src_lines = 0;
625
626 for (code_size = 0; ins ; ins = ins->next) {
627 if (ins->type & ITLABEL)
628 ins->symregs[0]->color = code_size;
629
630 if (ins->opname && *ins->opname) {
631 (*src_lines)++;
632 if (ins->opnum < 0)
633 IMCC_fatal(interp, 1, "get_codesize: "
634 "no opnum ins#%d %I\n",
635 ins->index, ins);
636
637 if (ins->opnum == PARROT_OP_set_p_pc) {
638 /* set_p_pc opcode */
639 IMCC_debug(interp, DEBUG_PBC_FIXUP, "PMC constant %s\n",
640 ins->symregs[1]->name);
641
642 if (ins->symregs[1]->usage & U_FIXUP)
643 store_fixup(interp, ins->symregs[1], code_size, 2);
644 }
645
646 code_size += ins->opsize;
647 }
648 else if (ins->opsize)
649 IMCC_fatal(interp, 1, "get_codesize: "
650 "non instruction with size found\n");
651 }
652
653 return code_size;
654 }
655
656
657 /*
658
659 =item C<static subs_t * find_global_label>
660
661 get a global label, return the pc (absolute)
662
663 =cut
664
665 */
666
667 PARROT_WARN_UNUSED_RESULT
668 PARROT_CAN_RETURN_NULL
669 static subs_t *
670 find_global_label(ARGIN(const char *name), ARGIN(const subs_t *sym), ARGOUT(int *pc))
671 {
672 subs_t *s;
673
674 *pc = 0;
675
676 for (s = globals.cs->first; s; s = s->next) {
677 SymReg * const r = s->unit->instructions->symregs[0];
678
679 /* if names and namespaces are matching - ok */
680 if (r && (strcmp(r->name, name) == 0)
681 && ((sym->unit->_namespace && s->unit->_namespace
682 && (strcmp(sym->unit->_namespace->name, s->unit->_namespace->name) == 0))
683 || (!sym->unit->_namespace && !s->unit->_namespace)))
684 return s;
685
686 *pc += s->size;
687 }
688
689 return NULL;
690 }
691
692 /*
693
694 =item C<static void fixup_globals>
695
696 fix global stuff
697
698 =cut
699
700 */
701
702 static void
703 fixup_globals(PARROT_INTERP)
704 {
705 subs_t *s;
706 int jumppc = 0;
707
708 for (s = globals.cs->first; s; s = s->next) {
709 const SymHash * const hsh = &s->fixup;
710 int i;
711
712 for (i = 0; i < hsh->size; i++) {
713 SymReg *fixup;
714 for (fixup = hsh->data[i]; fixup; fixup = fixup->next) {
715 int pc, pmc_const;
716 int addr = jumppc + fixup->color;
717
718 /* check in matching namespace */
719 subs_t *s1 = find_global_label(fixup->name, s, &pc);
720
721 /*
722 * if failed change opcode:
723 * set_p_pc => find_name p_sc
724 * if a sub label is found
725 * convert to find_name, if the sub is a multi
726 */
727 if (s1) {
728 PARROT_ASSERT(s1->unit);
729 if (s1->unit->type & IMC_PCCSUB) {
730 const Instruction * const ins = s1->unit->instructions;
731 SymReg *r1;
732 pcc_sub_t *pcc_sub;
733
734 PARROT_ASSERT(ins);
735
736 r1 = ins->symregs[0];
737 PARROT_ASSERT(r1);
738
739 pcc_sub = r1->pcc_sub;
740 PARROT_ASSERT(pcc_sub);
741
742 /* if the sub is multi, don't insert constant */
743 if (pcc_sub->nmulti)
744 s1 = NULL;
745 }
746 }
747 if (!s1) {
748 int op, col;
749 SymReg * const nam = mk_const(interp, fixup->name,
750 fixup->type & VT_ENCODED ? 'U' : 'S');
751
752 op = interp->op_lib->op_code("find_sub_not_null_p_sc", 1);
753 PARROT_ASSERT(op);
754
755 interp->code->base.data[addr] = op;
756
757 if (nam->color >= 0)
758 col = nam->color;
759 else
760 col = nam->color = add_const_str(interp, nam);
761
762 interp->code->base.data[addr+2] = col;
763
764 IMCC_debug(interp, DEBUG_PBC_FIXUP,
765 "fixup const PMC"
766 " find_name sub '%s' const nr: %d\n",
767 fixup->name, col);
768 continue;
769 }
770
771 pmc_const = s1->pmc_const;
772
773 if (pmc_const < 0) {
774 IMCC_fatal(interp, 1, "fixup_globals: "
775 "couldn't find sub 2 '%s'\n", fixup->name);
776 }
777
778 interp->code->base.data[addr+fixup->offset] = pmc_const;
779 IMCC_debug(interp, DEBUG_PBC_FIXUP, "fixup const PMC"
780 " sub '%s' const nr: %d\n", fixup->name, pmc_const);
781
782 continue;
783 }
784 }
785
786 jumppc += s->size;
787 }
788 }
789
790 /*
791
792 =item C<STRING * IMCC_string_from_reg>
793
794 RT #48260: Not yet documented!!!
795
796 =cut
797
798 */
799
800 PARROT_WARN_UNUSED_RESULT
801 PARROT_CANNOT_RETURN_NULL
802 STRING *
803 IMCC_string_from_reg(PARROT_INTERP, ARGIN(const SymReg *r))
804 {
805 const char *buf = r->name;
806
807 if (r->type & VT_ENCODED) {
808 /*
809 * the lexer parses: foo:"string"
810 * get first part as charset, rest as string
811 */
812 STRING *s;
813 const char *charset;
814 char * const p = strchr(r->name, '"');
815 PARROT_ASSERT(p && p[-1] == ':');
816
817 p[-1] = 0;
818 charset = r->name;
819
820 /* past delim */
821 buf = p + 1;
822 s = string_unescape_cstring(interp, buf, '"', charset);
823
824 /* restore colon, as we may reuse this string */
825 p[-1] = ':';
826 return s;
827 }
828 else if (*buf == '"') {
829 buf++;
830 return string_unescape_cstring(interp, buf, '"', NULL);
831 }
832 else if (*buf == '\'') { /* TODO handle python raw strings */
833 buf++;
834 return string_make(interp, buf, strlen(buf) - 1, "ascii",
835 PObj_constant_FLAG);
836 }
837
838 /* unquoted bare name - ascii only don't unescape it */
839 return string_make(interp, buf, strlen(buf), "ascii", PObj_constant_FLAG);
840 }
841
842 /*
843
844 =item C<static int add_const_str>
845
846 add constant string to constant_table
847
848 =cut
849
850 */
851
852 PARROT_WARN_UNUSED_RESULT
853 static int
854 add_const_str(PARROT_INTERP, ARGIN(const SymReg *r))
855 {
856 const int k = add_const_table(interp);
857 STRING * const s = IMCC_string_from_reg(interp, r);
858
859 interp->code->const_table->constants[k]->type = PFC_STRING;
860 interp->code->const_table->constants[k]->u.string = s;
861
862 return k;
863 }
864
865 /*
866
867 =item C<static int add_const_num>
868
869 RT #48260: Not yet documented!!!
870
871 =cut
872
873 */
874
875 PARROT_WARN_UNUSED_RESULT
876 static int
877 add_const_num(PARROT_INTERP, ARGIN_NULLOK(const char *buf))
878 {
879 const int k = add_const_table(interp);
880 STRING * const s = string_from_cstring(interp, buf, 0);
881
882 interp->code->const_table->constants[k]->type = PFC_NUMBER;
883 interp->code->const_table->constants[k]->u.number = string_to_num(interp, s);
884
885 return k;
886 }
887
888 /*
889
890 =item C<static PMC* mk_multi_sig>
891
892 RT #48260: Not yet documented!!!
893
894 =cut
895
896 */
897
898 PARROT_CANNOT_RETURN_NULL
899 PARROT_MALLOC
900 static PMC*
901 mk_multi_sig(PARROT_INTERP, ARGIN(const SymReg *r))
902 {
903 PMC * const multi_sig = pmc_new(interp, enum_class_FixedPMCArray);
904 pcc_sub_t * const pcc_sub = r->pcc_sub;
905 const INTVAL n = pcc_sub->nmulti;
906 INTVAL i;
907
908 PackFile_ConstTable *ct;
909
910 VTABLE_set_integer_native(interp, multi_sig, n);
911
912 /* :multi() n = 1, reg = NULL */
913 if (!pcc_sub->multi[0]) {
914 STRING * const sig = string_from_literal(interp, "__VOID");
915 PMC * const sig_pmc = pmc_new(interp, enum_class_String);
916
917 VTABLE_set_string_native(interp, sig_pmc, sig);
918 VTABLE_set_pmc_keyed_int(interp, multi_sig, 0, sig_pmc);
919
920 return multi_sig;
921 }
922
923 ct = interp->code->const_table;
924
925 for (i = 0; i < n; ++i) {
926 /* multi[i] can be a Key too -
927 * store PMC constants instead of bare strings */
928 PMC *sig_pmc;
929 r = pcc_sub->multi[i];
930
931 if (r->set == 'S') {
932 sig_pmc = pmc_new(interp, enum_class_String);
933 VTABLE_set_string_native(interp, sig_pmc,
934 ct->constants[r->color]->u.string);
935 }
936 else {
937 PARROT_ASSERT(r->set == 'K');
938 sig_pmc = ct->constants[r->color]->u.key;
939 }
940
941 VTABLE_set_pmc_keyed_int(interp, multi_sig, i, sig_pmc);
942 }
943
944 return multi_sig;
945 }
946
947 typedef void (*decl_func_t)(Interp *, PMC *, STRING *, INTVAL);
948
949 /*
950
951 =item C<static PMC* create_lexinfo>
952
953 RT #48260: Not yet documented!!!
954
955 =cut
956
957 */
958
959 PARROT_WARN_UNUSED_RESULT
960 PARROT_CANNOT_RETURN_NULL
961 static PMC*
962 create_lexinfo(PARROT_INTERP, ARGMOD(IMC_Unit *unit), ARGIN(PMC *sub),
963 int need_lex)
964 {
965 int i;
966
967 PMC *lex_info = NULL;
968 SymHash *hsh = &unit->hash;
969 PackFile_Constant **constants = interp->code->const_table->constants;
970 const INTVAL lex_info_id = Parrot_get_ctx_HLL_type(interp,
971 enum_class_LexInfo);
972
973 for (i = 0; i < hsh->size; i++) {
974 SymReg *r;
975 for (r = hsh->data[i]; r; r = r->next) {
976 if (r->set == 'P' && r->usage & U_LEXICAL) {
977 SymReg *n;
978 if (!lex_info) {
979 lex_info = pmc_new_noinit(interp, lex_info_id);
980 VTABLE_init_pmc(interp, lex_info, sub);
981 }
982
983 /* at least one lexical name */
984 n = r->reg;
985 PARROT_ASSERT(n);
986
987 while (n) {
988 STRING *lex_name;
989 const int k = n->color;
990 PARROT_ASSERT(k >= 0);
991
992 lex_name = constants[k]->u.string;
993 PARROT_ASSERT(PObj_is_string_TEST(lex_name));
994
995 IMCC_debug(interp, DEBUG_PBC_CONST,
996 "add lexical '%s' to sub name '%s'\n",
997 n->name, (char*)PMC_sub(sub)->name->strstart);
998
999 Parrot_PCCINVOKE(interp, lex_info,
1000 string_from_literal(interp, "declare_lex_preg"),
1001 "SI->", lex_name, r->color);
1002
1003 /* next possible name */
1004 n = n->reg;
1005 }
1006 }
1007 }
1008 }
1009
1010 if (!lex_info && (unit->outer || need_lex)) {
1011 lex_info = pmc_new_noinit(interp, lex_info_id);
1012 VTABLE_init_pmc(interp, lex_info, sub);
1013 }
1014
1015 return lex_info;
1016 }
1017
1018 /*
1019
1020 =item C<static PMC* find_outer>
1021
1022 RT #48260: Not yet documented!!!
1023
1024 =cut
1025
1026 */
1027
1028 PARROT_WARN_UNUSED_RESULT
1029 PARROT_CAN_RETURN_NULL
1030 static PMC*
1031 find_outer(PARROT_INTERP, ARGIN(const IMC_Unit *unit))
1032 {
1033 subs_t *s;
1034 size_t len;
1035 PMC *current;
1036 STRING *cur_name;
1037
1038 if (!unit->outer)
1039 return NULL;
1040
1041 /*
1042 * we need that the :outer sub is already compiled,
1043 * because we are freezing the outer Sub PMC along with this
1044 * one
1045 */
1046
1047 len = strlen(unit->outer->name);
1048
1049 if (!len)
1050 return NULL;
1051
1052 for (s = globals.cs->first; s; s = s->next) {
1053 if (STREQ(s->unit->lexid->name, unit->outer->name)) {
1054 PObj_get_FLAGS(s->unit->sub_pmc) |= SUB_FLAG_IS_OUTER;
1055 return s->unit->sub_pmc;
1056 }
1057 }
1058
1059 /* could be eval too; check if :outer is the current sub */
1060 current = CONTEXT(interp)->current_sub;
1061
1062 if (!current)
1063 IMCC_fatal(interp, 1, "Undefined :outer sub '%s'.\n",
1064 unit->outer->name);
1065
1066 cur_name = PMC_sub(current)->name;
1067
1068 if (cur_name->strlen == len
1069 && (memcmp((char*)cur_name->strstart, unit->outer->name, len) == 0))
1070 return current;
1071
1072 return NULL;
1073 }
1074
1075 /*
1076
1077 =item C<static int add_const_pmc_sub>
1078
1079 RT #48260: Not yet documented!!!
1080
1081 =cut
1082
1083 */
1084
1085 static int
1086 add_const_pmc_sub(PARROT_INTERP, ARGMOD(SymReg *r), int offs, int end)
1087 {
1088 int i;
1089 int ns_const = -1;
1090 PMC *ns_pmc;
1091 PMC *sub_pmc;
1092 Parrot_sub *sub;
1093
1094 const int k = add_const_table(interp);
1095 IMC_Unit * const unit = globals.cs->subs->unit;
1096 PackFile_ConstTable *ct = interp->code->const_table;
1097 PackFile_Constant *pfc = ct->constants[k];
1098
1099 INTVAL type =
1100 (r->pcc_sub->calls_a_sub & ITPCCYIELD) ?
1101 enum_class_Coroutine :
1102 unit->outer ? enum_class_Closure : enum_class_Sub;
1103
1104 globals.cs->subs->pmc_const = k;
1105
1106 if (unit->_namespace) {
1107 /* strip namespace off from front */
1108 const char *real_name = strrchr(r->name, '@');
1109 SymReg * const ns = unit->_namespace->reg;
1110
1111 IMCC_debug(interp, DEBUG_PBC_CONST,
1112 "name space const = %d ns name '%s'\n", ns->color, ns->name);
1113
1114 ns_const = ns->color;
1115
1116 if (real_name) {
1117 char * const p = str_dup(real_name + 1);
1118 free(r->name);
1119 r->name = p;
1120 }
1121 }
1122
1123 /* Do we have to create an instance of a specific type for this sub? */
1124 if (unit->instance_of) {
1125 /* Look it up as a class and as a PMC type. */
1126 STRING * const classname = string_from_cstring(interp, unit->instance_of + 1,
1127 strlen(unit->instance_of) - 2);
1128 PMC * const classobj = Parrot_oo_get_class_str(interp, classname);
1129 if (!PMC_IS_NULL(classobj))
1130 sub_pmc = VTABLE_instantiate(interp, classobj, PMCNULL);
1131 else {
1132 const INTVAL type = pmc_type(interp, classname);
1133 if (type <= 0)
1134 Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_NO_CLASS,
1135 "Class '%Ss' specified in :instanceof(...) not found", classname);
1136 sub_pmc = pmc_new(interp, type);
1137 }
1138 }
1139 else {
1140 /* use a possible type mapping for the Sub PMCs, and create it */
1141 type = Parrot_get_ctx_HLL_type(interp, type);
1142
1143 /* TODO create constant - see also src/packfile.c */
1144 sub_pmc = pmc_new(interp, type);
1145 }
1146
1147 /* Set flags and get the sub info. */
1148 PObj_get_FLAGS(sub_pmc) |= (r->pcc_sub->pragma & SUB_FLAG_PF_MASK);
1149 Sub_comp_get_FLAGS(sub_pmc) |= (r->pcc_sub->pragma & SUB_COMP_FLAG_MASK);
1150 sub = PMC_sub(sub_pmc);
1151
1152 r->color = add_const_str(interp, r);
1153 sub->name = ct->constants[r->color]->u.string;
1154
1155 /* If the unit has no lexid, set the lexid to match the name. */
1156 if (!unit->lexid) {
1157 unit->lexid = r;
1158 }
1159 else {
1160 /* trim the quotes */
1161 unit->lexid->name = str_dup(unit->lexid->name + 1);
1162
1163 /* Otherwise, create string constant for it. */
1164 unit->lexid->name[strlen(unit->lexid->name) - 1] = 0;
1165 unit->lexid->color = add_const_str(interp, unit->lexid);
1166 }
1167 sub->lexid = ct->constants[unit->lexid->color]->u.string;
1168
1169 ns_pmc = NULL;
1170
1171 if (ns_const >= 0 && ns_const < ct->const_count) {
1172 switch (ct->constants[ns_const]->type) {
1173 case PFC_KEY:
1174 ns_pmc = ct->constants[ns_const]->u.key;
1175 break;
1176 case PFC_STRING:
1177 ns_pmc = constant_pmc_new(interp, enum_class_String);
1178 PMC_str_val(ns_pmc) = ct->constants[ns_const]->u.string;
1179 break;
1180 default:
1181 break;
1182 }
1183 }
1184
1185 sub->namespace_name = ns_pmc;
1186 sub->start_offs = offs;
1187 sub->end_offs = end;
1188 sub->HLL_id = CONTEXT(interp)->current_HLL;
1189
1190 for (i = 0; i < 4; ++i)
1191 sub->n_regs_used[i] = unit->n_regs_used[i];
1192
1193 sub->lex_info = create_lexinfo(interp, unit, sub_pmc,
1194 r->pcc_sub->pragma & P_NEED_LEX);
1195 sub->outer_sub = find_outer(interp, unit);
1196 sub->vtable_index = -1;
1197
1198 /* check if it's declared multi */
1199 if (r->pcc_sub->nmulti)
1200 sub->multi_signature = mk_multi_sig(interp, r);
1201 else
1202 sub->multi_signature = NULL;
1203
1204 if (unit->is_vtable_method == 1) {
1205 STRING *vtable_name;
1206 INTVAL vtable_index;
1207
1208 /* Work out the name of the vtable method. */
1209 if (unit->vtable_name)
1210 vtable_name = string_from_cstring(interp, unit->vtable_name + 1,
1211 strlen(unit->vtable_name) - 2);
1212 else
1213 vtable_name = sub->name;
1214
1215 /* Check this is a valid vtable method to override. */
1216 vtable_index = Parrot_get_vtable_index(interp, vtable_name);
1217
1218 if (vtable_index == -1) {
1219 IMCC_fatal(interp, 1,
1220 "'%S' is not a v-table method, but was used with :vtable.\n",
1221 vtable_name);
1222 }
1223
1224 /* TODO check for duplicates */
1225 sub->vtable_index = vtable_index;
1226 }
1227
1228 Parrot_store_sub_in_namespace(interp, sub_pmc);
1229
1230 pfc->type = PFC_PMC;
1231 pfc->u.key = sub_pmc;
1232 unit->sub_pmc = sub_pmc;
1233
1234 IMCC_debug(interp, DEBUG_PBC_CONST,
1235 "add_const_pmc_sub '%s' flags %x color %d (%s) "
1236 "lex_info %s :outer(%s)\n",
1237 r->name, r->pcc_sub->pragma, k,
1238 (char *) sub_pmc->vtable->whoami->strstart,
1239 sub->lex_info ? "yes" : "no",
1240 sub->outer_sub ?
1241 (char *)PMC_sub(sub->outer_sub)->name->strstart :
1242 "*none*");
1243 /*
1244 * create entry in our fixup (=symbol) table
1245 * the offset is the index in the constant table of this Sub
1246 */
1247 PackFile_FixupTable_new_entry(interp, r->name, enum_fixup_sub, k);
1248 return k;
1249 }
1250
1251 /*
1252
1253 =item C<static int add_const_key>
1254
1255 add constant key to constant_table
1256
1257 =cut
1258
1259 */
1260
1261 static int
1262 add_const_key(PARROT_INTERP, ARGIN(const opcode_t *key), int size, ARGIN(const char *s_key))
1263 {
1264 int k;
1265 const opcode_t *rc;
1266 PackFile_Constant *pfc;
1267
1268 const SymReg * const r = _get_sym(&globals.cs->key_consts, s_key);
1269
1270 if (r)
1271 return r->color;
1272
1273 pfc = mem_allocate_typed(PackFile_Constant);
1274 rc = PackFile_Constant_unpack_key(interp,
1275 interp->code->const_table, pfc, key);
1276
1277 if (!rc) {
1278 mem_sys_free(pfc);
1279 IMCC_fatal(interp, 1,
1280 "add_const_key: PackFile_Constant error\n");
1281 }
1282
1283 k = add_const_table_key(interp, pfc->u.key);
1284
1285 store_key_const(s_key, k);
1286
1287 IMCC_debug(interp, DEBUG_PBC_CONST, "\t=> %s #%d size %d\n",
1288 s_key, k, size);
1289 IMCC_debug(interp, DEBUG_PBC_CONST, "\t %x /%x %x/ /%x %x/\n",
1290 key[0], key[1], key[2], key[3], key[4]);
1291
1292 mem_sys_free(pfc);
1293
1294 return k;
1295 }
1296
1297 /*
1298
1299 =item C<static const char * slice_deb>
1300
1301 RT #48260: Not yet documented!!!
1302
1303 =cut
1304
1305 */
1306
1307 PARROT_CONST_FUNCTION
1308 PARROT_WARN_UNUSED_RESULT
1309 PARROT_CANNOT_RETURN_NULL
1310 static const char *
1311 slice_deb(int bits)
1312 {
1313 if ((bits & VT_SLICE_BITS) == (VT_START_SLICE|VT_END_SLICE))
1314 return "start+end";
1315
1316 if ((bits & VT_SLICE_BITS) == (VT_START_ZERO|VT_END_SLICE))
1317 return "..end";
1318
1319 if ((bits & VT_SLICE_BITS) == (VT_START_SLICE|VT_END_INF))
1320 return "start..";
1321
1322 if (bits & VT_START_SLICE)
1323 return "start";
1324
1325 if (bits & VT_END_SLICE)
1326 return "end";
1327
1328 return "";
1329 }
1330
1331 /*
1332
1333 =item C<static opcode_t build_key>
1334
1335 color is a Parrot register number or a constant table index
1336
1337 for the rest, please consult PDD08_KEYS(1)
1338
1339 additionally, I build a string representation of the key,
1340 which gets cached in the globals.keys
1341
1342 =cut
1343
1344 */
1345
1346 static opcode_t
1347 build_key(PARROT_INTERP, ARGIN(SymReg *key_reg))
1348 {
1349 #define KEYLEN 21
1350 char s_key[KEYLEN * 10];
1351 opcode_t key[KEYLEN];
1352 opcode_t size;
1353 int key_length; /* P0["hi;there"; S0; 2] has length 3 */
1354 int k;
1355 SymReg *reg;
1356
1357 /* 0 is length */
1358 opcode_t *pc = key + 1;
1359
1360 /* stringified key */
1361 char *s = s_key;
1362 *s = 0;
1363
1364 reg = key_reg->set == 'K' ? key_reg->nextkey : key_reg;
1365
1366 for (key_length = 0; reg ; reg = reg->nextkey, key_length++) {
1367 SymReg *r = reg;
1368 int var_type, slice_bits, type;
1369
1370 if ((pc - key - 2) >= KEYLEN)
1371 IMCC_fatal(interp, 1, "build_key:"
1372 "key too complex increase KEYLEN\n");
1373
1374 /* if key is a register, the original sym is in r->reg */
1375 type = r->type;
1376
1377 if (r->reg)
1378 r = r->reg;
1379
1380 var_type = type & ~VT_SLICE_BITS;
1381 slice_bits = type & VT_SLICE_BITS;
1382
1383 switch (var_type) {
1384 case VTIDENTIFIER: /* P[S0] */
1385 case VTPASM: /* P[S0] */
1386 case VTREG: /* P[S0] */
1387 if (r->set == 'I')
1388 *pc++ = PARROT_ARG_I | slice_bits; /* register type */
1389 else if (r->set == 'S')
1390 *pc++ = PARROT_ARG_S | slice_bits;
1391 else
1392 IMCC_fatal(interp, 1, "build_key: wrong register set\n");
1393
1394 /* don't emit mapped regs in key parts */
1395 if (r->color < 0)
1396 *pc++ = -1 - r->color;
1397 else
1398 *pc++ = r->color;
1399
1400 sprintf(s+strlen(s), "%c%d", r->set, (int)r->color);
1401
1402 IMCC_debug(interp, DEBUG_PBC_CONST,
1403 " keypart reg %s %c%d slice %s\n",
1404 r->name, r->set, (int)r->color,
1405 slice_deb(slice_bits));
1406 break;
1407 case VT_CONSTP:
1408 case VTCONST:
1409 case VTCONST|VT_ENCODED:
1410 switch (r->set) {
1411 case 'S': /* P["key"] */
1412 /* str constant */
1413 *pc++ = PARROT_ARG_SC | slice_bits;
1414
1415 /* constant idx */
1416 *pc++ = r->color;
1417
1418 IMCC_debug(interp, DEBUG_PBC_CONST,
1419 " keypart SC %s #%d slice %s\n",
1420 r->name, r->color,
1421 slice_deb(slice_bits));
1422 break;
1423 case 'I': /* P[;42;..] */
1424 /* int constant */
1425 *pc++ = PARROT_ARG_IC | slice_bits;
1426
1427 /* value */
1428 *pc++ = r->color = atol(r->name);
1429
1430 IMCC_debug(interp, DEBUG_PBC_CONST,
1431 " keypart IC %s #%d slice %s\n",
1432 r->name, r->color,
1433 slice_deb(slice_bits));
1434 break;
1435 default:
1436 IMCC_fatal(interp, 1, "build_key: unknown set\n");
1437 }
1438 sprintf(s+strlen(s), "%cc" INTVAL_FMT, r->set, r->color);
1439 break;
1440 default:
1441 IMCC_fatal(interp, 1, "build_key: "
1442 "unknown type 0x%x on %s\n", var_type, r->name);
1443 }
1444 }
1445
1446 key[0] = key_length;
1447 size = pc - key;
1448
1449 /* now we have a packed key, which packfile can work on */
1450 /* XXX endianess? probably no, we pack/unpack on the very
1451 * same computer */
1452 k = add_const_key(interp, key, size, s_key);
1453
1454 /* single 'S' keys already have their color assigned */
1455 if (key_reg->set == 'K')
1456 key_reg->color = k;
1457
1458 return k;
1459 }
1460
1461 /*
1462
1463 =item C<INTVAL IMCC_int_from_reg>
1464
1465 RT #48260: Not yet documented!!!
1466
1467 =cut
1468
1469 */
1470
1471 INTVAL
1472 IMCC_int_from_reg(PARROT_INTERP, ARGIN(const SymReg *r))
1473 {
1474 INTVAL i;
1475
1476 errno = 0;
1477
1478 if (r->type & VT_CONSTP)
1479 r = r->reg;
1480
1481 if (r->name[0] == '0' && (r->name[1] == 'x' || r->name[1] == 'X'))
1482 i = strtoul(r->name+2, 0, 16);
1483
1484 else if (r->name[0] == '0' && (r->name[1] == 'O' || r->name[1] == 'o'))
1485 i = strtoul(r->name+2, 0, 8);
1486
1487 else if (r->name[0] == '0' && (r->name[1] == 'b' || r->name[1] == 'B'))
1488 i = strtoul(r->name+2, 0, 2);
1489
1490 else
1491 i = strtol(r->name, 0, 10);
1492
1493 /*
1494 * TODO
1495 * - is this portable?
1496 * - there are some more atol()s in this file
1497 */
1498 if (errno == ERANGE)
1499 IMCC_fatal(interp, 1, "add_1_const:" "Integer overflow '%s'", r->name);
1500
1501 return i;
1502 }
1503
1504 /*
1505
1506 =item C<static void make_pmc_const>
1507
1508 RT #48260: Not yet documented!!!
1509
1510 =cut
1511
1512 */
1513
1514 static void
1515 make_pmc_const(PARROT_INTERP, ARGMOD(SymReg *r))
1516 {
1517 STRING *s;
1518 PMC *p;
1519 PMC *_class = interp->vtables[r->pmc_type]->pmc_class;
1520 int k;
1521
1522 if (*r->name == '"')
1523 s = string_unescape_cstring(interp, r->name + 1, '"', NULL);
1524
1525 else if (*r->name == '\'')
1526 s = string_unescape_cstring(interp, r->name + 1, '\'', NULL);
1527
1528 else
1529 s = string_unescape_cstring(interp, r->name, 0, NULL);
1530
1531 p = VTABLE_new_from_string(interp, _class, s, PObj_constant_FLAG);
1532
1533 /* append PMC constant */
1534 k = add_const_table_pmc(interp, p);
1535
1536 r->color = k;
1537 }
1538
1539 /*
1540
1541 =item C<static void add_1_const>
1542
1543 RT #48260: Not yet documented!!!
1544
1545 =cut
1546
1547 */
1548
1549 static void
1550 add_1_const(PARROT_INTERP, ARGMOD(SymReg *r))
1551 {
1552 if (r->color >= 0)
1553 return;
1554
1555 if (r->use_count <= 0)
1556 return;
1557
1558 switch (r->set) {
1559 case 'I':
1560 r->color = IMCC_int_from_reg(interp, r);
1561 break;
1562 case 'S':
1563 if (r->type & VT_CONSTP)
1564 r = r->reg;
1565 r->color = add_const_str(interp, r);
1566 break;
1567 case 'N':
1568 r->color = add_const_num(interp, r->name);
1569 break;
1570 case 'K':
1571 {
1572 SymReg *key = r;
1573
1574 for (r = r->nextkey; r; r = r->nextkey)
1575 if (r->type & VTCONST)
1576 add_1_const(interp, r);
1577 build_key(interp, key);
1578 }
1579 break;
1580 case 'P':
1581 make_pmc_const(interp, r);
1582 IMCC_debug(interp, DEBUG_PBC_CONST,
1583 "PMC const %s\tcolor %d\n", r->name, r->color);
1584 break;
1585 default:
1586 break;
1587 }
1588
1589 if (r)
1590 IMCC_debug(interp, DEBUG_PBC_CONST, "const %s\tcolor %d use_count %d\n",
1591 r->name, r->color, r->use_count);
1592 }
1593
1594 /*
1595
1596 =item C<static void constant_folding>
1597
1598 store a constants idx for later reuse
1599
1600 =cut
1601
1602 */
1603
1604 static void
1605 constant_folding(PARROT_INTERP, ARGIN(const IMC_Unit *unit))
1606 {
1607 int i;
1608 const SymHash *hsh = &IMCC_INFO(interp)->ghash;
1609
1610 /* go through all consts of current sub */
1611 for (i = 0; i < hsh->size; i++) {
1612 SymReg *r;
1613 /* normally constants are in ghash ... */
1614 for (r = hsh->data[i]; r; r = r->next) {
1615 if (r->type & (VTCONST|VT_CONSTP))
1616 add_1_const(interp, r);
1617
1618 if (r->usage & U_LEXICAL) {
1619 SymReg *n = r->reg;
1620
1621 /* r->reg is a chain of names for the same lex sym */
1622 while (n) {
1623 /* lex_name */
1624 add_1_const(interp, n);
1625 n = n->reg;
1626 }
1627 }
1628 }
1629 }
1630
1631 /* ... but keychains 'K' are in local hash, they may contain
1632 * variables and constants */
1633 hsh = &unit->hash;
1634
1635 for (i = 0; i < hsh->size; i++) {
1636 SymReg *r;
1637 /* normally constants are in ghash ... */
1638 for (r = hsh->data[i]; r; r = r->next) {
1639 if (r->type & VTCONST)
1640 add_1_const(interp, r);
1641 }
1642 }
1643
1644 /* and finally, there may be an outer Sub */
1645 if (unit->outer)
1646 add_1_const(interp, unit->outer);
1647 }
1648
1649 /*
1650
1651 =item C<int e_pbc_new_sub>
1652
1653 RT #48260: Not yet documented!!!
1654
1655 =cut
1656
1657 */
1658
1659 int
1660 e_pbc_new_sub(SHIM_INTERP, SHIM(void *param), ARGIN(IMC_Unit *unit))
1661 {
1662 if (!unit->instructions)
1663 return 0;
1664
1665 /* we start a new compilation unit */
1666 make_new_sub(unit);
1667
1668 return 0;
1669 }
1670
1671 /*
1672
1673 =item C<int e_pbc_end_sub>
1674
1675 RT #48260: Not yet documented!!!
1676
1677 =cut
1678
1679 */
1680
1681 int
1682 e_pbc_end_sub(PARROT_INTERP, SHIM(void *param), ARGIN(IMC_Unit *unit))
1683 {
1684 Instruction *ins;
1685 int pragma;
1686
1687 if (!unit->instructions)
1688 return 0;
1689
1690 /*
1691 * if the sub was marked IMMEDIATE, we run it now
1692 * This is *dangerous*: all possible global state can be messed
1693 * up, e.g. when that sub starts loading bytecode
1694 */
1695 ins = unit->instructions;
1696
1697 /* we run only PCC subs */
1698 if (!ins->symregs[0] || !ins->symregs[0]->pcc_sub)
1699 return 0;
1700
1701 pragma = ins->symregs[0]->pcc_sub->pragma;
1702
1703 if (pragma & P_IMMEDIATE) {
1704 IMCC_debug(interp, DEBUG_PBC, "immediate sub '%s'",
1705 ins->symregs[0]->name);
1706 PackFile_fixup_subs(interp, PBC_IMMEDIATE, NULL);
1707 }
1708
1709 return 0;
1710 }
1711
1712 /*
1713
1714 =item C<static void verify_signature>
1715
1716 - check if any get_ argument contains constants
1717 - fill in type bits for argument types and constants, if missing
1718
1719 =cut
1720
1721 */
1722
1723 static void
1724 verify_signature(PARROT_INTERP, ARGIN(const Instruction *ins), ARGIN(opcode_t *pc))
1725 {
1726 INTVAL i, n;
1727 int needed = 0;
1728 int no_consts = (ins->opnum == PARROT_OP_get_results_pc
1729 || ins->opnum == PARROT_OP_get_params_pc);
1730 PMC *changed_sig = NULL;
1731 PMC * const sig_arr = interp->code->const_table->constants[pc[-1]]->u.key;
1732
1733 PARROT_ASSERT(PObj_is_PMC_TEST(sig_arr));
1734 PARROT_ASSERT(sig_arr->vtable->base_type == enum_class_FixedIntegerArray);
1735
1736 n = VTABLE_elements(interp, sig_arr);
1737
1738 if (n != ins->symreg_count - 1)
1739 IMCC_fatal(interp, 1, "syntax error: parameter count mismatch in '%s'"
1740 " -- have %d, want %d",
1741 ins->opname, ins->symreg_count - 1, n);
1742
1743 for (i = 0; i < n; ++i) {
1744 SymReg * const r = ins->symregs[i + 1];
1745 INTVAL sig = VTABLE_get_integer_keyed_int(interp, sig_arr, i);
1746
1747 if (! (sig & PARROT_ARG_NAME)
1748 && no_consts && (r->type & VTCONST))
1749 IMCC_fatal(interp, 1, "e_pbc_emit: "
1750 "constant argument '%s' in get param/result\n", r->name);
1751
1752 if ((r->type & VTCONST) && !(sig & PARROT_ARG_CONSTANT)) {
1753 if (!changed_sig)
1754 changed_sig = VTABLE_clone(interp, sig_arr);
1755
1756 sig |= PARROT_ARG_CONSTANT;
1757
1758 VTABLE_set_integer_keyed_int(interp, changed_sig, i, sig);
1759 }
1760
1761 switch (r->set) {
1762 case 'I': needed = PARROT_ARG_INTVAL; break;
1763 case 'S': needed = PARROT_ARG_STRING; break;
1764 case 'P': needed = PARROT_ARG_PMC; break;
1765 case 'N': needed = PARROT_ARG_FLOATVAL; break;
1766 default : break;
1767 }
1768
1769 if (needed != (sig & PARROT_ARG_TYPE_MASK)) {
1770 if (!changed_sig)
1771 changed_sig = VTABLE_clone(interp, sig_arr);
1772
1773 sig &= ~PARROT_ARG_TYPE_MASK;
1774 sig |= needed;
1775
1776 VTABLE_set_integer_keyed_int(interp, changed_sig, i, sig);
1777 }
1778 }
1779
1780 if (changed_sig) {
1781 /* append PMC constant */
1782 const int k = add_const_table_pmc(interp, changed_sig);
1783 pc[-1] = k;
1784 }
1785 }
1786
1787 /*
1788
1789 =item C<int e_pbc_emit>
1790
1791 now let the fun begin, actually emit code for one ins
1792
1793 =cut
1794
1795 */
1796
1797 int
1798 e_pbc_emit(PARROT_INTERP, SHIM(void *param), ARGIN(const IMC_Unit *unit),
1799 ARGIN(const Instruction *ins))
1800 {
1801 int op, i;
1802 int ok = 0;
1803 op_info_t *op_info;
1804
1805 /* XXX move these statics into IMCC_INFO */
1806 static PackFile_Debug *debug_seg;
1807 static int ins_line;
1808 static opcode_t *pc;
1809 static opcode_t npc;
1810 /* XXX end */
1811
1812 #if IMC_TRACE_HIGH
1813 PIO_eprintf(NULL, "e_pbc_emit\n");
1814 #endif
1815
1816 /* first instruction, do initialisation ... */
1817 if (ins == unit->instructions) {
1818 int ins_size;
1819
1820 const int oldsize = get_old_size(interp, &ins_line);
1821 const int code_size = get_codesize(interp, unit, &ins_size);
1822 const int bytes = (oldsize + code_size) * sizeof (opcode_t);
1823
1824 IMCC_debug(interp, DEBUG_PBC, "code_size(ops) %d oldsize %d\n",
1825 code_size, oldsize);
1826
1827 constant_folding(interp, unit);
1828 store_sub_size(code_size, ins_size);
1829
1830 /*
1831 * allocate code and pic_index
1832 *
1833 * pic_index is half the size of the code, as one PIC-cachable opcode
1834 * is at least two opcodes wide - see below how to further decrease
1835 * this storage
1836 */
1837 interp->code->base.data = (opcode_t *)
1838 mem_sys_realloc(interp->code->base.data, bytes);
1839
1840 interp->code->pic_index->data = (opcode_t *)
1841 mem_sys_realloc(interp->code->pic_index->data, bytes/2);
1842
1843 interp->code->base.size = oldsize + code_size;
1844 interp->code->pic_index->size = (oldsize + code_size) / 2;
1845
1846 pc = (opcode_t *)interp->code->base.data + oldsize;
1847 npc = 0;
1848
1849 /* add debug if necessary */
1850 if (IMCC_INFO(interp)->optimizer_level == 0
1851 || IMCC_INFO(interp)->optimizer_level == OPT_PASM) {
1852 const char * const sourcefile = unit->file;
1853
1854 /* FIXME length and multiple subs */
1855 debug_seg = Parrot_new_debug_seg(interp,
1856 interp->code, (size_t) ins_line + ins_size + 1);
1857
1858 Parrot_debug_add_mapping(interp, debug_seg, ins_line,
1859 PF_DEBUGMAPPINGTYPE_FILENAME, sourcefile, 0);
1860 }
1861 else
1862 debug_seg = NULL;
1863
1864 /* if item is a PCC_SUB entry then store it constants */
1865 if (ins->symregs[0] && ins->symregs[0]->pcc_sub) {
1866
1867 #if IMC_TRACE
1868 PIO_eprintf(NULL, "pbc.c: e_pbc_emit (pcc_sub=%s)\n",
1869 ins->symregs[0]->name);
1870 #endif
1871
1872 add_const_pmc_sub(interp, ins->symregs[0], oldsize,
1873 oldsize + code_size);
1874 }
1875 else {
1876 /* need a dummy to hold register usage */
1877 SymReg * const r = mk_sub_label(interp, "(null)");
1878 r->type = VT_PCC_SUB;
1879 r->pcc_sub = mem_allocate_zeroed_typed(pcc_sub_t);
1880
1881 add_const_pmc_sub(interp, r, oldsize, oldsize + code_size);
1882 }
1883 }
1884
1885 /* if this is not the first sub then store the sub */
1886 if (npc && unit->pasm_file && ins->symregs[0] && ins->symregs[0]->pcc_sub) {
1887 /* we can only set the offset for PASM code */
1888 add_const_pmc_sub(interp, ins->symregs[0], npc, npc);
1889 }
1890
1891 if (ins->opname && *ins->opname) {
1892 SymReg *addr, *r;
1893 opcode_t last_label;
1894 last_label = 1;
1895 #if IMC_TRACE_HIGH
1896 PIO_eprintf(NULL, "emit_pbc: op [%d %s]\n", ins->opnum, ins->opname);
1897 #endif
1898 if ((ins->type & ITBRANCH)
1899 && (addr = get_branch_reg(ins)) != 0
1900 && !REG_NEEDS_ALLOC(addr)) {
1901 /* fixup local jumps - calc offset */
1902 if (addr->color == -1)
1903 IMCC_fatal(interp, 1, "e_pbc_emit: "
1904 "no label offset defined for '%s'\n", addr->name);
1905 last_label = addr->color - npc;
1906 IMCC_debug(interp, DEBUG_PBC_FIXUP,
1907 "branch label at pc %d addr %d %s %d\n",
1908 npc, addr->color, addr->name, last_label);
1909 }
1910
1911 /* add debug line info */
1912 if (debug_seg)
1913 debug_seg->base.data[ins_line++] = (opcode_t) ins->line;
1914
1915 op = (opcode_t)ins->opnum;
1916
1917 /* add PIC idx */
1918 if (parrot_PIC_op_is_cached(op)) {
1919 const size_t offs = pc - interp->code->base.data;
1920 /*
1921 * for pic_idx fitting into a short, we could
1922 * further reduce the size by storing shorts
1923 * the relation code_size / pic_index_size could
1924 * indicate the used storage
1925 *
1926 * drawback: if we reach 0xffff, we'd have to resize again
1927 */
1928 interp->code->pic_index->data[offs / 2] = ++globals.cs->pic_idx;
1929 }
1930
1931 /* Start generating the bytecode */
1932 *pc++ = op;
1933
1934 /* Get the info for that opcode */
1935 op_info = &interp->op_info_table[op];
1936
1937 IMCC_debug(interp, DEBUG_PBC, "%d %s", npc, op_info->full_name);
1938
1939 for (i = 0; i < op_info->op_count-1; i++) {
1940 switch (op_info->types[i]) {
1941 case PARROT_ARG_IC:
1942 /* branch instruction */
1943 if (op_info->labels[i]) {
1944 if (last_label == 1)
1945 /* we don't have a branch with offset 1 !? */
1946 IMCC_fatal(interp, 1, "e_pbc_emit: "
1947 "no label offset found\n");
1948 *pc++ = last_label;
1949 last_label = 1;
1950 break;
1951 /* else fall through */
1952 }
1953 case PARROT_ARG_I:
1954 case PARROT_ARG_N:
1955 case PARROT_ARG_S:
1956 case PARROT_ARG_P:
1957 case PARROT_ARG_K:
1958 case PARROT_ARG_KI:
1959 case PARROT_ARG_KIC:
1960 case PARROT_ARG_SC:
1961 case PARROT_ARG_NC:
1962 case PARROT_ARG_PC:
1963 r = ins->symregs[i];
1964
1965 if (r->type & VT_CONSTP)
1966 r = r->reg;
1967
1968 *pc++ = (opcode_t) r->color;
1969 IMCC_debug(interp, DEBUG_PBC, " %d", r->color);
1970 break;
1971 case PARROT_ARG_KC:
1972 r = ins->symregs[i];
1973 if (r->set == 'K') {
1974 PARROT_ASSERT(r->color >= 0);
1975 *pc++ = r->color;
1976 }
1977 else {
1978 *pc++ = build_key(interp, r);
1979 }
1980 IMCC_debug(interp, DEBUG_PBC, " %d", pc[-1]);
1981 break;
1982 default:
1983 IMCC_fatal(interp, 1, "e_pbc_emit:"
1984 "unknown argtype in parrot op\n");
1985 break;
1986 }
1987 }
1988 if (ins->opnum == PARROT_OP_set_args_pc
1989 || ins->opnum == PARROT_OP_get_results_pc
1990 || ins->opnum == PARROT_OP_get_params_pc
1991 || ins->opnum == PARROT_OP_set_returns_pc) {
1992
1993 /* TODO get rid of verify_signature - PIR call sigs are already
1994 * fixed, but PASM still needs it */
1995 verify_signature(interp, ins, pc);
1996
1997 /* emit var_args part */
1998 for (; i < ins->opsize - 1; ++i) {
1999 r = ins->symregs[i];
2000 if (r->type & VT_CONSTP)
2001 r = r->reg;
2002 *pc++ = (opcode_t) r->color;
2003 IMCC_debug(interp, DEBUG_PBC, " %d", r->color);
2004 }
2005 }
2006
2007 IMCC_debug(interp, DEBUG_PBC, "\t%I\n", ins);
2008 npc += ins->opsize;
2009 }
2010
2011 return ok;
2012 }
2013
2014 /*
2015
2016 =item C<int e_pbc_close>
2017
2018 RT #48260: Not yet documented!!!
2019
2020 =cut
2021
2022 */
2023
2024 int
2025 e_pbc_close(PARROT_INTERP, SHIM(void *param))
2026 {
2027 fixup_globals(interp);
2028
2029 return 0;
2030 }
2031
2032 /*
2033
2034 =back
2035
2036 =cut
2037
2038 */
2039
2040 /*
2041 * Local variables:
2042 * c-file-style: "parrot"
2043 * End:
2044 * vim: expandtab shiftwidth=4:
2045 */
parrot vm git mirror