/* [<][>][^][v][top][bottom][index][help] */
DEFINITIONS
This source file includes following definitions.
- Scm_CompiledCodeFullName
- compiled_code_print
- make_compiled_code
- Scm_VMExecuteToplevels
- execute_toplevels_cc
- execute_toplevels
- Scm_CompiledCodeDump
- cc_builder_chunk
- cc_builder
- make_cc_builder
- cc_builder_add_word
- cc_builder_add_constant
- cc_builder_add_info
- cc_builder_label_def
- cc_builder_flush
- cc_builder_jumpopt
- Scm_MakeCompiledCodeBuilder
- Scm_CompiledCodeNewLabel
- Scm_CompiledCodeSetLabel
- Scm_CompiledCodeFinishBuilder
- Scm_CompiledCodeEmit
- Scm_CompiledCodeToList
- code_size_get
- code_maxstack_get
- code_info_get
- code_arginfo_get
- code_reqargs_get
- code_optargs_get
- code_name_get
- code_parent_get
- code_iform_get
- Scm_VMInsnName
- Scm_VMInsnNumParams
- Scm_VMInsnOperandType
- Scm_VMInsnNameToCode
- Scm_VMInsnBuild
- Scm__InitCode
1 /*
2 * code.c - compiled code builder/handler
3 *
4 * Copyright (c) 2005 Shiro Kawai, All rights reserved.
5 *
6 * Redistribution and use in source and binary forms, with or without
7 * modification, are permitted provided that the following conditions
8 * are met:
9 *
10 * 1. Redistributions of source code must retain the above copyright
11 * notice, this list of conditions and the following disclaimer.
12 *
13 * 2. Redistributions in binary form must reproduce the above copyright
14 * notice, this list of conditions and the following disclaimer in the
15 * documentation and/or other materials provided with the distribution.
16 *
17 * 3. Neither the name of the authors nor the names of its contributors
18 * may be used to endorse or promote products derived from this
19 * software without specific prior written permission.
20 *
21 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
22 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
23 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
24 * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
25 * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
26 * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
27 * TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
28 * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
29 * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
30 * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
31 * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
32 *
33 * $Id: code.c,v 1.10 2005/10/13 08:14:13 shirok Exp $
34 */
35
36 #define LIBGAUCHE_BODY
37 #include "gauche.h"
38 #include "gauche/class.h"
39 #include "gauche/code.h"
40 #include "gauche/vminsn.h"
41 #include "gauche/builtin-syms.h"
42
43 /*===============================================================
44 * NVM related stuff
45 */
46
47 /* Debug information:
48 *
49 * debug info is kept as an assoc-list with insn offset
50 * as a key.
51 */
52
53 ScmObj Scm_CompiledCodeFullName(ScmCompiledCode *cc)
54 {
55 if (SCM_COMPILED_CODE_P(cc->parent)
56 && !SCM_EQ(SCM_COMPILED_CODE(cc->parent)->name, SCM_SYM_TOPLEVEL)) {
57 ScmObj h = SCM_NIL, t = SCM_NIL;
58 for (;;) {
59 SCM_APPEND1(h, t, cc->name);
60 if (!SCM_COMPILED_CODE_P(cc->parent)) break;
61 cc = SCM_COMPILED_CODE(cc->parent);
62 if (SCM_EQ(cc->name, SCM_SYM_TOPLEVEL)) break;
63 }
64 return Scm_ReverseX(h);
65 } else {
66 return cc->name;
67 }
68 }
69
70 static void compiled_code_print(ScmObj obj, ScmPort *out, ScmWriteContext *c)
71 {
72 Scm_Printf(out, "#<compiled-code %S@%p>",
73 Scm_CompiledCodeFullName(SCM_COMPILED_CODE(obj)), obj);
74 }
75
76 SCM_DEFINE_BUILTIN_CLASS_SIMPLE(Scm_CompiledCodeClass, compiled_code_print);
77
78 static ScmCompiledCode *make_compiled_code(void)
79 {
80 ScmCompiledCode *cc = SCM_NEW(ScmCompiledCode);
81 SCM_SET_CLASS(cc, SCM_CLASS_COMPILED_CODE);
82 cc->code = NULL;
83 cc->constants = NULL;
84 cc->maxstack = -1;
85 cc->info = SCM_NIL;
86 cc->argInfo = SCM_FALSE;
87 cc->name = SCM_FALSE;
88 cc->parent = SCM_FALSE;
89 cc->builder = NULL;
90 return cc;
91 }
92
93 /*----------------------------------------------------------------------
94 * An API to execute statically compiled toplevel code. *PROVISIONAL*
95 */
96 static ScmObj execute_toplevels(ScmObj*, int, void*);
97
98 void Scm_VMExecuteToplevels(ScmCompiledCode *cs[])
99 {
100 ScmObj proc = Scm_MakeSubr(execute_toplevels, cs, 0, 0, SCM_FALSE);
101 Scm_Apply(proc, SCM_NIL);
102 }
103
104 static ScmObj execute_toplevels_cc(ScmObj result, void **data)
105 {
106 ScmCompiledCode **cs = (ScmCompiledCode **)data[0];
107 ScmVM *vm;
108
109 if (cs[0] == NULL) return SCM_UNDEFINED;
110 data[0] = cs+1;
111 Scm_VMPushCC(execute_toplevels_cc, data, 1);
112 vm = Scm_VM();
113 vm->base = cs[0];
114 vm->pc = vm->base->code;
115 return SCM_UNDEFINED;
116 }
117
118 static ScmObj execute_toplevels(ScmObj *args, int nargs, void *cv)
119 {
120 Scm_VMPushCC(execute_toplevels_cc, &cv, 1);
121 return SCM_UNDEFINED;
122 }
123
124 /*----------------------------------------------------------------------
125 * Disassembler
126 */
127 void Scm_CompiledCodeDump(ScmCompiledCode *cc)
128 {
129 int i;
130 ScmWord *p;
131 ScmObj closures = SCM_NIL, cp;
132 int clonum = 0;
133
134 Scm_Printf(SCM_CUROUT, "main_code (name=%S, code=%p, size=%d, const=%d, stack=%d):\n",
135 cc->name, cc->code, cc->codeSize, cc->constantSize,
136 cc->maxstack);
137 do {
138 loop:
139 p = cc->code;
140 Scm_Printf(SCM_CUROUT, "args: %S\n", cc->argInfo);
141 for (i=0; i < cc->codeSize; i++) {
142 ScmWord insn = p[i];
143 ScmObj info, s;
144 ScmPort *out = SCM_PORT(Scm_MakeOutputStringPort(TRUE));
145 u_int code;
146 const char *insn_name;
147
148 info = Scm_Assq(SCM_MAKE_INT(i), cc->info);
149 code = SCM_VM_INSN_CODE(insn);
150 insn_name = Scm_VMInsnName(code);
151
152 switch (Scm_VMInsnNumParams(code)) {
153 case 0:
154 Scm_Printf(out, " %4d %s ", i, insn_name);
155 break;
156 case 1:
157 Scm_Printf(out, " %4d %s(%d) ", i, insn_name,
158 SCM_VM_INSN_ARG(insn));
159 break;
160 case 2:
161 Scm_Printf(out, " %4d %s(%d,%d) ", i, insn_name,
162 SCM_VM_INSN_ARG0(insn),SCM_VM_INSN_ARG1(insn));
163 break;
164 }
165 switch (Scm_VMInsnOperandType(code)) {
166 case SCM_VM_OPERAND_ADDR:
167 Scm_Printf(out, "%d", (ScmWord*)p[i+1] - cc->code);
168 i++;
169 break;
170 case SCM_VM_OPERAND_OBJ:
171 Scm_Printf(out, "%S", p[i+1]);
172 i++;
173 break;
174 case SCM_VM_OPERAND_OBJ_ADDR:
175 Scm_Printf(out, "%S, %d", p[i+1], (ScmWord*)p[i+2] - cc->code);
176 i += 2;
177 break;
178 case SCM_VM_OPERAND_CODE:
179 Scm_Printf(out, "#<lambda %d>", clonum);
180 closures = Scm_Acons(SCM_OBJ(p[i+1]), SCM_MAKE_INT(clonum),
181 closures);
182 clonum++;
183 i++;
184 break;
185 case SCM_VM_OPERAND_CODES:
186 Scm_Printf(out, "(");
187 SCM_FOR_EACH(cp, SCM_OBJ(p[i+1])) {
188 if (SCM_COMPILED_CODE_P(SCM_CAR(cp))) {
189 closures = Scm_Acons(SCM_CAR(cp),
190 SCM_MAKE_INT(clonum),
191 closures);
192 Scm_Printf(out, "#<lambda %d>", clonum);
193 clonum++;
194 }
195 }
196 Scm_Printf(out, ")");
197 i++;
198 break;
199 default:
200 /*nothing*/;
201 }
202
203 /* Show info */
204 s = Scm_GetOutputStringUnsafe(out);
205 if (!SCM_PAIRP(info)) {
206 Scm_Puts(SCM_STRING(s), SCM_CUROUT);
207 Scm_Putc('\n', SCM_CUROUT);
208 } else {
209 int len = SCM_STRING_BODY_SIZE(SCM_STRING_BODY(s));
210 ScmObj srcinfo = Scm_Assq(SCM_SYM_SOURCE_INFO, info);
211 ScmObj bindinfo = Scm_Assq(SCM_SYM_BIND_INFO, info);
212 Scm_Puts(SCM_STRING(s), SCM_CUROUT);
213 Scm_Flush(SCM_CUROUT);
214 for (; len<32; len++) {
215 Scm_Putc(' ', SCM_CUROUT);
216 }
217 if (SCM_FALSEP(srcinfo)) {
218 Scm_Printf(SCM_CUROUT, "; lambda %#40.1S\n",
219 SCM_CDR(bindinfo));
220 } else {
221 Scm_Printf(SCM_CUROUT, "; %#40.1S\n",
222 Scm_UnwrapSyntax(SCM_CDR(srcinfo)));
223 }
224 }
225 }
226 if (!SCM_NULLP(closures)) {
227 cc = SCM_COMPILED_CODE(SCM_CAAR(closures));
228 Scm_Printf(SCM_CUROUT, "internal_closure_%S (name=%S, code=%p, size=%d, const=%d stack=%d):\n",
229 SCM_CDAR(closures), cc->name, cc->code,
230 cc->codeSize, cc->constantSize, cc->maxstack);
231 closures = SCM_CDR(closures);
232 goto loop;
233 }
234 } while (0);
235 }
236
237 /*------------------------------------------------------------------
238 * Builder - used by the new compiler
239 */
240
241 #define CC_BUILDER_CHUNK_BITS 5
242 #define CC_BUILDER_CHUNK_SIZE (1L<<CC_BUILDER_CHUNK_BITS)
243 #define CC_BUILDER_CHUNK_MASK (CC_BUILDER_CHUNK_SIZE-1)
244
245 typedef struct cc_builder_chunk {
246 struct cc_builder_chunk *prev;
247 ScmWord code[CC_BUILDER_CHUNK_SIZE];
248 } cc_builder_chunk;
249
250 /* To perform instruction combination, the builder buffers one insn/operand.
251 * currentInsn == SCM_WORD(-1) indicates there's no buffered insn.
252 */
253 typedef struct cc_builder_rec {
254 cc_builder_chunk *chunks;
255 int numChunks;
256 ScmObj constants; /* list of constants */
257 int currentIndex;
258 ScmWord currentInsn; /* buffer for instruction combining. */
259 int currentArg0; /* ditto */
260 int currentArg1; /* ditto */
261 ScmObj currentOperand; /* ditto */
262 ScmObj currentInfo; /* ditto */
263 ScmObj labelDefs; /* alist of (name . offset) */
264 ScmObj labelRefs; /* alist of (name . offset-to-fill) */
265 int labelCount; /* counter to generate unique labels */
266 ScmObj info; /* alist of (offset (source-info obj)) */
267 } cc_builder;
268
269 #define CC_BUILDER_BUFFER_EMPTY SCM_WORD(-1)
270 #define CC_BUILDER_BUFFER_EMPTY_P(b) ((b)->currentInsn == CC_BUILDER_BUFFER_EMPTY)
271
272 /* Some internal stuff */
273
274 #define CC_BUILDER_GET(b, cc) \
275 do { \
276 if (cc->builder == NULL) { \
277 Scm_Error("[internal error] CompiledCode is already frozen"); \
278 } \
279 (b) = (cc_builder*)cc->builder; \
280 } while (0)
281
282 static cc_builder *make_cc_builder(void)
283 {
284 cc_builder *b;
285 b = SCM_NEW(cc_builder);
286 b->chunks = NULL;
287 b->numChunks = 0;
288 b->constants = SCM_NIL;
289 b->currentIndex = 0;
290 b->currentInsn = CC_BUILDER_BUFFER_EMPTY;
291 b->currentOperand = b->currentInfo = SCM_FALSE;
292 b->labelDefs = b->labelRefs = SCM_NIL;
293 b->labelCount = 0;
294 b->info = SCM_NIL;
295 return b;
296 }
297
298 static void cc_builder_add_word(cc_builder *b, ScmWord w)
299 {
300 int ni = b->currentIndex & CC_BUILDER_CHUNK_MASK;
301 if (ni == 0) {
302 cc_builder_chunk *newchunk = SCM_NEW(cc_builder_chunk);
303 newchunk->prev = b->chunks;
304 b->chunks = newchunk;
305 b->numChunks++;
306 }
307 b->chunks->code[ni] = w;
308 b->currentIndex++;
309 }
310
311 static void cc_builder_add_constant(cc_builder *b, ScmObj obj)
312 {
313 if (!SCM_PTRP(obj)) return;
314 if (!SCM_FALSEP(Scm_Memq(obj, b->constants))) return;
315 b->constants = Scm_Cons(obj, b->constants);
316 }
317
318 static void cc_builder_add_info(cc_builder *b)
319 {
320 if (SCM_FALSEP(b->currentInfo)) return;
321 b->info = Scm_Acons(SCM_MAKE_INT(b->currentIndex),
322 SCM_LIST1(Scm_Cons(SCM_SYM_SOURCE_INFO,
323 b->currentInfo)),
324 b->info);
325 b->currentInfo = SCM_FALSE;
326 }
327
328 /* Returns label offset of the given label, if the label is already defined.
329 Otherwise, returns -1. */
330 static int cc_builder_label_def(cc_builder *b, ScmObj label)
331 {
332 ScmObj p = Scm_Assq(label, b->labelDefs);
333 if (SCM_PAIRP(p)) {
334 return SCM_INT_VALUE(SCM_CDR(p));
335 } else {
336 return -1;
337 }
338 }
339
340 /* Flush the currentInsn buffer. */
341 static void cc_builder_flush(cc_builder *b)
342 {
343 u_int code;
344
345 if (CC_BUILDER_BUFFER_EMPTY_P(b)) return;
346 cc_builder_add_info(b);
347 cc_builder_add_word(b, b->currentInsn);
348
349 code = SCM_VM_INSN_CODE(b->currentInsn);
350 switch (Scm_VMInsnOperandType(code)) {
351 case SCM_VM_OPERAND_ADDR:
352 /* Addr should be a label. We just push the label reference
353 into labelRefs, and emit a dummy address for the time being.
354 (we can't emit the actual number even if we're referring to
355 the label that has already appeared, since the number should
356 be calculated after the code vector is allocated.) */
357 b->labelRefs = Scm_Acons(b->currentOperand,
358 SCM_MAKE_INT(b->currentIndex),
359 b->labelRefs);
360 cc_builder_add_word(b, SCM_WORD(0)); /* dummy */
361 break;
362 case SCM_VM_OPERAND_OBJ:;
363 case SCM_VM_OPERAND_CODES:
364 cc_builder_add_word(b, SCM_WORD(b->currentOperand));
365 cc_builder_add_constant(b, b->currentOperand);
366 break;
367 case SCM_VM_OPERAND_OBJ_ADDR:
368 /* operand would be given as a list of (OBJ LABEL). */
369 SCM_ASSERT(SCM_PAIRP(b->currentOperand)
370 && SCM_PAIRP(SCM_CDR(b->currentOperand)));
371 cc_builder_add_word(b, SCM_WORD(SCM_CAR(b->currentOperand)));
372 cc_builder_add_constant(b, SCM_CAR(b->currentOperand));
373 b->labelRefs = Scm_Acons(SCM_CADR(b->currentOperand),
374 SCM_MAKE_INT(b->currentIndex),
375 b->labelRefs);
376 cc_builder_add_word(b, SCM_WORD(0)); /* dummy */
377 break;
378 case SCM_VM_OPERAND_CODE:
379 if (!SCM_COMPILED_CODE_P(b->currentOperand)) goto badoperand;
380 cc_builder_add_word(b, SCM_WORD(b->currentOperand));
381 cc_builder_add_constant(b, b->currentOperand);
382 default:
383 break;
384 }
385 b->currentInsn = CC_BUILDER_BUFFER_EMPTY;
386 return;
387 badoperand:
388 b->currentInsn = CC_BUILDER_BUFFER_EMPTY;
389 Scm_Error("[internal error] bad operand: %S", b->currentOperand);
390 return;
391 }
392
393 /* a peephole optimization; rewrite jump destination for cascaded jump
394 *
395 * - if the destination of JUMP-like insn (including conditional jump
396 * and PRE-CALL) is another JUMP, rewrite the destination.
397 * - if the destination of BF is another BF (this pattern appears frequently,
398 * e.g. 'or' is used in the test clause of 'cond'), rewrite the destination.
399 */
400 static void cc_builder_jumpopt(ScmCompiledCode *cc)
401 {
402 ScmWord *cp = cc->code;
403 u_int code, i;
404 ScmWord *target;
405
406 for (i=0; i<cc->codeSize; i++) {
407 code = SCM_VM_INSN_CODE(*cp); cp++;
408 switch (Scm_VMInsnOperandType(code)) {
409 case SCM_VM_OPERAND_OBJ:;
410 case SCM_VM_OPERAND_CODE:;
411 case SCM_VM_OPERAND_CODES:;
412 i++; cp++;
413 break;
414 case SCM_VM_OPERAND_OBJ_ADDR:
415 i++; cp++;
416 /*FALLTHROUGH*/
417 case SCM_VM_OPERAND_ADDR:
418 target = (ScmWord*)*cp;
419 while (SCM_VM_INSN_CODE(*target) == SCM_VM_JUMP
420 || (code == SCM_VM_BF
421 && SCM_VM_INSN_CODE(*target) == SCM_VM_BF)) {
422 target = (ScmWord*)target[1];
423 }
424 if (target != (ScmWord*)*cp) {
425 *cp = SCM_WORD(target);
426 }
427 i++; cp++;
428 break;
429 default:
430 break;
431 }
432 }
433 }
434
435
436 /* Creates and returns a new empty compiled-code object for building
437 new code chunk. */
438 ScmObj Scm_MakeCompiledCodeBuilder(int reqargs, int optargs,
439 ScmObj name, ScmObj parent, ScmObj intForm)
440 {
441 ScmCompiledCode *cc = make_compiled_code();
442 cc->builder = make_cc_builder();
443 cc->requiredArgs = reqargs;
444 cc->optionalArgs = optargs;
445 cc->name = name;
446 cc->parent = parent;
447 cc->intermediateForm = intForm;
448 return SCM_OBJ(cc);
449 }
450
451 /* Returns a label identifier (integer) unique to this code block */
452 ScmObj Scm_CompiledCodeNewLabel(ScmCompiledCode *cc)
453 {
454 ScmObj label;
455 cc_builder *b;
456 CC_BUILDER_GET(b, cc);
457 label = SCM_MAKE_INT(b->labelCount);
458 b->labelCount++;
459 return label;
460 }
461
462 /* Set label to the current instruction position. */
463 void Scm_CompiledCodeSetLabel(ScmCompiledCode *cc, ScmObj label)
464 {
465 cc_builder *b;
466
467 CC_BUILDER_GET(b, cc);
468
469 /* Flush buffered insn first. */
470 cc_builder_flush(b);
471
472 /* NB: should check duplicate labels */
473 b->labelDefs = Scm_Acons(label, SCM_MAKE_INT(b->currentIndex),
474 b->labelDefs);
475 }
476
477 /* Pack the code accumulated in the builder into a code vector.
478 Perform label resolution and jump optimization. */
479 void Scm_CompiledCodeFinishBuilder(ScmCompiledCode *cc, int maxstack)
480 {
481 ScmObj cp;
482 cc_builder *b;
483 cc_builder_chunk *bc, *bcprev;
484 int i, j, numConstants;
485
486 CC_BUILDER_GET(b, cc);
487 cc_builder_flush(b);
488 cc->code = SCM_NEW_ATOMIC2(ScmWord *, b->currentIndex * sizeof(ScmWord));
489 cc->codeSize = b->currentIndex;
490
491 /* reverse chunks, leaving the first chunk in bcprev. */
492 bcprev = NULL;
493 for (bc = b->chunks; bc;) {
494 cc_builder_chunk *next = bc->prev;
495 bc->prev = bcprev;
496 bcprev = bc;
497 bc = next;
498 }
499
500 /* pack words */
501 bc = bcprev;
502 for (i=0, j=0; i<b->currentIndex; i++, j++) {
503 if (j >= CC_BUILDER_CHUNK_SIZE) {
504 bc = bc->prev;
505 j = 0;
506 }
507 cc->code[i] = bc->code[j];
508 }
509
510 /* pack constants */
511 numConstants = Scm_Length(b->constants);
512 if (numConstants > 0) {
513 ScmObj cp;
514 cc->constants = SCM_NEW_ARRAY(ScmObj, numConstants);
515 for (i=0, cp=b->constants; i<numConstants; i++, cp=SCM_CDR(cp)) {
516 cc->constants[i] = SCM_CAR(cp);
517 }
518 }
519 cc->constantSize = numConstants;
520
521 /* resolve labels */
522 SCM_FOR_EACH(cp, b->labelRefs) {
523 int destAddr = cc_builder_label_def(b, SCM_CAAR(cp));
524 int operandAddr;
525 if (destAddr < 0) {
526 Scm_Error("[internal error] undefined label in compiled code: %S",
527 SCM_CAAR(cp));
528 }
529 operandAddr = SCM_INT_VALUE(SCM_CDAR(cp));
530 SCM_ASSERT(operandAddr >= 0 && operandAddr < cc->codeSize);
531 cc->code[operandAddr] = SCM_WORD(cc->code + destAddr);
532 }
533
534 /* jump destination optimization */
535 cc_builder_jumpopt(cc);
536
537 /* record debug info */
538 cc->info = b->info;
539
540 /* set max stack depth */
541 cc->maxstack = maxstack;
542
543 /* make sure this code is 'fixed'---no more building */
544 cc->builder = NULL;
545 }
546
547 /*----------------------------------------------------------------
548 * Emitting instruction and operand, performing instruction combination
549 */
550
551 /* This is originally implemented in Scheme, but moved here for efficiency,
552 * since this routine is the most frequently called one during compilation.
553 */
554
555 /* The plan is to use STN generated from vminsn.scm for instruction
556 combination, but we haven't got it working yet. */
557 #if 0
558 /* The state transition table */
559 struct stn_arc {
560 int input; /* input insn, or -1 for wildcard */
561 int action; /* NEXT, RESET, KEEPn */
562 int operand; /* emitting insn / next state */
563 };
564
565 /* State transition actions */
566 enum {
567 NEXT,
568 EMIT,
569 KEEP
570 };
571
572 /* Include STN generated from vminsn.scm */
573 static struct stn_arc stn[] = {
574 #define STATE_TABLE
575 #include "vminsn.c"
576 #undef STATE_TABLE
577 };
578 #endif /*0*/
579 /* The following is the legacy code (manually tweaked automaton).
580 Once we get STN working it will go away. */
581
582 /* some abbreviations for better readability */
583
584 #define INSN(x) SCM_VM_INSN(x)
585 #define INSN1(x, a) SCM_VM_INSN1(x, a)
586 #define INSN2(x, a, b) SCM_VM_INSN2(x, a, b)
587
588 #define CODE(x) SCM_VM_INSN_CODE(x)
589 #define IARG(x) SCM_VM_INSN_ARG(x)
590 #define IARG0(x) SCM_VM_INSN_ARG0(x)
591 #define IARG1(x) SCM_VM_INSN_ARG1(x)
592
593 #define EMPTYP(b) CC_BUILDER_BUFFER_EMPTY_P(b)
594
595
596 #define PUT(insn, operand) \
597 do { \
598 cc_builder_flush(b); \
599 b->currentInsn = (insn); \
600 b->currentOperand = (operand); \
601 b->currentInfo = (info); \
602 } while (0)
603
604 #define SUB(insn) \
605 do { \
606 b->currentInsn = (insn); \
607 if (!SCM_FALSEP(info)) b->currentInfo = info; \
608 } while (0)
609
610 #define SUBO(insn, operand) \
611 do { \
612 b->currentInsn = (insn); \
613 b->currentOperand = (operand); \
614 if (!SCM_FALSEP(info)) b->currentInfo = info; \
615 } while (0)
616
617 #define INT_FITS_P(obj) \
618 (SCM_INTP(obj)&&SCM_VM_INSN_ARG_FITS(SCM_INT_VALUE(obj)))
619
620
621 void Scm_CompiledCodeEmit(ScmCompiledCode *cc,
622 int code, /* instruction code number */
623 int arg0, /* instruction code parameter 0 */
624 int arg1, /* instruction code parameter 1 */
625 ScmObj operand,
626 ScmObj info) /* debug info */
627 {
628 cc_builder *b;
629 CC_BUILDER_GET(b, cc);
630
631 if (SCM_VM_COMPILER_FLAG_IS_SET(Scm_VM(), SCM_COMPILE_NOCOMBINE)) {
632 goto def;
633 }
634
635
636 switch (code) {
637 case SCM_VM_LREF:
638 {
639 static const int lrefs[4][4] = {
640 { SCM_VM_LREF0, SCM_VM_LREF1, SCM_VM_LREF2, SCM_VM_LREF3 },
641 { SCM_VM_LREF10, SCM_VM_LREF11, SCM_VM_LREF12, -1 },
642 { SCM_VM_LREF20, SCM_VM_LREF21, -1, -1 },
643 { SCM_VM_LREF30, -1, -1, -1 }
644 };
645 if (arg0 < 4 && arg1 < 4) {
646 int insn = lrefs[arg0][arg1];
647 if (insn >= 0) {
648 PUT(INSN(insn), SCM_FALSE);
649 break;
650 }
651 }
652 PUT(INSN2(SCM_VM_LREF, arg0, arg1), SCM_FALSE);
653 break;
654 }
655
656 case SCM_VM_PUSH:
657 {
658 if (EMPTYP(b)) goto def;
659 switch (CODE(b->currentInsn)) {
660 case SCM_VM_LREF0: SUB(INSN(SCM_VM_LREF0_PUSH)); break;
661 case SCM_VM_LREF1: SUB(INSN(SCM_VM_LREF1_PUSH)); break;
662 case SCM_VM_LREF2: SUB(INSN(SCM_VM_LREF2_PUSH)); break;
663 case SCM_VM_LREF3: SUB(INSN(SCM_VM_LREF3_PUSH)); break;
664 case SCM_VM_LREF10: SUB(INSN(SCM_VM_LREF10_PUSH)); break;
665 case SCM_VM_LREF11: SUB(INSN(SCM_VM_LREF11_PUSH)); break;
666 case SCM_VM_LREF12: SUB(INSN(SCM_VM_LREF12_PUSH)); break;
667 case SCM_VM_LREF20: SUB(INSN(SCM_VM_LREF20_PUSH)); break;
668 case SCM_VM_LREF21: SUB(INSN(SCM_VM_LREF21_PUSH)); break;
669 case SCM_VM_LREF30: SUB(INSN(SCM_VM_LREF30_PUSH)); break;
670
671 /* obsoleted */
672 case SCM_VM_LREF4: SUB(INSN(SCM_VM_LREF4_PUSH)); break;
673 case SCM_VM_LREF13: SUB(INSN(SCM_VM_LREF13_PUSH)); break;
674 case SCM_VM_LREF14: SUB(INSN(SCM_VM_LREF14_PUSH)); break;
675
676 case SCM_VM_LREF: SUB(INSN2(SCM_VM_LREF_PUSH,
677 IARG0(b->currentInsn),
678 IARG1(b->currentInsn))); break;
679 case SCM_VM_GREF: SUB(INSN(SCM_VM_GREF_PUSH)); break;
680
681 case SCM_VM_CAR: SUB(INSN(SCM_VM_CAR_PUSH)); break;
682 case SCM_VM_CDR: SUB(INSN(SCM_VM_CDR_PUSH)); break;
683 case SCM_VM_CAAR: SUB(INSN(SCM_VM_CAAR_PUSH)); break;
684 case SCM_VM_CADR: SUB(INSN(SCM_VM_CADR_PUSH)); break;
685 case SCM_VM_CDAR: SUB(INSN(SCM_VM_CDAR_PUSH)); break;
686 case SCM_VM_CDDR: SUB(INSN(SCM_VM_CDDR_PUSH)); break;
687 case SCM_VM_CONS: SUB(INSN(SCM_VM_CONS_PUSH)); break;
688 case SCM_VM_CONST: SUB(INSN(SCM_VM_CONST_PUSH)); break;
689 case SCM_VM_CONSTI: SUB(INSN1(SCM_VM_CONSTI_PUSH,
690 IARG(b->currentInsn))); break;
691 case SCM_VM_CONSTN: SUB(INSN(SCM_VM_CONSTN_PUSH)); break;
692 case SCM_VM_CONSTF: SUB(INSN(SCM_VM_CONSTF_PUSH)); break;
693 default:
694 PUT(INSN(SCM_VM_PUSH), SCM_FALSE);
695 }
696 break;
697 }
698
699 case SCM_VM_CONST:
700 {
701 if (SCM_NULLP(operand)) {
702 PUT(INSN(SCM_VM_CONSTN), SCM_FALSE);
703 } else if (SCM_FALSEP(operand)) {
704 PUT(INSN(SCM_VM_CONSTF), SCM_FALSE);
705 } else if (SCM_UNDEFINEDP(operand)) {
706 PUT(INSN(SCM_VM_CONSTU), SCM_FALSE);
707 } else if (INT_FITS_P(operand)) {
708 PUT(INSN1(SCM_VM_CONSTI, SCM_INT_VALUE(operand)), SCM_FALSE);
709 } else {
710 PUT(INSN(SCM_VM_CONST), operand);
711 }
712 break;
713 }
714
715 case SCM_VM_CALL:
716 {
717 if (EMPTYP(b)) goto def;
718 switch (CODE(b->currentInsn)) {
719 case SCM_VM_GREF:
720 SUB(INSN1(SCM_VM_GREF_CALL, arg0)); break;
721 case SCM_VM_PUSH_GREF:
722 SUB(INSN1(SCM_VM_PUSH_GREF_CALL, arg0)); break;
723 case SCM_VM_LREF0_PUSH_GREF:
724 SUB(INSN1(SCM_VM_LREF0_PUSH_GREF_CALL, arg0)); break;
725 default:
726 PUT(INSN1(SCM_VM_CALL, arg0), SCM_FALSE);
727 }
728 break;
729 }
730
731 case SCM_VM_TAIL_CALL:
732 {
733 if (EMPTYP(b)) goto def;
734 switch (CODE(b->currentInsn)) {
735 case SCM_VM_GREF:
736 SUB(INSN1(SCM_VM_GREF_TAIL_CALL, arg0)); break;
737 case SCM_VM_PUSH_GREF:
738 SUB(INSN1(SCM_VM_PUSH_GREF_TAIL_CALL, arg0)); break;
739 case SCM_VM_LREF0_PUSH_GREF:
740 SUB(INSN1(SCM_VM_LREF0_PUSH_GREF_TAIL_CALL, arg0)); break;
741 default:
742 PUT(INSN1(SCM_VM_TAIL_CALL, arg0), SCM_FALSE);
743 }
744 break;
745 }
746
747 case SCM_VM_PRE_CALL:
748 {
749 if (!EMPTYP(b) && CODE(b->currentInsn) == SCM_VM_PUSH) {
750 SUBO(INSN1(SCM_VM_PUSH_PRE_CALL, arg0), operand);
751 } else {
752 PUT(INSN1(SCM_VM_PRE_CALL, arg0), operand);
753 }
754 break;
755 }
756
757 case SCM_VM_GREF:
758 {
759 if (!EMPTYP(b)) {
760 if (CODE(b->currentInsn) == SCM_VM_PUSH) {
761 SUBO(INSN1(SCM_VM_PUSH_GREF, arg0), operand);
762 break;
763 } else if (CODE(b->currentInsn) == SCM_VM_LREF0_PUSH) {
764 SUBO(INSN1(SCM_VM_LREF0_PUSH_GREF, arg0), operand);
765 break;
766 }
767 }
768 PUT(INSN1(SCM_VM_GREF, arg0), operand);
769 break;
770 }
771
772 case SCM_VM_LOCAL_ENV:
773 {
774 if (!EMPTYP(b) && CODE(b->currentInsn) == SCM_VM_PUSH) {
775 SUBO(INSN1(SCM_VM_PUSH_LOCAL_ENV, arg0), SCM_FALSE);
776 } else {
777 PUT(INSN1(SCM_VM_LOCAL_ENV, arg0), SCM_FALSE);
778 }
779 break;
780 }
781
782 case SCM_VM_RET:
783 {
784 if (EMPTYP(b)) goto def;
785 switch (CODE(b->currentInsn)) {
786 case SCM_VM_CONST: SUB(INSN(SCM_VM_CONST_RET)); break;
787 case SCM_VM_CONSTF: SUB(INSN(SCM_VM_CONSTF_RET)); break;
788 case SCM_VM_CONSTU: SUB(INSN(SCM_VM_CONSTU_RET)); break;
789 default:
790 PUT(INSN(SCM_VM_RET), SCM_FALSE);
791 }
792 break;
793 }
794
795 case SCM_VM_CAR:
796 {
797 if (EMPTYP(b)) goto def;
798 switch (CODE(b->currentInsn)) {
799 case SCM_VM_CAR: SUB(INSN(SCM_VM_CAAR)); break;
800 case SCM_VM_CDR: SUB(INSN(SCM_VM_CADR)); break;
801 default:
802 PUT(INSN(SCM_VM_CAR), SCM_FALSE);
803 }
804 break;
805 }
806
807 case SCM_VM_CDR:
808 {
809 if (EMPTYP(b)) goto def;
810 switch (CODE(b->currentInsn)) {
811 case SCM_VM_CAR: SUB(INSN(SCM_VM_CDAR)); break;
812 case SCM_VM_CDR: SUB(INSN(SCM_VM_CDDR)); break;
813 default:
814 PUT(INSN(SCM_VM_CDR), SCM_FALSE);
815 }
816 break;
817 }
818
819 #if 0
820 case SCM_VM_NUMADDI:
821 {
822 if (EMPTYP(b)) goto def;
823 switch (CODE(b->currentInsn)) {
824 case SCM_VM_LREF0: SUB(INSN1(SCM_VM_LREF0_NUMADDI, arg0)); break;
825 case SCM_VM_LREF1: SUB(INSN1(SCM_VM_LREF1_NUMADDI, arg0)); break;
826 case SCM_VM_LREF2: SUB(INSN1(SCM_VM_LREF2_NUMADDI, arg0)); break;
827 case SCM_VM_LREF3: SUB(INSN1(SCM_VM_LREF3_NUMADDI, arg0)); break;
828 case SCM_VM_LREF4: SUB(INSN1(SCM_VM_LREF4_NUMADDI, arg0)); break;
829 default:
830 PUT(INSN1(SCM_VM_NUMADDI, arg0), SCM_FALSE);
831 }
832 break;
833 }
834 #endif
835
836 default:;
837 def:
838 switch (Scm_VMInsnNumParams(code)) {
839 case 0: PUT(INSN(code), operand); break;
840 case 1: PUT(INSN1(code, arg0), operand); break;
841 case 2: PUT(INSN2(code, arg0, arg1), operand); break;
842 }
843 }
844 }
845
846 #undef PUT
847 #undef SUB
848 #undef SUBO
849 #undef INSN
850 #undef INSN1
851 #undef INSN2
852 #undef CODE
853 #undef IARG
854 #undef IARG0
855 #undef IARG1
856 #undef EMPTYP
857
858 /*----------------------------------------------------------------
859 * CompiledCode - Scheme interface
860 */
861
862 /* Converts the code vector into a list.
863 Instruction -> (<insn-symbol> [<arg0> <arg1>])
864 Obj/Code operand -> as is
865 Addr operand -> integer offset from the beginning of the code */
866 ScmObj Scm_CompiledCodeToList(ScmCompiledCode *cc)
867 {
868 int i, off;
869 ScmObj h = SCM_NIL, t = SCM_NIL;
870
871 for (i=0; i<cc->codeSize; i++) {
872 ScmWord insn = cc->code[i];
873 int code = SCM_VM_INSN_CODE(insn);
874 const char *name = Scm_VMInsnName(code);
875
876 switch (Scm_VMInsnNumParams(code)) {
877 case 0:
878 SCM_APPEND1(h, t, SCM_LIST1(SCM_INTERN(name)));
879 break;
880 case 1:
881 SCM_APPEND1(h, t, SCM_LIST2(SCM_INTERN(name),
882 SCM_MAKE_INT(SCM_VM_INSN_ARG(insn))));
883 break;
884 case 2:
885 SCM_APPEND1(h, t, SCM_LIST3(SCM_INTERN(name),
886 SCM_MAKE_INT(SCM_VM_INSN_ARG0(insn)),
887 SCM_MAKE_INT(SCM_VM_INSN_ARG1(insn))));
888 break;
889 }
890
891 switch (Scm_VMInsnOperandType(code)) {
892 case SCM_VM_OPERAND_OBJ:;
893 case SCM_VM_OPERAND_CODE:;
894 case SCM_VM_OPERAND_CODES:;
895 SCM_APPEND1(h, t, SCM_OBJ(cc->code[++i]));
896 break;
897 case SCM_VM_OPERAND_ADDR:
898 off = (ScmWord*)cc->code[++i] - cc->code;
899 SCM_APPEND1(h, t, SCM_MAKE_INT(off));
900 break;
901 case SCM_VM_OPERAND_OBJ_ADDR:
902 off = (ScmWord*)cc->code[i+2] - cc->code;
903 SCM_APPEND(h, t, SCM_LIST2(SCM_OBJ(cc->code[i+1]),
904 SCM_MAKE_INT(off)));
905 i += 2;
906 break;
907 }
908 }
909 return h;
910 }
911
912 static ScmObj code_size_get(ScmObj cc)
913 {
914 return SCM_MAKE_INT(SCM_COMPILED_CODE(cc)->codeSize);
915 }
916
917 static ScmObj code_maxstack_get(ScmObj cc)
918 {
919 return SCM_MAKE_INT(SCM_COMPILED_CODE(cc)->maxstack);
920 }
921
922 static ScmObj code_info_get(ScmObj cc)
923 {
924 return SCM_COMPILED_CODE(cc)->info;
925 }
926
927 static ScmObj code_arginfo_get(ScmObj cc)
928 {
929 return SCM_COMPILED_CODE(cc)->argInfo;
930 }
931
932 static ScmObj code_reqargs_get(ScmObj cc)
933 {
934 return SCM_MAKE_INT(SCM_COMPILED_CODE(cc)->requiredArgs);
935 }
936
937 static ScmObj code_optargs_get(ScmObj cc)
938 {
939 return SCM_MAKE_INT(SCM_COMPILED_CODE(cc)->optionalArgs);
940 }
941
942 static ScmObj code_name_get(ScmObj cc)
943 {
944 return SCM_COMPILED_CODE(cc)->name;
945 }
946
947 static ScmObj code_parent_get(ScmObj cc)
948 {
949 return SCM_OBJ(SCM_COMPILED_CODE(cc)->parent);
950 }
951
952 static ScmObj code_iform_get(ScmObj cc)
953 {
954 return SCM_OBJ(SCM_COMPILED_CODE(cc)->intermediateForm);
955 }
956
957 static ScmClassStaticSlotSpec code_slots[] = {
958 SCM_CLASS_SLOT_SPEC("parent", code_parent_get, NULL),
959 SCM_CLASS_SLOT_SPEC("arg-info", code_arginfo_get, NULL),
960 SCM_CLASS_SLOT_SPEC("info", code_info_get, NULL),
961 SCM_CLASS_SLOT_SPEC("required-args", code_reqargs_get, NULL),
962 SCM_CLASS_SLOT_SPEC("optional-args", code_optargs_get, NULL),
963 SCM_CLASS_SLOT_SPEC("name", code_name_get, NULL),
964 SCM_CLASS_SLOT_SPEC("full-name", Scm_CompiledCodeFullName, NULL),
965 SCM_CLASS_SLOT_SPEC("size", code_size_get, NULL),
966 SCM_CLASS_SLOT_SPEC("max-stack", code_maxstack_get, NULL),
967 SCM_CLASS_SLOT_SPEC("intermediate-form", code_iform_get, NULL),
968 { NULL }
969 };
970
971 /*===========================================================
972 * VM Instruction introspection
973 */
974
975 static struct insn_info {
976 const char *name; /* name */
977 int nparams; /* # of parameters */
978 int operandType; /* operand type */
979 } insn_table[] = {
980 #define DEFINSN(sym, nam, np, type) \
981 { nam, np, SCM_CPP_CAT(SCM_VM_OPERAND_, type) },
982 #include "vminsn.c"
983 #undef DEFINSN
984 };
985
986 #define CHECK_CODE(code) \
987 do { \
988 if (code >= SCM_VM_NUM_INSNS) { \
989 Scm_Error("invalid VM instruction code: %d", code); \
990 } \
991 } while (0)
992
993 const char *Scm_VMInsnName(u_int code)
994 {
995 CHECK_CODE(code);
996 return insn_table[code].name;
997 }
998
999 int Scm_VMInsnNumParams(u_int code)
1000 {
1001 CHECK_CODE(code);
1002 return insn_table[code].nparams;
1003 }
1004
1005 int Scm_VMInsnOperandType(u_int code)
1006 {
1007 CHECK_CODE(code);
1008 return insn_table[code].operandType;
1009 }
1010
1011 int Scm_VMInsnNameToCode(ScmObj name)
1012 {
1013 const char *n;
1014 struct insn_info *info;
1015 int i;
1016
1017 if (SCM_SYMBOLP(name)) name = SCM_OBJ(SCM_SYMBOL_NAME(name));
1018 else if (!SCM_STRINGP(name)) {
1019 Scm_Error("vm-insn-name->code: requires a symbol or a string, but got %S", name);
1020 }
1021 n = Scm_GetStringConst(SCM_STRING(name));
1022 info = insn_table;
1023 for (i=0; i<SCM_VM_NUM_INSNS; i++) {
1024 if (strcmp(insn_table[i].name, n) == 0) {
1025 return i;
1026 }
1027 }
1028 Scm_Error("vm-insn-name->code: no such instruction: %A", name);
1029 return -1; /* dummy */
1030 }
1031
1032 /* (kind of) inversion of VMInsnInspect. */
1033 ScmWord Scm_VMInsnBuild(ScmObj obj)
1034 {
1035 int len = Scm_Length(obj), code, arg0, arg1;
1036
1037 if (len < 1 || len > 3 || !SCM_SYMBOLP(SCM_CAR(obj))) goto badspec;
1038 code = Scm_VMInsnNameToCode(SCM_CAR(obj));
1039
1040 switch (Scm_VMInsnNumParams(code)) {
1041 case 0:
1042 if (len != 1) {
1043 Scm_Error("VM instruction %S takes no parameters, but got %S",
1044 SCM_CAR(obj), obj);
1045 }
1046 return SCM_VM_INSN(code);
1047 case 1:
1048 if (len != 2) {
1049 Scm_Error("VM instruction %S takes one parameter, but got %S",
1050 SCM_CAR(obj), obj);
1051 }
1052 if (!SCM_INTP(SCM_CADR(obj))) goto badspec;
1053 arg0 = SCM_INT_VALUE(SCM_CADR(obj));
1054 return SCM_VM_INSN1(code, arg0);
1055 case 2:
1056 if (len != 3) {
1057 Scm_Error("VM instruction %S takes two parameters, but got %S",
1058 SCM_CAR(obj), obj);
1059 }
1060 if (!SCM_INTP(SCM_CADR(obj))) goto badspec;
1061 if (!SCM_INTP(SCM_CAR(SCM_CDDR(obj)))) goto badspec;
1062 arg0 = SCM_INT_VALUE(SCM_CADR(obj));
1063 arg1 = SCM_INT_VALUE(SCM_CAR(SCM_CDDR(obj)));
1064 return SCM_VM_INSN2(code, arg0, arg1);
1065 }
1066 /*FALLTHROUGH*/
1067 badspec:
1068 Scm_Error("Bad VM insn spec: %S", obj);
1069 return 0; /* dummy */
1070 }
1071
1072 /*===========================================================
1073 * Initialization
1074 */
1075 void Scm__InitCode(void)
1076 {
1077 Scm_InitStaticClass(SCM_CLASS_COMPILED_CODE, "<compiled-code>",
1078 Scm_GaucheModule(), code_slots, 0);
1079 }