1 /* -*-C-*-
2
3 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
4 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
5 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014 Massachusetts
6 Institute of Technology
7
8 This file is part of MIT/GNU Scheme.
9
10 MIT/GNU Scheme is free software; you can redistribute it and/or modify
11 it under the terms of the GNU General Public License as published by
12 the Free Software Foundation; either version 2 of the License, or (at
13 your option) any later version.
14
15 MIT/GNU Scheme is distributed in the hope that it will be useful, but
16 WITHOUT ANY WARRANTY; without even the implied warranty of
17 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
18 General Public License for more details.
19
20 You should have received a copy of the GNU General Public License
21 along with MIT/GNU Scheme; if not, write to the Free Software
22 Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
23 USA.
24
25 */
26
27 #include "config.h"
28
29 #include <stdlib.h>
30 #include <string.h>
31
32 #define LIARC_IN_MICROCODE
33 #include "liarc.h"
34 #include "stackops.h"
35
36 typedef struct
37 {
38 unsigned char * strptr;
39 entry_count_t dispatch_base;
40 SCHEME_OBJECT * sp;
41 SCHEME_OBJECT * regmap;
42 } stackify_context_s, * stackify_context_t;
43
44 static entry_count_t dispatch_base;
45
46 static unsigned char * prog_start;
47 static unsigned char * prog_end;
48 static unsigned char * pc;
49
50 static unsigned char * string_start;
51 static unsigned char * string_end;
52 static unsigned char * strptr;
53
54 static SCHEME_OBJECT * sp_lower;
55 static SCHEME_OBJECT * sp_upper;
56 static SCHEME_OBJECT * sp;
57
58 static SCHEME_OBJECT * regmap;
59 static SCHEME_OBJECT * regmap_end;
60
61 #ifdef ENABLE_DEBUGGING_TOOLS
62
63 #undef NDEBUG
64 #include <assert.h>
65
66 static const char * opcode_names [] =
67 {
68 "stackify-opcode/illegal",
69 "stackify-opcode/escape",
70 "stackify-opcode/push-+fixnum",
71 "stackify-opcode/push--fixnum",
72 "stackify-opcode/push-+integer",
73 "stackify-opcode/push--integer",
74 "stackify-opcode/push-false",
75 "stackify-opcode/push-true",
76 "stackify-opcode/push-nil",
77 "stackify-opcode/push-flonum",
78 "stackify-opcode/push-cons-ratnum",
79 "stackify-opcode/push-cons-recnum",
80 "stackify-opcode/push-string",
81 "stackify-opcode/push-symbol",
82 "stackify-opcode/push-uninterned-symbol",
83 "stackify-opcode/push-char",
84 "stackify-opcode/push-bit-string",
85 "stackify-opcode/push-empty-cons",
86 "stackify-opcode/pop-and-set-car",
87 "stackify-opcode/pop-and-set-cdr",
88 "stackify-opcode/push-cons*",
89 "stackify-opcode/push-empty-vector",
90 "stackify-opcode/pop-and-vector-set",
91 "stackify-opcode/push-vector",
92 "stackify-opcode/push-empty-record",
93 "stackify-opcode/pop-and-record-set",
94 "stackify-opcode/push-record",
95 "stackify-opcode/push-lookup",
96 "stackify-opcode/store",
97 "stackify-opcode/push-constant",
98 "stackify-opcode/push-unassigned",
99 "stackify-opcode/push-primitive",
100 "stackify-opcode/push-primitive-lexpr",
101 "stackify-opcode/push-nm-header",
102 "stackify-opcode/push-label-entry",
103 "stackify-opcode/push-linkage-header-operator",
104 "stackify-opcode/push-linkage-header-reference",
105 "stackify-opcode/push-linkage-header-assignment",
106 "stackify-opcode/push-linkage-header-global",
107 "stackify-opcode/push-linkage-header-closure",
108 "stackify-opcode/push-ulong",
109 "stackify-opcode/push-label-descriptor",
110 "stackify-opcode/cc-block-to-entry",
111 "stackify-opcode/retag-cc-block",
112 "stackify-opcode/push-return-code",
113 "unknown-055",
114 "unknown-056",
115 "unknown-057",
116 "unknown-060",
117 "unknown-061",
118 "unknown-062",
119 "unknown-063",
120 "unknown-064",
121 "unknown-065",
122 "unknown-066",
123 "unknown-067",
124 "unknown-070",
125 "unknown-071",
126 "unknown-072",
127 "unknown-073",
128 "unknown-074",
129 "unknown-075",
130 "unknown-076",
131 "unknown-077",
132 "unknown-0100",
133 "unknown-0101",
134 "unknown-0102",
135 "unknown-0103",
136 "unknown-0104",
137 "unknown-0105",
138 "unknown-0106",
139 "unknown-0107",
140 "unknown-0110",
141 "unknown-0111",
142 "unknown-0112",
143 "unknown-0113",
144 "unknown-0114",
145 "unknown-0115",
146 "unknown-0116",
147 "unknown-0117",
148 "unknown-0120",
149 "unknown-0121",
150 "unknown-0122",
151 "unknown-0123",
152 "unknown-0124",
153 "unknown-0125",
154 "unknown-0126",
155 "unknown-0127",
156 "unknown-0130",
157 "unknown-0131",
158 "unknown-0132",
159 "unknown-0133",
160 "unknown-0134",
161 "unknown-0135",
162 "unknown-0136",
163 "unknown-0137",
164 "unknown-0140",
165 "unknown-0141",
166 "unknown-0142",
167 "unknown-0143",
168 "unknown-0144",
169 "unknown-0145",
170 "unknown-0146",
171 "unknown-0147",
172 "unknown-0150",
173 "unknown-0151",
174 "unknown-0152",
175 "unknown-0153",
176 "unknown-0154",
177 "unknown-0155",
178 "unknown-0156",
179 "unknown-0157",
180 "unknown-0160",
181 "unknown-0161",
182 "unknown-0162",
183 "unknown-0163",
184 "unknown-0164",
185 "unknown-0165",
186 "unknown-0166",
187 "unknown-0167",
188 "unknown-0170",
189 "unknown-0171",
190 "unknown-0172",
191 "unknown-0173",
192 "unknown-0174",
193 "unknown-0175",
194 "unknown-0176",
195 "unknown-0177",
196 "stackify-opcode/push-0",
197 "stackify-opcode/push-1",
198 "stackify-opcode/push-2",
199 "stackify-opcode/push-3",
200 "stackify-opcode/push-4",
201 "stackify-opcode/push-5",
202 "stackify-opcode/push-6",
203 "stackify-opcode/push--1",
204 "stackify-opcode/push-cons*-0",
205 "stackify-opcode/push-cons*-1",
206 "stackify-opcode/push-cons*-2",
207 "stackify-opcode/push-cons*-3",
208 "stackify-opcode/push-cons*-4",
209 "stackify-opcode/push-cons*-5",
210 "stackify-opcode/push-cons*-6",
211 "stackify-opcode/push-cons*-7",
212 "stackify-opcode/pop-and-vector-set-0",
213 "stackify-opcode/pop-and-vector-set-1",
214 "stackify-opcode/pop-and-vector-set-2",
215 "stackify-opcode/pop-and-vector-set-3",
216 "stackify-opcode/pop-and-vector-set-4",
217 "stackify-opcode/pop-and-vector-set-5",
218 "stackify-opcode/pop-and-vector-set-6",
219 "stackify-opcode/pop-and-vector-set-7",
220 "stackify-opcode/push-vector-1",
221 "stackify-opcode/push-vector-2",
222 "stackify-opcode/push-vector-3",
223 "stackify-opcode/push-vector-4",
224 "stackify-opcode/push-vector-5",
225 "stackify-opcode/push-vector-6",
226 "stackify-opcode/push-vector-7",
227 "stackify-opcode/push-vector-8",
228 "stackify-opcode/pop-and-record-set-0",
229 "stackify-opcode/pop-and-record-set-1",
230 "stackify-opcode/pop-and-record-set-2",
231 "stackify-opcode/pop-and-record-set-3",
232 "stackify-opcode/pop-and-record-set-4",
233 "stackify-opcode/pop-and-record-set-5",
234 "stackify-opcode/pop-and-record-set-6",
235 "stackify-opcode/pop-and-record-set-7",
236 "stackify-opcode/push-record-1",
237 "stackify-opcode/push-record-2",
238 "stackify-opcode/push-record-3",
239 "stackify-opcode/push-record-4",
240 "stackify-opcode/push-record-5",
241 "stackify-opcode/push-record-6",
242 "stackify-opcode/push-record-7",
243 "stackify-opcode/push-record-8",
244 "stackify-opcode/push-lookup-0",
245 "stackify-opcode/push-lookup-1",
246 "stackify-opcode/push-lookup-2",
247 "stackify-opcode/push-lookup-3",
248 "stackify-opcode/push-lookup-4",
249 "stackify-opcode/push-lookup-5",
250 "stackify-opcode/push-lookup-6",
251 "stackify-opcode/push-lookup-7",
252 "stackify-opcode/store-0",
253 "stackify-opcode/store-1",
254 "stackify-opcode/store-2",
255 "stackify-opcode/store-3",
256 "stackify-opcode/store-4",
257 "stackify-opcode/store-5",
258 "stackify-opcode/store-6",
259 "stackify-opcode/store-7",
260 "stackify-opcode/push-primitive-0",
261 "stackify-opcode/push-primitive-1",
262 "stackify-opcode/push-primitive-2",
263 "stackify-opcode/push-primitive-3",
264 "stackify-opcode/push-primitive-4",
265 "stackify-opcode/push-primitive-5",
266 "stackify-opcode/push-primitive-6",
267 "stackify-opcode/push-primitive-7",
268 "unknown-0310",
269 "unknown-0311",
270 "unknown-0312",
271 "unknown-0313",
272 "unknown-0314",
273 "unknown-0315",
274 "unknown-0316",
275 "unknown-0317",
276 "unknown-0320",
277 "unknown-0321",
278 "unknown-0322",
279 "unknown-0323",
280 "unknown-0324",
281 "unknown-0325",
282 "unknown-0326",
283 "unknown-0327",
284 "unknown-0330",
285 "unknown-0331",
286 "unknown-0332",
287 "unknown-0333",
288 "unknown-0334",
289 "unknown-0335",
290 "unknown-0336",
291 "unknown-0337",
292 "unknown-0340",
293 "unknown-0341",
294 "unknown-0342",
295 "unknown-0343",
296 "unknown-0344",
297 "unknown-0345",
298 "unknown-0346",
299 "unknown-0347",
300 "unknown-0350",
301 "unknown-0351",
302 "unknown-0352",
303 "unknown-0353",
304 "unknown-0354",
305 "unknown-0355",
306 "unknown-0356",
307 "unknown-0357",
308 "unknown-0360",
309 "unknown-0361",
310 "unknown-0362",
311 "unknown-0363",
312 "unknown-0364",
313 "unknown-0365",
314 "unknown-0366",
315 "unknown-0367",
316 "unknown-0370",
317 "unknown-0371",
318 "unknown-0372",
319 "unknown-0373",
320 "unknown-0374",
321 "unknown-0375",
322 "unknown-0376",
323 "unknown-0377",
324 };
325
326 static bool debug_trace_p = 0;
327
328 static void
debug_trace(void)329 debug_trace (void)
330 {
331 if (debug_trace_p)
332 {
333 if (pc == prog_start)
334 fprintf (stderr,
335 "sp_lower = 0x%08x;"
336 " sp_upper = 0x%08x;"
337 " string_end = 0x%08x\n",
338 ((unsigned int) sp_lower),
339 ((unsigned int) sp_upper),
340 ((unsigned int) string_end));
341 fprintf (stderr,
342 "(opcode %s stack-depth %d pc %d strtab-ptr %d)\n",
343 (opcode_names[*pc]),
344 (sp_upper - sp),
345 (pc - prog_start),
346 (strptr - string_start));
347 }
348 }
349
350 #endif /* ENABLE_DEBUGGING_TOOLS */
351
352 static inline SCHEME_OBJECT
unstackify_pop(void)353 unstackify_pop (void)
354 {
355 assert (sp < sp_upper);
356 return (*sp++);
357 }
358
359 static inline SCHEME_OBJECT
unstackify_tos(void)360 unstackify_tos (void)
361 {
362 assert (sp < sp_upper);
363 return (*sp);
364 }
365
366 static inline void
unstackify_push(SCHEME_OBJECT object)367 unstackify_push (SCHEME_OBJECT object)
368 {
369 assert (sp > sp_lower);
370 (*--sp) = object;
371 }
372
373 /* Note: The encoded value is one greater than the actual value,
374 so that the encoding of a ulong never uses a null character.
375 Thus we subtract one after decoding. */
376
377 static unsigned long
unstackify_read_ulong(void)378 unstackify_read_ulong (void)
379 {
380 unsigned int shift = 0;
381 unsigned long value = 0;
382 #ifdef ENABLE_DEBUGGING_TOOLS
383 unsigned long sentinel = 1;
384 #endif
385 while (true)
386 {
387 unsigned char byte = (*strptr++);
388 assert (strptr <= string_end);
389 value |= ((byte & 0x7f) << shift);
390 if ((byte & 0x80) == 0)
391 break;
392 assert ((sentinel <<= 7) != 0);
393 shift += 7;
394 }
395 return (value - 1);
396 }
397
398 static char *
unstackify_read_string(unsigned long * plen)399 unstackify_read_string (unsigned long * plen)
400 {
401 unsigned long len = (unstackify_read_ulong ());
402 char * res = ((char *) strptr);
403 assert ((strptr + len) <= string_end);
404 strptr += len;
405 (*plen) = len;
406 return (res);
407 }
408
409 /* This returns a newly allocated string */
410
411 static char *
unstackify_read_C_string(void)412 unstackify_read_C_string (void)
413 {
414 unsigned long len;
415 char * temp = (unstackify_read_string (&len));
416 char * str = (malloc (len + 1));
417 memcpy (str, temp, len);
418 (str[len]) = '\0';
419 return (str);
420 }
421
422 static void
unstackify_push_consS(unsigned long N)423 unstackify_push_consS (unsigned long N)
424 {
425 unsigned long i;
426 SCHEME_OBJECT kar;
427 SCHEME_OBJECT kdr = (unstackify_pop ());
428
429 for (i = 0; (i <= N); i += 1)
430 {
431 kar = (unstackify_pop ());
432 kdr = (CONS (kar, kdr));
433 }
434
435 unstackify_push (kdr);
436 }
437
438 static void
unstackify_pop_and_set_cXr(unsigned long N)439 unstackify_pop_and_set_cXr (unsigned long N)
440 {
441 SCHEME_OBJECT cXr = (unstackify_pop ());
442 SCHEME_OBJECT pair = (unstackify_tos ());
443 MEMORY_SET (pair, N, cXr);
444 }
445
446 static void
unstackify_push_empty_vector(unsigned long N)447 unstackify_push_empty_vector (unsigned long N)
448 {
449 SCHEME_OBJECT res = (ALLOCATE_VECTOR (N));
450 unstackify_push (res);
451 }
452
453 static void
unstackify_pop_and_vector_set(unsigned long N)454 unstackify_pop_and_vector_set (unsigned long N)
455 {
456 SCHEME_OBJECT el = (unstackify_pop ());
457 SCHEME_OBJECT vec = (unstackify_tos ());
458 VECTOR_SET (vec, N, el);
459 }
460
461 static void
unstackify_push_vector(unsigned long N)462 unstackify_push_vector (unsigned long N)
463 {
464 SCHEME_OBJECT vec = (ALLOCATE_VECTOR (N));
465 unsigned long i;
466
467 for (i = 0; (i < N); i += 1)
468 VECTOR_SET (vec, i, (unstackify_pop ()));
469
470 unstackify_push (vec);
471 }
472
473 static void
unstackify_push_empty_record(unsigned long N)474 unstackify_push_empty_record (unsigned long N)
475 {
476 unstackify_push (ALLOCATE_RECORD (N));
477 }
478
479 static void
unstackify_pop_and_record_set(unsigned long N)480 unstackify_pop_and_record_set (unsigned long N)
481 {
482 SCHEME_OBJECT el = (unstackify_pop ());
483 SCHEME_OBJECT rec = (unstackify_tos ());
484 RECORD_SET (rec, N, el);
485 }
486
487 static void
unstackify_push_record(unsigned long N)488 unstackify_push_record (unsigned long N)
489 {
490 SCHEME_OBJECT rec = (ALLOCATE_RECORD (N));
491 unsigned long i;
492
493 for (i = 0; (i < N); i++)
494 RECORD_SET (rec, i, (unstackify_pop ()));
495
496 unstackify_push (rec);
497 }
498
499 static inline void
unstackify_push_lookup(unsigned long N)500 unstackify_push_lookup (unsigned long N)
501 {
502 assert ((regmap + N) < regmap_end);
503 unstackify_push (regmap[N]);
504 }
505
506 static inline void
unstackify_store(unsigned long N)507 unstackify_store (unsigned long N)
508 {
509 assert ((regmap + N) < regmap_end);
510 (regmap[N]) = (unstackify_tos ());
511 }
512
513 static void
unstackify_push_primitive(long N)514 unstackify_push_primitive (long N)
515 {
516 const char * prim_name = (unstackify_read_C_string ());
517 SCHEME_OBJECT res = (MAKE_PRIMITIVE_PROCEDURE (prim_name, N));
518 free ((void *) prim_name);
519 unstackify_push (res);
520 }
521
522 static inline void
unstackify_undefined_opcode(stackify_opcode_t op)523 unstackify_undefined_opcode (stackify_opcode_t op)
524 {
525 outf_fatal ("unstackify/undefined_opcode invoked.\n");
526 }
527
528 static void
stackify_push_ulong(stackify_opcode_t op)529 stackify_push_ulong (stackify_opcode_t op)
530 {
531 unsigned long N = (unstackify_read_ulong ());
532 unstackify_push ((SCHEME_OBJECT) N);
533 }
534
535 static void
stackify_push_Pfixnum(stackify_opcode_t op)536 stackify_push_Pfixnum (stackify_opcode_t op)
537 {
538 unsigned long N = (unstackify_read_ulong ());
539 unstackify_push (ULONG_TO_FIXNUM (N));
540 }
541
542 static void
stackify_push__fixnum(stackify_opcode_t op)543 stackify_push__fixnum (stackify_opcode_t op)
544 {
545 long val = (0 - ((long) (unstackify_read_ulong ())));
546 unstackify_push (LONG_TO_FIXNUM (val));
547 }
548
549 static void
stackify_push_Pinteger(stackify_opcode_t op)550 stackify_push_Pinteger (stackify_opcode_t op)
551 {
552 unsigned long len;
553 char * digits = (unstackify_read_string (&len));
554 unstackify_push (DIGIT_STRING_TO_INTEGER (false, len, digits));
555 }
556
557 static void
stackify_push__integer(stackify_opcode_t op)558 stackify_push__integer (stackify_opcode_t op)
559 {
560 unsigned long len;
561 char * digits = (unstackify_read_string (&len));
562 unstackify_push (DIGIT_STRING_TO_INTEGER (true, len, digits));
563 }
564
565 static inline void
stackify_push_false(stackify_opcode_t op)566 stackify_push_false (stackify_opcode_t op)
567 {
568 unstackify_push (SHARP_F);
569 }
570
571 static inline void
stackify_push_true(stackify_opcode_t op)572 stackify_push_true (stackify_opcode_t op)
573 {
574 unstackify_push (SHARP_T);
575 }
576
577 static inline void
stackify_push_nil(stackify_opcode_t op)578 stackify_push_nil (stackify_opcode_t op)
579 {
580 unstackify_push (EMPTY_LIST);
581 }
582
583 static void
stackify_push_flonum(stackify_opcode_t op)584 stackify_push_flonum (stackify_opcode_t op)
585 {
586 char * str = (unstackify_read_C_string ());
587 double val = (strtod (str, 0));
588 free (str);
589 unstackify_push (DOUBLE_TO_FLONUM (val));
590 }
591
592 static void
stackify_push_cons_ratnum(stackify_opcode_t op)593 stackify_push_cons_ratnum (stackify_opcode_t op)
594 {
595 SCHEME_OBJECT den = (unstackify_pop ());
596 SCHEME_OBJECT num = (unstackify_pop ());
597 unstackify_push (MAKE_RATIO (num, den));
598 }
599
600 static void
stackify_push_cons_recnum(stackify_opcode_t op)601 stackify_push_cons_recnum (stackify_opcode_t op)
602 {
603 SCHEME_OBJECT imag = (unstackify_pop ());
604 SCHEME_OBJECT real = (unstackify_pop ());
605 unstackify_push (MAKE_COMPLEX (real, imag));
606 }
607
608 static void
stackify_push_string(stackify_opcode_t op)609 stackify_push_string (stackify_opcode_t op)
610 {
611 unsigned long len;
612 char * str = (unstackify_read_string (&len));
613 unstackify_push (C_STRING_TO_SCHEME_STRING (len, str));
614 }
615
616 static void
stackify_push_symbol(stackify_opcode_t op)617 stackify_push_symbol (stackify_opcode_t op)
618 {
619 unsigned long len;
620 char * str = (unstackify_read_string (&len));
621 unstackify_push (C_SYM_INTERN (len, str));
622 }
623
624 static void
stackify_push_uninterned_symbol(stackify_opcode_t op)625 stackify_push_uninterned_symbol (stackify_opcode_t op)
626 {
627 unsigned long len;
628 char * str = (unstackify_read_string (&len));
629 unstackify_push (C_TO_UNINTERNED_SYMBOL (len, str));
630 }
631
632 static void
stackify_push_char(stackify_opcode_t op)633 stackify_push_char (stackify_opcode_t op)
634 {
635 unsigned long bits = (unstackify_read_ulong ());
636 unsigned long code = (unstackify_read_ulong ());
637 unstackify_push (MAKE_CHAR (bits, code));
638 }
639
640 static void
stackify_push_bit_string(stackify_opcode_t op)641 stackify_push_bit_string (stackify_opcode_t op)
642 {
643 unsigned long n_bits = (unstackify_read_ulong ());
644 unsigned long len;
645 char * digits = (unstackify_read_string (&len));
646 unstackify_push (DIGIT_STRING_TO_BIT_STRING (n_bits, len, digits));
647 }
648
649 static void
stackify_push_empty_cons(stackify_opcode_t op)650 stackify_push_empty_cons (stackify_opcode_t op)
651 {
652 unstackify_push (CONS (SHARP_F, SHARP_F));
653 }
654
655 static inline void
stackify_pop_and_set_car(stackify_opcode_t op)656 stackify_pop_and_set_car (stackify_opcode_t op)
657 {
658 unstackify_pop_and_set_cXr (CONS_CAR);
659 }
660
661 static inline void
stackify_pop_and_set_cdr(stackify_opcode_t op)662 stackify_pop_and_set_cdr (stackify_opcode_t op)
663 {
664 unstackify_pop_and_set_cXr (CONS_CDR);
665 }
666
667 static void
stackify_push_consS(stackify_opcode_t op)668 stackify_push_consS (stackify_opcode_t op)
669 {
670 unsigned long N = (unstackify_read_ulong ());
671 unstackify_push_consS (N);
672 }
673
674 static void
stackify_push_empty_vector(stackify_opcode_t op)675 stackify_push_empty_vector (stackify_opcode_t op)
676 {
677 unsigned long N = (unstackify_read_ulong ());
678 unstackify_push_empty_vector (N);
679 }
680
681 static void
stackify_pop_and_vector_set(stackify_opcode_t op)682 stackify_pop_and_vector_set (stackify_opcode_t op)
683 {
684 unsigned long N = (unstackify_read_ulong ());
685 unstackify_pop_and_vector_set (N);
686 }
687
688 static void
stackify_push_vector(stackify_opcode_t op)689 stackify_push_vector (stackify_opcode_t op)
690 {
691 unsigned long N = (unstackify_read_ulong ());
692 unstackify_push_vector (N);
693 }
694
695 static void
stackify_push_empty_record(stackify_opcode_t op)696 stackify_push_empty_record (stackify_opcode_t op)
697 {
698 unsigned long N = (unstackify_read_ulong ());
699 unstackify_push_empty_record (N);
700 }
701
702 static void
stackify_pop_and_record_set(stackify_opcode_t op)703 stackify_pop_and_record_set (stackify_opcode_t op)
704 {
705 unsigned long N = (unstackify_read_ulong ());
706 unstackify_pop_and_record_set (N);
707 }
708
709 static void
stackify_push_record(stackify_opcode_t op)710 stackify_push_record (stackify_opcode_t op)
711 {
712 unsigned long N = (unstackify_read_ulong ());
713 unstackify_push_record (N);
714 }
715
716 static void
stackify_push_lookup(stackify_opcode_t op)717 stackify_push_lookup (stackify_opcode_t op)
718 {
719 unsigned long N = (unstackify_read_ulong ());
720 unstackify_push_lookup (N);
721 }
722
723 static void
stackify_store(stackify_opcode_t op)724 stackify_store (stackify_opcode_t op)
725 {
726 unsigned long N = (unstackify_read_ulong ());
727 unstackify_store (N);
728 }
729
730 static void
stackify_push_constant(stackify_opcode_t op)731 stackify_push_constant (stackify_opcode_t op)
732 {
733 unsigned long N = (unstackify_read_ulong ());
734 unstackify_push (MAKE_OBJECT (TC_CONSTANT, N));
735 }
736
737 static inline void
stackify_push_unassigned(stackify_opcode_t op)738 stackify_push_unassigned (stackify_opcode_t op)
739 {
740 unstackify_push (UNASSIGNED_OBJECT);
741 }
742
743 static void
stackify_push_primitive(stackify_opcode_t op)744 stackify_push_primitive (stackify_opcode_t op)
745 {
746 unsigned long N = (unstackify_read_ulong ());
747 unstackify_push_primitive ((long) N);
748 }
749
750 static inline void
stackify_push_primitive_lexpr(stackify_opcode_t op)751 stackify_push_primitive_lexpr (stackify_opcode_t op)
752 {
753 unstackify_push_primitive (-1);
754 }
755
756 static void
stackify_push_N(stackify_opcode_t op)757 stackify_push_N (stackify_opcode_t op)
758 {
759 unstackify_push (ULONG_TO_FIXNUM (op - stackify_opcode_push_0));
760 }
761
762 static void
stackify_push__1(stackify_opcode_t op)763 stackify_push__1 (stackify_opcode_t op)
764 {
765 unstackify_push (LONG_TO_FIXNUM (-1));
766 }
767
768 static inline void
stackify_push_consS_N(stackify_opcode_t op)769 stackify_push_consS_N (stackify_opcode_t op)
770 {
771 unstackify_push_consS (op - stackify_opcode_push_consS_0);
772 }
773
774 static inline void
stackify_pop_and_vector_set_N(stackify_opcode_t op)775 stackify_pop_and_vector_set_N (stackify_opcode_t op)
776 {
777 unstackify_pop_and_vector_set (op - stackify_opcode_pop_and_vector_set_0);
778 }
779
780 static inline void
stackify_push_vector_N(stackify_opcode_t op)781 stackify_push_vector_N (stackify_opcode_t op)
782 {
783 unstackify_push_vector (1 + (op - stackify_opcode_push_vector_1));
784 }
785
786 static inline void
stackify_pop_and_record_set_N(stackify_opcode_t op)787 stackify_pop_and_record_set_N (stackify_opcode_t op)
788 {
789 unstackify_pop_and_record_set (op - stackify_opcode_pop_and_record_set_0);
790 }
791
792 static inline void
stackify_push_record_N(stackify_opcode_t op)793 stackify_push_record_N (stackify_opcode_t op)
794 {
795 unstackify_push_record (1 + (op - stackify_opcode_push_record_1));
796 }
797
798 static inline void
stackify_push_lookup_N(stackify_opcode_t op)799 stackify_push_lookup_N (stackify_opcode_t op)
800 {
801 unstackify_push_lookup (op - stackify_opcode_push_lookup_0);
802 }
803
804 static inline void
stackify_store_N(stackify_opcode_t op)805 stackify_store_N (stackify_opcode_t op)
806 {
807 unstackify_store (op - stackify_opcode_store_0);
808 }
809
810 static inline void
stackify_push_primitive_N(stackify_opcode_t op)811 stackify_push_primitive_N (stackify_opcode_t op)
812 {
813 unstackify_push_primitive (op - stackify_opcode_push_primitive_0);
814 }
815
816 static void
stackify_push_nm_header(stackify_opcode_t op)817 stackify_push_nm_header (stackify_opcode_t op)
818 {
819 unstackify_push
820 (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, (unstackify_read_ulong ())));
821 }
822
823 static void
stackify_push_label_entry(stackify_opcode_t op)824 stackify_push_label_entry (stackify_opcode_t op)
825 {
826 unstackify_push
827 ((SCHEME_OBJECT)
828 (((unsigned long) dispatch_base)
829 + (unstackify_read_ulong ())));
830 }
831
832 static void
stackify_push_label_descriptor(stackify_opcode_t op)833 stackify_push_label_descriptor (stackify_opcode_t op)
834 {
835 unsigned long offset = (unstackify_read_ulong ());
836 unsigned long code_word = (unstackify_read_ulong ());
837 unstackify_push (MAKE_LABEL_DESCRIPTOR (code_word, offset));
838 }
839
840 static void
stackify_retag_cc_block(stackify_opcode_t op)841 stackify_retag_cc_block (stackify_opcode_t op)
842 {
843 unstackify_push
844 (OBJECT_NEW_TYPE (TC_COMPILED_CODE_BLOCK, (unstackify_pop ())));
845 }
846
847 static void
stackify_cc_block_to_entry(stackify_opcode_t op)848 stackify_cc_block_to_entry (stackify_opcode_t op)
849 {
850 unsigned long offset = (unstackify_read_ulong ());
851 SCHEME_OBJECT block = (unstackify_pop ());
852 unstackify_push (CC_BLOCK_TO_ENTRY (block, offset));
853 }
854
855 static void
stackify_push_return_code(stackify_opcode_t op)856 stackify_push_return_code (stackify_opcode_t op)
857 {
858 unstackify_push (MAKE_OBJECT (TC_RETURN_CODE, (unstackify_read_ulong ())));
859 }
860
861 static void
unstackify_push_linkage_header(linkage_section_type_t type)862 unstackify_push_linkage_header (linkage_section_type_t type)
863 {
864 unstackify_push (MAKE_LINKER_HEADER (type, (unstackify_read_ulong ())));
865 }
866
867 static void
stackify_push_linkage_header_operator(stackify_opcode_t op)868 stackify_push_linkage_header_operator (stackify_opcode_t op)
869 {
870 unstackify_push_linkage_header (LINKAGE_SECTION_TYPE_OPERATOR);
871 }
872
873 static void
stackify_push_linkage_header_reference(stackify_opcode_t op)874 stackify_push_linkage_header_reference (stackify_opcode_t op)
875 {
876 unstackify_push_linkage_header (LINKAGE_SECTION_TYPE_REFERENCE);
877 }
878
879 static void
stackify_push_linkage_header_assignment(stackify_opcode_t op)880 stackify_push_linkage_header_assignment (stackify_opcode_t op)
881 {
882 unstackify_push_linkage_header (LINKAGE_SECTION_TYPE_ASSIGNMENT);
883 }
884
885 static void
stackify_push_linkage_header_global(stackify_opcode_t op)886 stackify_push_linkage_header_global (stackify_opcode_t op)
887 {
888 unstackify_push_linkage_header (LINKAGE_SECTION_TYPE_GLOBAL_OPERATOR);
889 }
890
891 static void
stackify_push_linkage_header_closure(stackify_opcode_t op)892 stackify_push_linkage_header_closure (stackify_opcode_t op)
893 {
894 outf_fatal ("stackify_push_linkage_header_closure.\n");
895 }
896
897 static void
unstackify_save_context(stackify_context_t context)898 unstackify_save_context (stackify_context_t context)
899 {
900 (context->strptr) = strptr;
901 (context->dispatch_base) = dispatch_base;
902 (context->sp) = sp;
903 (context->regmap) = regmap;
904 }
905
906 static void
unstackify_restore_context(stackify_context_t context)907 unstackify_restore_context (stackify_context_t context)
908 {
909 strptr = (context->strptr);
910 dispatch_base = (context->dispatch_base);
911 sp = (context->sp);
912 regmap = (context->regmap);
913 }
914
915 SCHEME_OBJECT
unstackify(unsigned char * bytes,size_t n_bytes,entry_count_t db)916 unstackify (unsigned char * bytes, size_t n_bytes, entry_count_t db)
917 {
918 unsigned char op;
919 SCHEME_OBJECT result;
920 SCHEME_OBJECT * scratch;
921 unsigned long stack_length;
922 unsigned long regmap_length;
923 unsigned long prog_length;
924 stackify_context_s context;
925
926 unstackify_save_context (& context);
927
928 /* Read the header */
929
930 string_start = bytes;
931 string_end = (bytes + n_bytes);
932 strptr = string_start;
933
934 stack_length = (unstackify_read_ulong ());
935 regmap_length = (unstackify_read_ulong ());
936 prog_length = (unstackify_read_ulong ());
937
938 /* Set up for execution */
939
940 prog_start = strptr;
941 prog_end = (prog_start + prog_length);
942 pc = prog_start;
943
944 string_start = prog_end;
945 strptr = string_start;
946
947 scratch = (malloc ((stack_length + regmap_length) * SIZEOF_SCHEME_OBJECT));
948 if (scratch == 0)
949 return (SHARP_F);
950
951 sp_lower = scratch;
952 sp_upper = (sp_lower + stack_length);
953 sp = sp_upper;
954
955 regmap = sp_upper;
956 regmap_end = (regmap + regmap_length);
957
958 dispatch_base = db;
959
960 /* Now, execute the program */
961
962 while (pc < prog_end)
963 {
964 #ifdef ENABLE_DEBUGGING_TOOLS
965 debug_trace ();
966 #endif
967 op = ((stackify_opcode_t) (*pc++));
968 switch (op)
969 {
970 default:
971 case stackify_opcode_illegal:
972 case stackify_opcode_escape:
973 unstackify_undefined_opcode (op);
974 break;
975
976 case stackify_opcode_push_Pfixnum:
977 stackify_push_Pfixnum (op);
978 break;
979
980 case stackify_opcode_push__fixnum:
981 stackify_push__fixnum (op);
982 break;
983
984 case stackify_opcode_push_Pinteger:
985 stackify_push_Pinteger (op);
986 break;
987
988 case stackify_opcode_push__integer:
989 stackify_push__integer (op);
990 break;
991
992 case stackify_opcode_push_false:
993 stackify_push_false (op);
994 break;
995
996 case stackify_opcode_push_true:
997 stackify_push_true (op);
998 break;
999
1000 case stackify_opcode_push_nil:
1001 stackify_push_nil (op);
1002 break;
1003
1004 case stackify_opcode_push_flonum:
1005 stackify_push_flonum (op);
1006 break;
1007
1008 case stackify_opcode_push_cons_ratnum:
1009 stackify_push_cons_ratnum (op);
1010 break;
1011
1012 case stackify_opcode_push_cons_recnum:
1013 stackify_push_cons_recnum (op);
1014 break;
1015
1016 case stackify_opcode_push_string:
1017 stackify_push_string (op);
1018 break;
1019
1020 case stackify_opcode_push_symbol:
1021 stackify_push_symbol (op);
1022 break;
1023
1024 case stackify_opcode_push_uninterned_symbol:
1025 stackify_push_uninterned_symbol (op);
1026 break;
1027
1028 case stackify_opcode_push_char:
1029 stackify_push_char (op);
1030 break;
1031
1032 case stackify_opcode_push_bit_string:
1033 stackify_push_bit_string (op);
1034 break;
1035
1036 case stackify_opcode_push_empty_cons:
1037 stackify_push_empty_cons (op);
1038 break;
1039
1040 case stackify_opcode_pop_and_set_car:
1041 stackify_pop_and_set_car (op);
1042 break;
1043
1044 case stackify_opcode_pop_and_set_cdr:
1045 stackify_pop_and_set_cdr (op);
1046 break;
1047
1048 case stackify_opcode_push_consS:
1049 stackify_push_consS (op);
1050 break;
1051
1052 case stackify_opcode_push_empty_vector:
1053 stackify_push_empty_vector (op);
1054 break;
1055
1056 case stackify_opcode_pop_and_vector_set:
1057 stackify_pop_and_vector_set (op);
1058 break;
1059
1060 case stackify_opcode_push_vector:
1061 stackify_push_vector (op);
1062 break;
1063
1064 case stackify_opcode_push_empty_record:
1065 stackify_push_empty_record (op);
1066 break;
1067
1068 case stackify_opcode_pop_and_record_set:
1069 stackify_pop_and_record_set (op);
1070 break;
1071
1072 case stackify_opcode_push_record:
1073 stackify_push_record (op);
1074 break;
1075
1076 case stackify_opcode_push_lookup:
1077 stackify_push_lookup (op);
1078 break;
1079
1080 case stackify_opcode_store:
1081 stackify_store (op);
1082 break;
1083
1084 case stackify_opcode_push_constant:
1085 stackify_push_constant (op);
1086 break;
1087
1088 case stackify_opcode_push_unassigned:
1089 stackify_push_unassigned (op);
1090 break;
1091
1092 case stackify_opcode_push_primitive:
1093 stackify_push_primitive (op);
1094 break;
1095
1096 case stackify_opcode_push_primitive_lexpr:
1097 stackify_push_primitive_lexpr (op);
1098 break;
1099
1100 case stackify_opcode_push_0:
1101 case stackify_opcode_push_1:
1102 case stackify_opcode_push_2:
1103 case stackify_opcode_push_3:
1104 case stackify_opcode_push_4:
1105 case stackify_opcode_push_5:
1106 case stackify_opcode_push_6:
1107 stackify_push_N (op);
1108 break;
1109
1110 case stackify_opcode_push__1:
1111 stackify_push__1 (op);
1112 break;
1113
1114 case stackify_opcode_push_consS_0:
1115 case stackify_opcode_push_consS_1:
1116 case stackify_opcode_push_consS_2:
1117 case stackify_opcode_push_consS_3:
1118 case stackify_opcode_push_consS_4:
1119 case stackify_opcode_push_consS_5:
1120 case stackify_opcode_push_consS_6:
1121 case stackify_opcode_push_consS_7:
1122 stackify_push_consS_N (op);
1123 break;
1124
1125 case stackify_opcode_pop_and_vector_set_0:
1126 case stackify_opcode_pop_and_vector_set_1:
1127 case stackify_opcode_pop_and_vector_set_2:
1128 case stackify_opcode_pop_and_vector_set_3:
1129 case stackify_opcode_pop_and_vector_set_4:
1130 case stackify_opcode_pop_and_vector_set_5:
1131 case stackify_opcode_pop_and_vector_set_6:
1132 case stackify_opcode_pop_and_vector_set_7:
1133 stackify_pop_and_vector_set_N (op);
1134 break;
1135
1136 case stackify_opcode_push_vector_1:
1137 case stackify_opcode_push_vector_2:
1138 case stackify_opcode_push_vector_3:
1139 case stackify_opcode_push_vector_4:
1140 case stackify_opcode_push_vector_5:
1141 case stackify_opcode_push_vector_6:
1142 case stackify_opcode_push_vector_7:
1143 case stackify_opcode_push_vector_8:
1144 stackify_push_vector_N (op);
1145 break;
1146
1147 case stackify_opcode_pop_and_record_set_0:
1148 case stackify_opcode_pop_and_record_set_1:
1149 case stackify_opcode_pop_and_record_set_2:
1150 case stackify_opcode_pop_and_record_set_3:
1151 case stackify_opcode_pop_and_record_set_4:
1152 case stackify_opcode_pop_and_record_set_5:
1153 case stackify_opcode_pop_and_record_set_6:
1154 case stackify_opcode_pop_and_record_set_7:
1155 stackify_pop_and_record_set_N (op);
1156 break;
1157
1158 case stackify_opcode_push_record_1:
1159 case stackify_opcode_push_record_2:
1160 case stackify_opcode_push_record_3:
1161 case stackify_opcode_push_record_4:
1162 case stackify_opcode_push_record_5:
1163 case stackify_opcode_push_record_6:
1164 case stackify_opcode_push_record_7:
1165 case stackify_opcode_push_record_8:
1166 stackify_push_record_N (op);
1167 break;
1168
1169 case stackify_opcode_push_lookup_0:
1170 case stackify_opcode_push_lookup_1:
1171 case stackify_opcode_push_lookup_2:
1172 case stackify_opcode_push_lookup_3:
1173 case stackify_opcode_push_lookup_4:
1174 case stackify_opcode_push_lookup_5:
1175 case stackify_opcode_push_lookup_6:
1176 case stackify_opcode_push_lookup_7:
1177 stackify_push_lookup_N (op);
1178 break;
1179
1180 case stackify_opcode_store_0:
1181 case stackify_opcode_store_1:
1182 case stackify_opcode_store_2:
1183 case stackify_opcode_store_3:
1184 case stackify_opcode_store_4:
1185 case stackify_opcode_store_5:
1186 case stackify_opcode_store_6:
1187 case stackify_opcode_store_7:
1188 stackify_store_N (op);
1189 break;
1190
1191 case stackify_opcode_push_primitive_0:
1192 case stackify_opcode_push_primitive_1:
1193 case stackify_opcode_push_primitive_2:
1194 case stackify_opcode_push_primitive_3:
1195 case stackify_opcode_push_primitive_4:
1196 case stackify_opcode_push_primitive_5:
1197 case stackify_opcode_push_primitive_6:
1198 case stackify_opcode_push_primitive_7:
1199 stackify_push_primitive_N (op);
1200 break;
1201
1202 /* Compiler support */
1203 /* Ordinary objects don't need the following */
1204
1205 case stackify_opcode_push_nm_header:
1206 stackify_push_nm_header (op);
1207 break;
1208
1209 case stackify_opcode_push_linkage_header_operator:
1210 stackify_push_linkage_header_operator (op);
1211 break;
1212
1213 case stackify_opcode_push_linkage_header_reference:
1214 stackify_push_linkage_header_reference (op);
1215 break;
1216
1217 case stackify_opcode_push_linkage_header_assignment:
1218 stackify_push_linkage_header_assignment (op);
1219 break;
1220
1221 case stackify_opcode_push_linkage_header_global:
1222 stackify_push_linkage_header_global (op);
1223 break;
1224
1225 case stackify_opcode_push_linkage_header_closure:
1226 stackify_push_linkage_header_closure (op);
1227 break;
1228
1229 case stackify_opcode_push_ulong:
1230 stackify_push_ulong (op);
1231 break;
1232
1233 case stackify_opcode_push_label_entry:
1234 stackify_push_label_entry (op);
1235 break;
1236
1237 case stackify_opcode_push_label_descriptor:
1238 stackify_push_label_descriptor (op);
1239 break;
1240
1241 case stackify_opcode_retag_cc_block:
1242 stackify_retag_cc_block (op);
1243 break;
1244
1245 case stackify_opcode_cc_block_to_entry:
1246 stackify_cc_block_to_entry (op);
1247 break;
1248
1249 case stackify_opcode_push_return_code:
1250 stackify_push_return_code (op);
1251 break;
1252 }
1253 }
1254
1255 /* Grab the result and return it */
1256
1257 result = (unstackify_pop ());
1258 free (scratch);
1259 unstackify_restore_context (&context);
1260 return (result);
1261 }
1262