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 /* Compiled-code interface */
28
29 /* Some of the cmpintmd/FOO.h files use this macro to alter their
30 behavior when included here. */
31 #define IN_CMPINT_C 1
32
33 #include "scheme.h"
34 #include "prims.h"
35 #include "lookup.h"
36 #include "trap.h"
37 #include "history.h"
38 #include "cmpgc.h"
39
40 /* Two special classes of procedures are used in this file:
41
42 Scheme interface entries. These procedures are called from C and
43 ultimately invoke 'ENTER_SCHEME' to enter compiled code, or return
44 a status code.
45
46 Scheme interface utilities. These procedures are called from the
47 Scheme interface and perform tasks that the compiler does not code
48 inline. They are referenced from compiled Scheme code by index,
49 and the assembly language interface fetches them from an array.
50 They are defined with 'SCHEME_UTILITY_n' for some 'n', and
51 ultimately invoke either 'RETURN_TO_SCHEME' (in the normal case) or
52 'RETURN_TO_C' (in the error case). */
53
54 typedef long cache_handler_t (SCHEME_OBJECT, SCHEME_OBJECT, unsigned long);
55
56 typedef struct
57 {
58 SCHEME_OBJECT * block_address;
59 SCHEME_OBJECT * scan;
60 unsigned long n_sections;
61 insn_t * return_address;
62 unsigned long n_linked_sections;
63 SCHEME_OBJECT * scan0;
64 linkage_section_type_t type;
65 unsigned long n_entries;
66 unsigned long n_linked_entries;
67 } link_cc_state_t;
68
69 /* Ways to bypass the interpreter */
70 typedef enum
71 {
72 REFLECT_CODE_INTERNAL_APPLY,
73 REFLECT_CODE_RESTORE_INTERRUPT_MASK,
74 REFLECT_CODE_STACK_MARKER,
75 REFLECT_CODE_CC_BKPT
76 } reflect_code_t;
77
78 #define PUSH_REFLECTION(code) do \
79 { \
80 STACK_PUSH (ULONG_TO_FIXNUM (code)); \
81 STACK_PUSH (reflect_to_interface); \
82 } while (false)
83
84 #define TC_TRAMPOLINE_HEADER TC_FIXNUM
85 #define TRAMPOLINE_TABLE_SIZE 4
86
87 static trampoline_type_t
88 trampoline_arity_table [TRAMPOLINE_TABLE_SIZE * TRAMPOLINE_TABLE_SIZE] =
89 {
90 TRAMPOLINE_K_1_0, /* 1_0 */
91 TRAMPOLINE_K_APPLY, /* 1_1 should not get here */
92 TRAMPOLINE_K_APPLY, /* 1_2 should not get here */
93 TRAMPOLINE_K_APPLY, /* 1_3 should not get here */
94 TRAMPOLINE_K_2_0, /* 2_0 */
95 TRAMPOLINE_K_2_1, /* 2_1 */
96 TRAMPOLINE_K_APPLY, /* 2_2 should not get here */
97 TRAMPOLINE_K_APPLY, /* 2_3 should not get here */
98 TRAMPOLINE_K_3_0, /* 3_0 */
99 TRAMPOLINE_K_3_1, /* 3_1 */
100 TRAMPOLINE_K_3_2, /* 3_2 */
101 TRAMPOLINE_K_APPLY, /* 3_3 should not get here */
102 TRAMPOLINE_K_4_0, /* 4_0 */
103 TRAMPOLINE_K_4_1, /* 4_1 */
104 TRAMPOLINE_K_4_2, /* 4_2 */
105 TRAMPOLINE_K_4_3 /* 4_3 */
106 };
107
108 cc_arch_t compiler_processor_type;
109 unsigned int compiler_interface_version;
110
111 SCHEME_OBJECT compiler_utilities;
112 SCHEME_OBJECT return_to_interpreter;
113 SCHEME_OBJECT reflect_to_interface;
114
115 static bool linking_cc_block_p = 0;
116
117 static SCHEME_OBJECT make_compiler_utilities (void);
118 static void open_stack_gap (unsigned long, unsigned long);
119 static void close_stack_gap (unsigned long, unsigned long);
120 static void recover_from_apply_error (SCHEME_OBJECT, unsigned long);
121 static long link_remaining_sections (link_cc_state_t *);
122 static void start_linking_cc_block (void);
123 static void end_linking_cc_block (link_cc_state_t *);
124 static void abort_linking_cc_block (void *);
125 static void update_cache_after_link (link_cc_state_t *);
126 static void start_linking_section (link_cc_state_t *);
127 static long link_section (link_cc_state_t *);
128 static bool link_section_handler
129 (linkage_section_type_t, cache_handler_t **, bool *);
130 static void back_out_of_link_section (link_cc_state_t *);
131 static void restore_link_cc_state (link_cc_state_t *);
132 static void count_linkage_sections
133 (SCHEME_OBJECT *, SCHEME_OBJECT *, unsigned long *, unsigned long *);
134 static SCHEME_OBJECT read_linkage_sections
135 (SCHEME_OBJECT *, SCHEME_OBJECT *, unsigned long, unsigned long);
136 static bool section_execute_p (SCHEME_OBJECT);
137 static void setup_compiled_invocation_from_primitive
138 (SCHEME_OBJECT, unsigned long);
139 static long setup_compiled_invocation (SCHEME_OBJECT, unsigned long);
140 static long setup_lexpr_invocation
141 (SCHEME_OBJECT, unsigned long, unsigned long);
142 static bool open_gap (unsigned long, unsigned long);
143 static bool unlinked_section_start_p (SCHEME_OBJECT *, SCHEME_OBJECT *);
144 static bool cc_block_address_closure_p (SCHEME_OBJECT *);
145 static void write_uuo_link (SCHEME_OBJECT, SCHEME_OBJECT *);
146 static long make_fake_uuo_link (SCHEME_OBJECT, SCHEME_OBJECT, unsigned long);
147 static long make_trampoline
148 (SCHEME_OBJECT *, cc_entry_type_t *, trampoline_type_t, unsigned int, ...);
149 static void make_trampoline_headers
150 (unsigned long, unsigned long,
151 SCHEME_OBJECT *, SCHEME_OBJECT *, unsigned long *);
152 static bool fill_trampoline
153 (SCHEME_OBJECT *, unsigned long, cc_entry_type_t *, trampoline_type_t);
154 static long make_redirection_trampoline
155 (SCHEME_OBJECT *, trampoline_type_t, SCHEME_OBJECT);
156 static long make_apply_trampoline
157 (SCHEME_OBJECT *, trampoline_type_t, SCHEME_OBJECT, unsigned long);
158
159 #ifndef UTILITY_RESULT_DEFINED
160 #ifdef CMPINT_USE_STRUCS
161
162 #ifdef C_FUNC_PTR_IS_CLOSURE
163 typedef insn_t * c_func_t;
164 #else
165 typedef void c_func_t (void);
166 /* From trunk, but may not be needed: */
167 # if 0
168 # ifdef __OPEN_WATCOM_14__
169 # define REFENTRY(name) ((void *) name)
170 # else
171 # define REFENTRY(name) ((c_func_t *) name)
172 # endif
173 # define VARENTRY(name) c_func_t * name
174 # define EXTENTRY(name) extern c_func_t ASM_ENTRY_POINT (name)
175 # endif
176 #endif
177
178 #define RETURN_TO_C(code) do \
179 { \
180 (DSU_result->interface_dispatch) = interface_to_C; \
181 ((DSU_result->extra) . code_to_interpreter) = (code); \
182 return; \
183 } while (false)
184
185 #define RETURN_TO_SCHEME(ep) do \
186 { \
187 (DSU_result->interface_dispatch) = interface_to_scheme; \
188 ((DSU_result->extra) . entry_point) = (ep); \
189 return; \
190 } while (false)
191
192 extern c_func_t ASM_ENTRY_POINT (interface_to_C);
193 extern c_func_t ASM_ENTRY_POINT (interface_to_scheme);
194
195 #define ENTER_SCHEME(ep) return (C_to_interface (ep))
196 extern long ASM_ENTRY_POINT (C_to_interface) (insn_t *);
197
198 #else /* !CMPINT_USE_STRUCS */
199
200 #define RETURN_TO_C(code) do \
201 { \
202 (*DSU_result) = interface_to_C_hook; \
203 C_return_value = (code); \
204 return; \
205 } while (false)
206
207 #define RETURN_TO_SCHEME(ep) do \
208 { \
209 (*DSU_result) = (ep); \
210 return; \
211 } while (false)
212
213 #define ENTER_SCHEME(ep) do \
214 { \
215 C_to_interface (ep); \
216 return (C_return_value); \
217 } while (false)
218
219 extern utility_result_t interface_to_C_hook;
220 extern void ASM_ENTRY_POINT (C_to_interface) (insn_t *);
221 long C_return_value;
222
223 #endif /* !CMPINT_USE_STRUCS */
224 #endif /* !UTILITY_RESULT_DEFINED */
225
226 #define JUMP_TO_CC_ENTRY(entry) ENTER_SCHEME (CC_ENTRY_ADDRESS (entry))
227
228 #ifndef COMPILER_REGBLOCK_N_FIXED
229 # define COMPILER_REGBLOCK_N_FIXED REGBLOCK_MINIMUM_LENGTH
230 #endif
231
232 #ifndef COMPILER_REGBLOCK_N_TEMPS
233 # define COMPILER_REGBLOCK_N_TEMPS 0
234 #endif
235
236 #ifndef COMPILER_TEMP_SIZE
237 # define COMPILER_TEMP_SIZE ((sizeof (double)) / (sizeof (SCHEME_OBJECT)))
238 #endif
239
240 #ifndef COMPILER_REGBLOCK_EXTRA_SIZE
241 # define COMPILER_REGBLOCK_EXTRA_SIZE 0
242 #endif
243
244 #if (REGBLOCK_MINIMUM_LENGTH > COMPILER_REGBLOCK_N_FIXED)
245 # include "ERROR: cmpint.c and const.h disagree on REGBLOCK_MINIMUM_LENGTH!"
246 #endif
247
248 #define REGBLOCK_LENGTH \
249 (COMPILER_REGBLOCK_N_FIXED \
250 + (COMPILER_REGBLOCK_N_TEMPS * COMPILER_TEMP_SIZE) \
251 + COMPILER_REGBLOCK_EXTRA_SIZE)
252
253 #ifndef REGBLOCK_ALLOCATED_BY_INTERFACE
254 SCHEME_OBJECT Registers [REGBLOCK_LENGTH];
255 #endif
256
257 #ifndef ASM_RESET_HOOK
258 # define ASM_RESET_HOOK() do {} while (false)
259 #endif
260
261 #define SAVE_LAST_RETURN_CODE(code) do \
262 { \
263 { \
264 long SLRC_offset \
265 = (STACK_LOCATIVE_DIFFERENCE (stack_pointer, last_return_code)); \
266 assert (SLRC_offset > 0); \
267 STACK_PUSH (LONG_TO_FIXNUM (SLRC_offset)); \
268 } \
269 PUSH_RC (code); \
270 COMPILER_NEW_SUBPROBLEM (); \
271 } while (false)
272
273 #define RESTORE_LAST_RETURN_CODE() do \
274 { \
275 last_return_code = (STACK_LOC (FIXNUM_TO_ULONG (GET_EXP))); \
276 CHECK_LAST_RETURN_CODE (); \
277 COMPILER_END_SUBPROBLEM (); \
278 } while (false)
279
280 #define CHECK_LAST_RETURN_CODE() do \
281 { \
282 assert \
283 (RETURN_CODE_P \
284 (STACK_LOCATIVE_REFERENCE (last_return_code, \
285 CONTINUATION_RETURN_CODE))); \
286 } while (false)
287
288 /* Initialization */
289
290 void
compiler_initialize(bool fasl_p)291 compiler_initialize (bool fasl_p)
292 {
293 /* Called when scheme started. */
294 SET_PRIMITIVE (SHARP_F);
295 compiler_processor_type = COMPILER_PROCESSOR_TYPE;
296 compiler_interface_version = COMPILER_INTERFACE_VERSION;
297 if (fasl_p)
298 compiler_reset (make_compiler_utilities ());
299 else
300 {
301 /* Delay until after band-load, when compiler_reset will be invoked. */
302 compiler_utilities = SHARP_F;
303 return_to_interpreter = SHARP_F;
304 #ifdef CC_ARCH_INITIALIZE
305 CC_ARCH_INITIALIZE ();
306 #endif
307 }
308 }
309
310 #define COMPILER_UTILITIES_HEADERS(h1, h2, n) \
311 make_trampoline_headers (2, 2, (h1), (h2), (n))
312
313 static SCHEME_OBJECT
make_compiler_utilities(void)314 make_compiler_utilities (void)
315 {
316 SCHEME_OBJECT h1;
317 SCHEME_OBJECT h2;
318 unsigned long n_words;
319 SCHEME_OBJECT * block;
320
321 COMPILER_UTILITIES_HEADERS ((&h1), (&h2), (&n_words));
322 if (GC_NEEDED_P (n_words))
323 {
324 outf_fatal ("Can't allocate compiler_utilities.\n");
325 Microcode_Termination (TERM_NO_SPACE);
326 }
327 h1 = (OBJECT_NEW_TYPE (TC_MANIFEST_VECTOR, h1));
328
329 block = Free;
330 Free += n_words;
331 (block[0]) = h1;
332 (block[1]) = h2;
333
334 {
335 cc_entry_type_t cet;
336 make_cc_entry_type ((&cet), CET_RETURN_TO_INTERPRETER);
337 if ((fill_trampoline (block, 0, (&cet), TRAMPOLINE_K_RETURN_TO_INTERPRETER))
338 ||
339 (fill_trampoline (block, 1, (&cet), TRAMPOLINE_K_REFLECT_TO_INTERFACE)))
340 {
341 outf_fatal ("\nError in make_compiler_utilities\n");
342 Microcode_Termination (TERM_COMPILER_DEATH);
343 /*NOTREACHED*/
344 }
345 }
346
347 /* These entries are no longer used, but are provided for
348 compatibility with the previous structure. */
349 {
350 SCHEME_OBJECT * store = (trampoline_storage (block));
351 (store[0]) = ((trampoline_entry_addr (block, 0)) - ((insn_t *) block));
352 (store[1]) = ((trampoline_entry_addr (block, 1)) - ((insn_t *) block));
353 }
354
355 block = (copy_to_constant_space (block, n_words));
356 return (MAKE_CC_BLOCK (block));
357 }
358
359 void
compiler_reset(SCHEME_OBJECT new_block)360 compiler_reset (SCHEME_OBJECT new_block)
361 {
362 /* Called after a disk restore */
363 SCHEME_OBJECT h1;
364 SCHEME_OBJECT h2;
365 unsigned long n_words;
366 SCHEME_OBJECT * nbp;
367
368 COMPILER_UTILITIES_HEADERS ((&h1), (&h2), (&n_words));
369 h1 = (OBJECT_NEW_TYPE (TC_MANIFEST_VECTOR, h1));
370 if (! ((CC_BLOCK_P (new_block))
371 && ((MEMORY_REF (new_block, 0)) == h1)
372 && ((MEMORY_REF (new_block, 1)) == h2)))
373 {
374 outf_fatal ("\nThe world image being restored is incompatible"
375 " with this microcode.\n");
376 Microcode_Termination (TERM_COMPILER_DEATH);
377 /*NOTREACHED*/
378 }
379
380 nbp = (OBJECT_ADDRESS (new_block));
381 compiler_utilities = new_block;
382 return_to_interpreter = (MAKE_CC_ENTRY (trampoline_entry_addr (nbp, 0)));
383 reflect_to_interface = (MAKE_CC_ENTRY (trampoline_entry_addr (nbp, 1)));
384 SET_CLOSURE_FREE (0);
385 SET_CLOSURE_SPACE (0);
386 SET_REFLECTOR (reflect_to_interface);
387
388 ASM_RESET_HOOK ();
389 }
390
391 /* Main compiled-code entry points */
392
393 #define DEFINE_SCHEME_ENTRY(pname) long pname (void)
394
DEFINE_SCHEME_ENTRY(enter_compiled_expression)395 DEFINE_SCHEME_ENTRY (enter_compiled_expression)
396 {
397 SCHEME_OBJECT entry = GET_EXP;
398 {
399 cc_entry_type_t cet;
400 if (read_cc_entry_type ((&cet), (CC_ENTRY_ADDRESS (entry))))
401 return (ERR_COMPILED_CODE_ERROR);
402 if (cet.marker != CET_EXPRESSION)
403 {
404 /* evaluate to self */
405 SET_VAL (entry);
406 return (PRIM_DONE);
407 }
408 }
409 guarantee_cc_return (0);
410 JUMP_TO_CC_ENTRY (entry);
411 }
412
DEFINE_SCHEME_ENTRY(apply_compiled_procedure)413 DEFINE_SCHEME_ENTRY (apply_compiled_procedure)
414 {
415 unsigned long n_args = (POP_APPLY_FRAME_HEADER ());
416 SCHEME_OBJECT procedure = (STACK_POP ());
417 long code = (setup_compiled_invocation (procedure, n_args));
418 if (code != PRIM_DONE)
419 return (code);
420 JUMP_TO_CC_ENTRY (procedure);
421 }
422
DEFINE_SCHEME_ENTRY(return_to_compiled_code)423 DEFINE_SCHEME_ENTRY (return_to_compiled_code)
424 {
425 RESTORE_LAST_RETURN_CODE ();
426 {
427 SCHEME_OBJECT cont = (STACK_POP ());
428 {
429 cc_entry_type_t cet;
430 if ((read_cc_entry_type ((&cet), (CC_ENTRY_ADDRESS (cont))))
431 || (! ((cet.marker == CET_CONTINUATION)
432 || (cet.marker == CET_INTERNAL_CONTINUATION)
433 || (cet.marker == CET_RETURN_TO_INTERPRETER))))
434 {
435 STACK_PUSH (cont);
436 SAVE_CONT ();
437 return (ERR_INAPPLICABLE_OBJECT);
438 }
439 }
440 JUMP_TO_CC_ENTRY (cont);
441 }
442 }
443
444 void
guarantee_cc_return(unsigned long offset)445 guarantee_cc_return (unsigned long offset)
446 {
447 if (CC_ENTRY_P (STACK_REF (offset)))
448 return;
449 assert (RETURN_CODE_P (CONT_RET (offset)));
450 if (CHECK_RETURN_CODE (RC_REENTER_COMPILED_CODE, offset))
451 {
452 unsigned long lrc = (FIXNUM_TO_ULONG (CONT_EXP (offset)));
453 close_stack_gap (offset, CONTINUATION_SIZE);
454 last_return_code = (STACK_LOC (offset + lrc));
455 CHECK_LAST_RETURN_CODE ();
456 COMPILER_END_SUBPROBLEM ();
457 }
458 else
459 {
460 last_return_code = (STACK_LOC (offset));
461 CHECK_LAST_RETURN_CODE ();
462 open_stack_gap (offset, 1);
463 (STACK_REF (offset)) = return_to_interpreter;
464 }
465 }
466
467 void
guarantee_interp_return(void)468 guarantee_interp_return (void)
469 {
470 unsigned long offset = (1 + (APPLY_FRAME_SIZE ()));
471 if (RETURN_CODE_P (CONT_RET (offset)))
472 return;
473 assert (CC_ENTRY_P (STACK_REF (offset)));
474 if ((STACK_REF (offset)) == return_to_interpreter)
475 {
476 assert (RETURN_CODE_P (CONT_RET (offset + 1)));
477 close_stack_gap (offset, 1);
478 COMPILER_NEW_REDUCTION ();
479 }
480 else
481 {
482 open_stack_gap (offset, CONTINUATION_SIZE);
483 {
484 SCHEME_OBJECT * sp = stack_pointer;
485 stack_pointer = (STACK_LOC (offset + CONTINUATION_SIZE));
486 SAVE_LAST_RETURN_CODE (RC_REENTER_COMPILED_CODE);
487 stack_pointer = sp;
488 }
489 }
490 }
491
492 static void
open_stack_gap(unsigned long offset,unsigned long n_words)493 open_stack_gap (unsigned long offset, unsigned long n_words)
494 {
495 SCHEME_OBJECT * scan_from = (STACK_LOC (0));
496 SCHEME_OBJECT * scan_end = (STACK_LOC (offset));
497 SCHEME_OBJECT * scan_to = (STACK_LOC (-n_words));
498 while (scan_from != scan_end)
499 (STACK_LOCATIVE_POP (scan_to)) = (STACK_LOCATIVE_POP (scan_from));
500 stack_pointer = (STACK_LOC (-n_words));
501 }
502
503 static void
close_stack_gap(unsigned long offset,unsigned long n_words)504 close_stack_gap (unsigned long offset, unsigned long n_words)
505 {
506 SCHEME_OBJECT * scan_from = (STACK_LOC (offset));
507 SCHEME_OBJECT * scan_end = (STACK_LOC (0));
508 SCHEME_OBJECT * scan_to = (STACK_LOC (offset + n_words));
509 while (scan_from != scan_end)
510 (STACK_LOCATIVE_PUSH (scan_to)) = (STACK_LOCATIVE_PUSH (scan_from));
511 stack_pointer = (STACK_LOC (n_words));
512 }
513
514 static void
recover_from_apply_error(SCHEME_OBJECT procedure,unsigned long n_args)515 recover_from_apply_error (SCHEME_OBJECT procedure, unsigned long n_args)
516 {
517 STACK_PUSH (procedure);
518 PUSH_APPLY_FRAME_HEADER (n_args);
519 guarantee_interp_return ();
520 }
521
522 /* SCHEME_UTILITY procedures
523
524 Here's a mass of procedures that are called (via
525 'scheme_to_interface', an assembly language hook) by compiled code
526 to do various jobs. */
527
528 #define DEFINE_SCHEME_UTILITY_0(pname) \
529 void \
530 ASM_ENTRY_POINT (pname) \
531 (utility_result_t * DSU_result, \
532 unsigned long ignore1, \
533 unsigned long ignore2, \
534 unsigned long ignore3, \
535 unsigned long ignore4)
536
537 #define DEFINE_SCHEME_UTILITY_1(pname, av1) \
538 void \
539 ASM_ENTRY_POINT (pname) \
540 (utility_result_t * DSU_result, \
541 unsigned long av1##_raw, \
542 unsigned long ignore2, \
543 unsigned long ignore3, \
544 unsigned long ignore4)
545
546 #define DEFINE_SCHEME_UTILITY_2(pname, av1, av2) \
547 void \
548 ASM_ENTRY_POINT (pname) \
549 (utility_result_t * DSU_result, \
550 unsigned long av1##_raw, \
551 unsigned long av2##_raw, \
552 unsigned long ignore3, \
553 unsigned long ignore4)
554
555 #define DEFINE_SCHEME_UTILITY_3(pname, av1, av2, av3) \
556 void \
557 ASM_ENTRY_POINT (pname) \
558 (utility_result_t * DSU_result, \
559 unsigned long av1##_raw, \
560 unsigned long av2##_raw, \
561 unsigned long av3##_raw, \
562 unsigned long ignore4)
563
564 #define DEFINE_SCHEME_UTILITY_4(pname, av1, av2, av3, av4) \
565 void \
566 ASM_ENTRY_POINT (pname) \
567 (utility_result_t * DSU_result, \
568 unsigned long av1##_raw, \
569 unsigned long av2##_raw, \
570 unsigned long av3##_raw, \
571 unsigned long av4##_raw)
572
573 #define DECLARE_UTILITY_ARG(at1, av1) at1 av1 = ((at1) av1##_raw)
574
575 #define INVOKE_RETURN_ADDRESS() do \
576 { \
577 if (Free >= GET_MEMTOP) \
578 { \
579 compiler_interrupt_common (DSU_result, 0, GET_VAL); \
580 return; \
581 } \
582 RETURN_TO_SCHEME (CC_ENTRY_ADDRESS (STACK_POP ())); \
583 } while (false)
584
585 #define TAIL_CALL_1(pname, a1) do \
586 { \
587 pname (DSU_result, ((unsigned long) (a1)), 0, 0, 0); \
588 return; \
589 } while (false)
590
591 #define TAIL_CALL_2(pname, a1, a2) do \
592 { \
593 pname (DSU_result, \
594 ((unsigned long) (a1)), \
595 ((unsigned long) (a2)), \
596 0, \
597 0); \
598 return; \
599 } while (false)
600
DEFINE_SCHEME_UTILITY_2(comutil_apply,procedure,frame_size)601 DEFINE_SCHEME_UTILITY_2 (comutil_apply, procedure, frame_size)
602 {
603 DECLARE_UTILITY_ARG (SCHEME_OBJECT, procedure);
604 DECLARE_UTILITY_ARG (unsigned long, frame_size);
605
606 while (1)
607 switch (OBJECT_TYPE (procedure))
608 {
609 case TC_ENTITY:
610 {
611 SCHEME_OBJECT data = (MEMORY_REF (procedure, ENTITY_DATA));
612 if ((VECTOR_P (data))
613 && ((VECTOR_LENGTH (data)) > frame_size)
614 && ((VECTOR_REF (data, 0))
615 == (VECTOR_REF (fixed_objects, ARITY_DISPATCHER_TAG)))
616 && ((VECTOR_REF (data, frame_size)) != SHARP_F))
617 {
618 procedure = (VECTOR_REF (data, frame_size));
619 break;
620 }
621 }
622 {
623 SCHEME_OBJECT operator = (MEMORY_REF (procedure, ENTITY_OPERATOR));
624 if (!CC_ENTRY_P (operator))
625 goto handle_in_interpreter;
626 STACK_PUSH (procedure);
627 procedure = operator;
628 frame_size += 1;
629 }
630 /* fall through */
631
632 case TC_COMPILED_ENTRY:
633 {
634 long code
635 = (setup_compiled_invocation (procedure, (frame_size - 1)));
636 if (code != PRIM_DONE)
637 RETURN_TO_C (code);
638 }
639 RETURN_TO_SCHEME (CC_ENTRY_ADDRESS (procedure));
640
641 case TC_PRIMITIVE:
642 if (IMPLEMENTED_PRIMITIVE_P (procedure))
643 {
644 int arity = (PRIMITIVE_ARITY (procedure));
645 if (arity == (frame_size - 1))
646 TAIL_CALL_1 (comutil_primitive_apply, procedure);
647 else if (arity == LEXPR)
648 {
649 SET_LEXPR_ACTUALS (frame_size - 1);
650 TAIL_CALL_1 (comutil_primitive_lexpr_apply, procedure);
651 }
652 else
653 {
654 recover_from_apply_error (procedure, (frame_size - 1));
655 RETURN_TO_C (ERR_WRONG_NUMBER_OF_ARGUMENTS);
656 }
657 }
658 /* fall through */
659
660 handle_in_interpreter:
661 default:
662 {
663 recover_from_apply_error (procedure, (frame_size - 1));
664 RETURN_TO_C (PRIM_APPLY);
665 }
666 }
667 }
668
669 /* comutil_lexpr_apply is invoked to reformat the frame when compiled
670 code calls a known lexpr. The actual arguments are on the stack,
671 and it is given the number of arguments and the real entry point of
672 the procedure. */
673
DEFINE_SCHEME_UTILITY_2(comutil_lexpr_apply,address,n_args)674 DEFINE_SCHEME_UTILITY_2 (comutil_lexpr_apply, address, n_args)
675 {
676 DECLARE_UTILITY_ARG (insn_t *, address);
677 DECLARE_UTILITY_ARG (unsigned long, n_args);
678 cc_entry_type_t cet;
679
680 if (! ((!read_cc_entry_type ((&cet), address))
681 && ((cet.marker) == CET_PROCEDURE)
682 && (cet.args.for_procedure.rest_p)
683 && (n_args >= (cet.args.for_procedure.n_required))))
684 {
685 recover_from_apply_error ((MAKE_CC_ENTRY (address)), n_args);
686 RETURN_TO_C (ERR_COMPILED_CODE_ERROR);
687 }
688 {
689 long code
690 = (setup_lexpr_invocation ((MAKE_CC_ENTRY (address)),
691 n_args,
692 ((cet.args.for_procedure.n_required)
693 + (cet.args.for_procedure.n_optional))));
694 if (code != PRIM_DONE)
695 RETURN_TO_C (code);
696 }
697 RETURN_TO_SCHEME (address);
698 }
699
700 /* comutil_primitive_apply is used to invoked a C primitive. Note
701 that some C primitives (the so called interpreter hooks) will not
702 return normally, but will "longjmp" to the interpreter instead.
703 Thus the assembly language invoking this should have set up the
704 appropriate locations in case this happens. After invoking the
705 primitive, it pops the arguments off the Scheme stack, and proceeds
706 by invoking the continuation on top of the stack. */
707
DEFINE_SCHEME_UTILITY_1(comutil_primitive_apply,primitive)708 DEFINE_SCHEME_UTILITY_1 (comutil_primitive_apply, primitive)
709 {
710 DECLARE_UTILITY_ARG (SCHEME_OBJECT, primitive);
711 PRIMITIVE_APPLY (primitive);
712 POP_PRIMITIVE_FRAME (PRIMITIVE_ARITY (primitive));
713 INVOKE_RETURN_ADDRESS ();
714 }
715
716 /* comutil_primitive_lexpr_apply is like comutil_primitive_apply
717 except that it is used to invoke primitives that take an arbitrary
718 number of arguments. The number of arguments is in the
719 REGBLOCK_LEXPR_ACTUALS slot of the register block. */
720
DEFINE_SCHEME_UTILITY_1(comutil_primitive_lexpr_apply,primitive)721 DEFINE_SCHEME_UTILITY_1 (comutil_primitive_lexpr_apply, primitive)
722 {
723 DECLARE_UTILITY_ARG (SCHEME_OBJECT, primitive);
724 PRIMITIVE_APPLY (primitive);
725 POP_PRIMITIVE_FRAME (GET_LEXPR_ACTUALS);
726 INVOKE_RETURN_ADDRESS ();
727 }
728
729 /* comutil_error is used by compiled code to signal an error. It
730 expects the arguments to the error procedure to be pushed on the
731 stack, and is passed the number of arguments (+ 1). */
732
DEFINE_SCHEME_UTILITY_1(comutil_error,frame_size)733 DEFINE_SCHEME_UTILITY_1 (comutil_error, frame_size)
734 {
735 DECLARE_UTILITY_ARG (unsigned long, frame_size);
736 TAIL_CALL_2 (comutil_apply,
737 (VECTOR_REF (fixed_objects, CC_ERROR_PROCEDURE)),
738 frame_size);
739 }
740
741 /* comutil_link is used to initialize all the variable cache slots for
742 a compiled code block. It is called at load time, by the compiled
743 code itself. It assumes that the return address has been saved on
744 the stack. If an error occurs during linking, or an interrupt must
745 be processed (because of the need to GC, etc.), it backs out and
746 sets up a return code that will invoke comp_link_caches_restart
747 when the error/interrupt processing is done. */
748
DEFINE_SCHEME_UTILITY_4(comutil_link,return_addr,block_addr,constant_addr,n_sections)749 DEFINE_SCHEME_UTILITY_4 (comutil_link,
750 return_addr,
751 block_addr,
752 constant_addr,
753 n_sections)
754 {
755 DECLARE_UTILITY_ARG (insn_t *, return_addr);
756 DECLARE_UTILITY_ARG (SCHEME_OBJECT *, block_addr);
757 DECLARE_UTILITY_ARG (SCHEME_OBJECT *, constant_addr);
758 DECLARE_UTILITY_ARG (unsigned long, n_sections);
759 link_cc_state_t s;
760
761 (s.return_address) = return_addr;
762 (s.block_address) = block_addr;
763 (s.scan) = constant_addr;
764 (s.n_sections) = n_sections;
765 (s.n_linked_sections) = 0;
766
767 start_linking_cc_block ();
768 {
769 long result = (link_remaining_sections (&s));
770 end_linking_cc_block (&s);
771 if (result != PRIM_DONE)
772 RETURN_TO_C (result);
773 }
774 RETURN_TO_SCHEME (s.return_address);
775 }
776
777 /* comp_link_caches_restart is used to continue the linking process
778 started by comutil_link after the garbage collector has run. */
779
DEFINE_SCHEME_ENTRY(comp_link_caches_restart)780 DEFINE_SCHEME_ENTRY (comp_link_caches_restart)
781 {
782 link_cc_state_t s;
783 long result;
784
785 restore_link_cc_state (&s);
786 SET_ENV (cc_block_environment (MAKE_CC_BLOCK (s.block_address)));
787
788 start_linking_cc_block ();
789
790 result = (link_section (&s));
791 if (result == PRIM_DONE)
792 result = (link_remaining_sections (&s));
793
794 end_linking_cc_block (&s);
795 if (result != PRIM_DONE)
796 return (result);
797
798 ENTER_SCHEME (s.return_address);
799 }
800
801 static long
link_remaining_sections(link_cc_state_t * s)802 link_remaining_sections (link_cc_state_t * s)
803 {
804 while ((s->n_linked_sections) < (s->n_sections))
805 {
806 start_linking_section (s);
807 {
808 long result = (link_section (s));
809 if (result != PRIM_DONE)
810 return (result);
811 }
812 }
813 return (PRIM_DONE);
814 }
815
816 static void
start_linking_cc_block(void)817 start_linking_cc_block (void)
818 {
819 bool * ap = (dstack_alloc (sizeof (bool)));
820 (*ap) = linking_cc_block_p;
821 transaction_begin ();
822 transaction_record_action (tat_always, abort_linking_cc_block, ap);
823 linking_cc_block_p = 1;
824 }
825
826 static void
end_linking_cc_block(link_cc_state_t * s)827 end_linking_cc_block (link_cc_state_t * s)
828 {
829 transaction_commit ();
830 update_cache_after_link (s);
831 }
832
833 static void
abort_linking_cc_block(void * ap)834 abort_linking_cc_block (void * ap)
835 {
836 linking_cc_block_p = (* ((bool *) (ap)));
837 }
838
839 static void
update_cache_after_link(link_cc_state_t * s)840 update_cache_after_link (link_cc_state_t * s)
841 {
842 #if defined(FLUSH_I_CACHE_REGION) || defined(PUSH_D_CACHE_REGION)
843 SCHEME_OBJECT * addr = (s->block_address);
844 if ((cc_entry_address_to_block_address (s->return_address)) == addr)
845 #ifdef FLUSH_I_CACHE_REGION
846 FLUSH_I_CACHE_REGION (addr, (CC_BLOCK_ADDR_LENGTH (addr)));
847 #else
848 ;
849 #endif
850 else
851 #ifdef PUSH_D_CACHE_REGION
852 PUSH_D_CACHE_REGION (addr, (CC_BLOCK_ADDR_LENGTH (addr)));
853 #else
854 ;
855 #endif
856 #endif
857 }
858
859 static void
start_linking_section(link_cc_state_t * s)860 start_linking_section (link_cc_state_t * s)
861 {
862 (s->scan0) = (s->scan);
863 (s->n_linked_entries) = 0;
864 {
865 SCHEME_OBJECT header = (*(s->scan)++);
866 (s->type) = (linkage_section_type (header));
867 (s->n_entries) = (linkage_section_count (header));
868 }
869 }
870
871 static long
link_section(link_cc_state_t * s)872 link_section (link_cc_state_t * s)
873 {
874 SCHEME_OBJECT * scan1 = ((s->scan0) + 1);
875 SCHEME_OBJECT * scan = (s->scan);
876 SCHEME_OBJECT * block_address = (s->block_address);
877 unsigned long n_linked = (s->n_linked_entries);
878 unsigned long n_entries = (s->n_entries);
879 cache_handler_t * handler;
880 bool execute_p;
881 unsigned long entry_size;
882 long result = PRIM_DONE;
883 DECLARE_RELOCATION_REFERENCE (ref);
884
885 if (!link_section_handler ((s->type), (&handler), (&execute_p)))
886 {
887 result = ERR_COMPILED_CODE_ERROR;
888 goto done;
889 }
890
891 if (execute_p)
892 {
893 /* Hair: START_OPERATOR_RELOCATION requires scan to be pointing
894 to the first word after the header. Also, it might move scan
895 forward. If we are just starting the link, just use scan as
896 the argument and let it be changed. If we are restarting, we
897 need to use use a temporary variable that points to the right
898 place. */
899 if (n_linked == 0)
900 START_OPERATOR_RELOCATION (scan, ref);
901 else
902 START_OPERATOR_RELOCATION (scan1, ref);
903 entry_size = UUO_LINK_SIZE;
904 }
905 else
906 entry_size = 1;
907
908 while (n_linked < n_entries)
909 {
910 result = ((*handler) ((execute_p
911 ? (read_uuo_symbol (scan))
912 : (*scan)),
913 (MAKE_CC_BLOCK (block_address)),
914 (scan - block_address)));
915 if (result != PRIM_DONE)
916 break;
917 scan += entry_size;
918 n_linked += 1;
919 }
920
921 done:
922 /* If we failed on the first entry, back scan up to where it was
923 before START_OPERATOR_RELOCATION possibly changed it. */
924 (s->scan) = ((n_linked == 0) ? scan1 : scan);
925 (s->n_linked_entries) = n_linked;
926 (* (s->scan0)) = (make_linkage_section_marker ((s->type), n_linked));
927 if (result == PRIM_DONE)
928 (s->n_linked_sections) += 1;
929 else
930 back_out_of_link_section (s);
931 return (result);
932 }
933
934 static bool
link_section_handler(linkage_section_type_t type,cache_handler_t ** handler_r,bool * execute_p_r)935 link_section_handler (linkage_section_type_t type,
936 cache_handler_t ** handler_r,
937 bool * execute_p_r)
938 {
939 switch (type)
940 {
941 case LINKAGE_SECTION_TYPE_OPERATOR:
942 (*handler_r) = compiler_cache_operator;
943 (*execute_p_r) = true;
944 return (true);
945
946 case LINKAGE_SECTION_TYPE_GLOBAL_OPERATOR:
947 (*handler_r) = compiler_cache_global_operator;
948 (*execute_p_r) = true;
949 return (true);
950
951 case LINKAGE_SECTION_TYPE_REFERENCE:
952 (*handler_r) = compiler_cache_lookup;
953 (*execute_p_r) = false;
954 return (true);
955
956 case LINKAGE_SECTION_TYPE_ASSIGNMENT:
957 (*handler_r) = compiler_cache_assignment;
958 (*execute_p_r) = false;
959 return (true);
960
961 default:
962 return (false);
963 }
964 }
965
966 static void
back_out_of_link_section(link_cc_state_t * s)967 back_out_of_link_section (link_cc_state_t * s)
968 {
969 /* Save enough state to restart. */
970 STACK_PUSH (MAKE_CC_ENTRY (s->return_address));
971 STACK_PUSH (ULONG_TO_FIXNUM ((s->n_sections) - (s->n_linked_sections)));
972 STACK_PUSH (ULONG_TO_FIXNUM ((s->scan0) - (s->block_address)));
973 STACK_PUSH (ULONG_TO_FIXNUM ((s->scan) - (s->block_address)));
974 STACK_PUSH (MAKE_CC_BLOCK (s->block_address));
975 STACK_PUSH (ULONG_TO_FIXNUM ((s->n_entries) - (s->n_linked_entries)));
976 STACK_PUSH (ULONG_TO_FIXNUM (s->n_entries));
977 SAVE_LAST_RETURN_CODE (RC_COMP_LINK_CACHES_RESTART);
978 }
979
980 static void
restore_link_cc_state(link_cc_state_t * s)981 restore_link_cc_state (link_cc_state_t * s)
982 {
983 RESTORE_LAST_RETURN_CODE ();
984 (s->n_entries) = (OBJECT_DATUM (STACK_POP ()));
985 (s->n_linked_entries) = ((s->n_entries) - (OBJECT_DATUM (STACK_POP ())));
986 (s->block_address) = (OBJECT_ADDRESS (STACK_POP ()));
987 (s->scan) = ((s->block_address) + (OBJECT_DATUM (STACK_POP ())));
988 (s->scan0) = ((s->block_address) + (OBJECT_DATUM (STACK_POP ())));
989 (s->n_sections) = (OBJECT_DATUM (STACK_POP ()));
990 (s->return_address) = (CC_ENTRY_ADDRESS (STACK_POP ()));
991
992 (s->n_linked_sections) = 0;
993 (s->type) = (linkage_section_type (* (s->scan0)));
994 }
995
996 SCHEME_OBJECT
cc_block_linkage_info(SCHEME_OBJECT block)997 cc_block_linkage_info (SCHEME_OBJECT block)
998 {
999 SCHEME_OBJECT * const_addr
1000 = (VECTOR_LOC (block, (1 + (VECTOR_LENGTH (MAKE_POINTER_OBJECT (TC_VECTOR, (VECTOR_LOC (block, 0))))))));
1001 SCHEME_OBJECT * block_end = (CC_BLOCK_END (block));
1002 unsigned long n_sections;
1003 unsigned long n_words;
1004
1005 count_linkage_sections (const_addr, block_end, (&n_sections), (&n_words));
1006 Primitive_GC_If_Needed (n_words);
1007 return (read_linkage_sections (const_addr, block_end, n_sections, n_words));
1008 }
1009
1010 static void
count_linkage_sections(SCHEME_OBJECT * const_addr,SCHEME_OBJECT * block_end,unsigned long * n_sections,unsigned long * n_words)1011 count_linkage_sections (SCHEME_OBJECT * const_addr,
1012 SCHEME_OBJECT * block_end,
1013 unsigned long * n_sections,
1014 unsigned long * n_words)
1015 {
1016 SCHEME_OBJECT * scan = const_addr;
1017 (*n_sections) = 0;
1018 (*n_words) = 1;
1019 while (unlinked_section_start_p (scan, block_end))
1020 {
1021 SCHEME_OBJECT h = (*scan++);
1022 unsigned long count = (linkage_section_count (h));
1023 (*n_sections) += 1;
1024 /* One word for sections vector, one word for vector header,
1025 one word for type, rest for names. */
1026 (*n_words) += (3 + count);
1027 scan +=
1028 ((section_execute_p (h))
1029 ? (OPERATOR_RELOCATION_OFFSET + (count * UUO_LINK_SIZE))
1030 : count);
1031 }
1032 }
1033
1034 static SCHEME_OBJECT
read_linkage_sections(SCHEME_OBJECT * const_addr,SCHEME_OBJECT * block_end,unsigned long n_sections,unsigned long n_words)1035 read_linkage_sections (SCHEME_OBJECT * const_addr,
1036 SCHEME_OBJECT * block_end,
1037 unsigned long n_sections,
1038 unsigned long n_words)
1039 {
1040 SCHEME_OBJECT * scan = const_addr;
1041 SCHEME_OBJECT sections = (make_vector (n_sections, SHARP_F, false));
1042 SCHEME_OBJECT * sp = (VECTOR_LOC (sections, 0));
1043 SCHEME_OBJECT * spe = (VECTOR_LOC (sections, (VECTOR_LENGTH (sections))));
1044 while (sp < spe)
1045 {
1046 SCHEME_OBJECT h = (*scan++);
1047 SCHEME_OBJECT section
1048 = (make_vector ((1 + (linkage_section_count (h))), SHARP_F, false));
1049 SCHEME_OBJECT * p = (VECTOR_LOC (section, 0));
1050 SCHEME_OBJECT * pe = (VECTOR_LOC (section, (VECTOR_LENGTH (section))));
1051
1052 (*p++) = (ULONG_TO_FIXNUM ((unsigned long) (linkage_section_type (h))));
1053 if (section_execute_p (h))
1054 {
1055 scan += OPERATOR_RELOCATION_OFFSET;
1056 while (p < pe)
1057 {
1058 (*p++) = (read_uuo_symbol (scan));
1059 scan += UUO_LINK_SIZE;
1060 }
1061 }
1062 else
1063 while (p < pe)
1064 (*p++) = (*scan++);
1065
1066 (*sp++) = section;
1067 }
1068
1069 return (sections);
1070 }
1071
1072 static bool
section_execute_p(SCHEME_OBJECT h)1073 section_execute_p (SCHEME_OBJECT h)
1074 {
1075 linkage_section_type_t type = (linkage_section_type (h));
1076 return
1077 ((type == LINKAGE_SECTION_TYPE_OPERATOR)
1078 || (type == LINKAGE_SECTION_TYPE_GLOBAL_OPERATOR));
1079 }
1080
1081 /* Interrupt/GC from Scheme
1082
1083 These procedures are called from compiled code at the start
1084 (respectively) of a procedure or continuation if an interrupt has
1085 been detected. They must not be called unless there is an
1086 interrupt to be serviced.
1087
1088 The code that handles RC_COMP_INTERRUPT_RESTART in "interp.c" will
1089 return control to comp_interrupt_restart (below). This assumes
1090 that the Scheme stack contains a compiled code entry address (start
1091 of continuation, procedure, etc.). The GET_EXP saved with the
1092 continuation is a piece of state that will be returned to
1093 GET_VAL and GET_ENV (both) upon return. */
1094
DEFINE_SCHEME_UTILITY_0(comutil_interrupt_closure)1095 DEFINE_SCHEME_UTILITY_0 (comutil_interrupt_closure)
1096 {
1097 compiler_interrupt_common (DSU_result, 0, SHARP_F);
1098 }
1099
DEFINE_SCHEME_UTILITY_2(comutil_interrupt_dlink,entry_point,dlink)1100 DEFINE_SCHEME_UTILITY_2 (comutil_interrupt_dlink, entry_point, dlink)
1101 {
1102 DECLARE_UTILITY_ARG (insn_t *, entry_point);
1103 DECLARE_UTILITY_ARG (SCHEME_OBJECT *, dlink);
1104 compiler_interrupt_common (DSU_result,
1105 entry_point,
1106 (MAKE_CC_STACK_ENV (dlink)));
1107 }
1108
DEFINE_SCHEME_UTILITY_1(comutil_interrupt_procedure,entry_point)1109 DEFINE_SCHEME_UTILITY_1 (comutil_interrupt_procedure, entry_point)
1110 {
1111 DECLARE_UTILITY_ARG (insn_t *, entry_point);
1112 compiler_interrupt_common (DSU_result, entry_point, SHARP_F);
1113 }
1114
1115 /* GET_VAL has live data, and there is no entry address on the stack */
1116
DEFINE_SCHEME_UTILITY_1(comutil_interrupt_continuation,return_addr)1117 DEFINE_SCHEME_UTILITY_1 (comutil_interrupt_continuation, return_addr)
1118 {
1119 DECLARE_UTILITY_ARG (insn_t *, return_addr);
1120 compiler_interrupt_common (DSU_result, return_addr, GET_VAL);
1121 }
1122
1123 /* GET_ENV has live data; no entry point on the stack */
1124
DEFINE_SCHEME_UTILITY_1(comutil_interrupt_ic_procedure,entry_point)1125 DEFINE_SCHEME_UTILITY_1 (comutil_interrupt_ic_procedure, entry_point)
1126 {
1127 DECLARE_UTILITY_ARG (insn_t *, entry_point);
1128 compiler_interrupt_common (DSU_result, entry_point, GET_ENV);
1129 }
1130
DEFINE_SCHEME_UTILITY_0(comutil_interrupt_continuation_2)1131 DEFINE_SCHEME_UTILITY_0 (comutil_interrupt_continuation_2)
1132 {
1133 compiler_interrupt_common (DSU_result, 0, GET_VAL);
1134 }
1135
1136 void
compiler_interrupt_common(utility_result_t * DSU_result,insn_t * address,SCHEME_OBJECT state)1137 compiler_interrupt_common (utility_result_t * DSU_result,
1138 insn_t * address,
1139 SCHEME_OBJECT state)
1140 {
1141 if (!FREE_OK_P (Free))
1142 REQUEST_GC (Free - heap_alloc_limit);
1143 STACK_CHECK (0);
1144 if (address != 0)
1145 STACK_PUSH (MAKE_CC_ENTRY (address));
1146 STACK_PUSH (state);
1147 SAVE_LAST_RETURN_CODE (RC_COMP_INTERRUPT_RESTART);
1148 RETURN_TO_C (PRIM_INTERRUPT);
1149 }
1150
DEFINE_SCHEME_ENTRY(comp_interrupt_restart)1151 DEFINE_SCHEME_ENTRY (comp_interrupt_restart)
1152 {
1153 RESTORE_LAST_RETURN_CODE ();
1154 {
1155 SCHEME_OBJECT state = (STACK_POP ());
1156 SET_ENV (state);
1157 SET_VAL (state);
1158 }
1159 JUMP_TO_CC_ENTRY (STACK_POP ());
1160 }
1161
1162 /* Other traps */
1163
1164 /* Assigning a variable that contains a trap. */
1165
DEFINE_SCHEME_UTILITY_3(comutil_assignment_trap,ret_addr,cache_addr,new_val)1166 DEFINE_SCHEME_UTILITY_3 (comutil_assignment_trap,
1167 ret_addr, cache_addr, new_val)
1168 {
1169 DECLARE_UTILITY_ARG (insn_t *, ret_addr);
1170 DECLARE_UTILITY_ARG (SCHEME_OBJECT *, cache_addr);
1171 DECLARE_UTILITY_ARG (SCHEME_OBJECT, new_val);
1172 SCHEME_OBJECT cache = (MAKE_POINTER_OBJECT (CACHE_TYPE, cache_addr));
1173 SCHEME_OBJECT old_val;
1174 long code = (compiler_assignment_trap (cache, new_val, (&old_val)));
1175 if (code != PRIM_DONE)
1176 {
1177 SCHEME_OBJECT sra = (MAKE_CC_ENTRY (ret_addr));
1178 SCHEME_OBJECT block = (cc_entry_to_block (sra));
1179 STACK_PUSH (sra);
1180 STACK_PUSH (new_val);
1181 STACK_PUSH (cc_block_environment (block));
1182 STACK_PUSH
1183 (compiler_var_error (cache, block, CACHE_REFERENCES_ASSIGNMENT));
1184 SAVE_LAST_RETURN_CODE (RC_COMP_ASSIGNMENT_TRAP_RESTART);
1185 RETURN_TO_C (code);
1186 }
1187 SET_VAL (old_val);
1188 RETURN_TO_SCHEME (ret_addr);
1189 }
1190
DEFINE_SCHEME_ENTRY(comp_assignment_trap_restart)1191 DEFINE_SCHEME_ENTRY (comp_assignment_trap_restart)
1192 {
1193 RESTORE_LAST_RETURN_CODE ();
1194 {
1195 SCHEME_OBJECT name = (STACK_POP ());
1196 SCHEME_OBJECT environment = (STACK_POP ());
1197 SCHEME_OBJECT new_val = (STACK_POP ());
1198 SCHEME_OBJECT old_val;
1199 long code = (assign_variable (environment, name, new_val, (&old_val)));
1200 if (code != PRIM_DONE)
1201 {
1202 STACK_PUSH (new_val);
1203 STACK_PUSH (environment);
1204 STACK_PUSH (name);
1205 SAVE_LAST_RETURN_CODE (RC_COMP_ASSIGNMENT_TRAP_RESTART);
1206 return (code);
1207 }
1208 SET_VAL (old_val);
1209 JUMP_TO_CC_ENTRY (STACK_POP ());
1210 }
1211 }
1212
DEFINE_SCHEME_UTILITY_3(comutil_cache_lookup_apply,cache_addr,block_addr,frame_size)1213 DEFINE_SCHEME_UTILITY_3 (comutil_cache_lookup_apply,
1214 cache_addr, block_addr, frame_size)
1215 {
1216 DECLARE_UTILITY_ARG (SCHEME_OBJECT *, cache_addr);
1217 DECLARE_UTILITY_ARG (SCHEME_OBJECT *, block_addr);
1218 DECLARE_UTILITY_ARG (unsigned long, frame_size);
1219 SCHEME_OBJECT cache = (MAKE_POINTER_OBJECT (CACHE_TYPE, cache_addr));
1220 SCHEME_OBJECT value;
1221 long code = (compiler_lookup_trap (cache, (&value)));
1222 if (code != PRIM_DONE)
1223 {
1224 SCHEME_OBJECT block = (MAKE_CC_BLOCK (block_addr));
1225 STACK_PUSH (block);
1226 STACK_PUSH (ULONG_TO_FIXNUM (frame_size));
1227 STACK_PUSH (cc_block_environment (block));
1228 STACK_PUSH
1229 (compiler_var_error (cache, block, CACHE_REFERENCES_OPERATOR));
1230 SAVE_LAST_RETURN_CODE (RC_COMP_CACHE_REF_APPLY_RESTART);
1231 RETURN_TO_C (code);
1232 }
1233 TAIL_CALL_2 (comutil_apply, value, frame_size);
1234 }
1235
DEFINE_SCHEME_ENTRY(comp_cache_lookup_apply_restart)1236 DEFINE_SCHEME_ENTRY (comp_cache_lookup_apply_restart)
1237 {
1238 RESTORE_LAST_RETURN_CODE ();
1239 {
1240 SCHEME_OBJECT name = (STACK_POP ());
1241 SCHEME_OBJECT environment = (STACK_POP ());
1242 SCHEME_OBJECT frame_size = (STACK_POP ());
1243 SCHEME_OBJECT block = (STACK_POP ());
1244 SCHEME_OBJECT value;
1245 {
1246 long code = (lookup_variable (environment, name, (&value)));
1247 if (code != PRIM_DONE)
1248 {
1249 STACK_PUSH (block);
1250 STACK_PUSH (frame_size);
1251 STACK_PUSH (environment);
1252 STACK_PUSH (name);
1253 SAVE_LAST_RETURN_CODE (RC_COMP_CACHE_REF_APPLY_RESTART);
1254 return (code);
1255 }
1256 }
1257 STACK_PUSH (value);
1258 PUSH_APPLY_FRAME_HEADER ((FIXNUM_TO_ULONG (frame_size)) - 1);
1259 if (CC_ENTRY_P (value))
1260 return (apply_compiled_procedure ());
1261 guarantee_interp_return ();
1262 return (PRIM_APPLY);
1263 }
1264 }
1265
1266 /* Variable reference traps:
1267 Reference to a free variable that contains a reference trap. */
1268
DEFINE_SCHEME_UTILITY_2(comutil_lookup_trap,ret_addr,cache_addr)1269 DEFINE_SCHEME_UTILITY_2 (comutil_lookup_trap, ret_addr, cache_addr)
1270 {
1271 DECLARE_UTILITY_ARG (insn_t *, ret_addr);
1272 DECLARE_UTILITY_ARG (SCHEME_OBJECT *, cache_addr);
1273 SCHEME_OBJECT cache = (MAKE_POINTER_OBJECT (CACHE_TYPE, cache_addr));
1274 SCHEME_OBJECT val;
1275 long code = (compiler_lookup_trap (cache, (&val)));
1276 if (code != PRIM_DONE)
1277 {
1278 SCHEME_OBJECT sra = (MAKE_CC_ENTRY (ret_addr));
1279 SCHEME_OBJECT block = (cc_entry_to_block (sra));
1280 STACK_PUSH (sra);
1281 STACK_PUSH (cc_block_environment (block));
1282 STACK_PUSH (compiler_var_error (cache, block, CACHE_REFERENCES_LOOKUP));
1283 SAVE_LAST_RETURN_CODE (RC_COMP_LOOKUP_TRAP_RESTART);
1284 RETURN_TO_C (code);
1285 }
1286 SET_VAL (val);
1287 RETURN_TO_SCHEME (ret_addr);
1288 }
1289
DEFINE_SCHEME_ENTRY(comp_lookup_trap_restart)1290 DEFINE_SCHEME_ENTRY (comp_lookup_trap_restart)
1291 {
1292 RESTORE_LAST_RETURN_CODE ();
1293 {
1294 SCHEME_OBJECT name = GET_EXP;
1295 SCHEME_OBJECT environment = (STACK_POP ());
1296 SCHEME_OBJECT val;
1297 long code = (lookup_variable (environment, name, (&val)));
1298 if (code != PRIM_DONE)
1299 {
1300 STACK_PUSH (environment);
1301 STACK_PUSH (name);
1302 SAVE_LAST_RETURN_CODE (RC_COMP_LOOKUP_TRAP_RESTART);
1303 return (code);
1304 }
1305 SET_VAL (val);
1306 JUMP_TO_CC_ENTRY (STACK_POP ());
1307 }
1308 }
1309
DEFINE_SCHEME_UTILITY_2(comutil_safe_lookup_trap,ret_addr,cache_addr)1310 DEFINE_SCHEME_UTILITY_2 (comutil_safe_lookup_trap, ret_addr, cache_addr)
1311 {
1312 DECLARE_UTILITY_ARG (insn_t *, ret_addr);
1313 DECLARE_UTILITY_ARG (SCHEME_OBJECT *, cache_addr);
1314 SCHEME_OBJECT cache = (MAKE_POINTER_OBJECT (CACHE_TYPE, cache_addr));
1315 SCHEME_OBJECT val;
1316 long code = (compiler_safe_lookup_trap (cache, (&val)));
1317 if (code != PRIM_DONE)
1318 {
1319 SCHEME_OBJECT sra = (MAKE_CC_ENTRY (ret_addr));
1320 SCHEME_OBJECT block = (cc_entry_to_block (sra));
1321 STACK_PUSH (sra);
1322 STACK_PUSH (cc_block_environment (block));
1323 STACK_PUSH (compiler_var_error (cache, block, CACHE_REFERENCES_LOOKUP));
1324 SAVE_LAST_RETURN_CODE (RC_COMP_SAFE_REF_TRAP_RESTART);
1325 RETURN_TO_C (code);
1326 }
1327 SET_VAL (val);
1328 RETURN_TO_SCHEME (ret_addr);
1329 }
1330
DEFINE_SCHEME_ENTRY(comp_safe_lookup_trap_restart)1331 DEFINE_SCHEME_ENTRY (comp_safe_lookup_trap_restart)
1332 {
1333 RESTORE_LAST_RETURN_CODE ();
1334 {
1335 SCHEME_OBJECT name = GET_EXP;
1336 SCHEME_OBJECT environment = (STACK_POP ());
1337 SCHEME_OBJECT val;
1338 long code = (safe_lookup_variable (environment, name, (&val)));
1339 if (code != PRIM_DONE)
1340 {
1341 STACK_PUSH (environment);
1342 STACK_PUSH (name);
1343 SAVE_LAST_RETURN_CODE (RC_COMP_SAFE_REF_TRAP_RESTART);
1344 return (code);
1345 }
1346 SET_VAL (val);
1347 JUMP_TO_CC_ENTRY (STACK_POP ());
1348 }
1349 }
1350
DEFINE_SCHEME_UTILITY_2(comutil_unassigned_p_trap,ret_addr,cache_addr)1351 DEFINE_SCHEME_UTILITY_2 (comutil_unassigned_p_trap, ret_addr, cache_addr)
1352 {
1353 DECLARE_UTILITY_ARG (insn_t *, ret_addr);
1354 DECLARE_UTILITY_ARG (SCHEME_OBJECT *, cache_addr);
1355 SCHEME_OBJECT cache = (MAKE_POINTER_OBJECT (CACHE_TYPE, cache_addr));
1356 SCHEME_OBJECT val;
1357 long code = (compiler_unassigned_p_trap (cache, (&val)));
1358 if (code != PRIM_DONE)
1359 {
1360 SCHEME_OBJECT sra = (MAKE_CC_ENTRY (ret_addr));
1361 SCHEME_OBJECT block = (cc_entry_to_block (sra));
1362 STACK_PUSH (sra);
1363 STACK_PUSH (cc_block_environment (block));
1364 STACK_PUSH (compiler_var_error (cache, block, CACHE_REFERENCES_LOOKUP));
1365 SAVE_LAST_RETURN_CODE (RC_COMP_UNASSIGNED_TRAP_RESTART);
1366 RETURN_TO_C (code);
1367 }
1368 SET_VAL (val);
1369 RETURN_TO_SCHEME (ret_addr);
1370 }
1371
DEFINE_SCHEME_ENTRY(comp_unassigned_p_trap_restart)1372 DEFINE_SCHEME_ENTRY (comp_unassigned_p_trap_restart)
1373 {
1374 RESTORE_LAST_RETURN_CODE ();
1375 {
1376 SCHEME_OBJECT name = GET_EXP;
1377 SCHEME_OBJECT environment = (STACK_POP ());
1378 SCHEME_OBJECT val;
1379 long code = (variable_unassigned_p (environment, name, (&val)));
1380 if (code != PRIM_DONE)
1381 {
1382 STACK_PUSH (environment);
1383 STACK_PUSH (name);
1384 SAVE_LAST_RETURN_CODE (RC_COMP_UNASSIGNED_TRAP_RESTART);
1385 return (code);
1386 }
1387 SET_VAL (val);
1388 JUMP_TO_CC_ENTRY (STACK_POP ());
1389 }
1390 }
1391
1392 /* Numeric routines
1393
1394 Invoke the arithmetic primitive in the fixed objects vector. The
1395 Scheme arguments are expected on the Scheme stack. */
1396
1397 #define COMPILER_ARITH_PRIM(name, fobj_index, arity) \
1398 DEFINE_SCHEME_UTILITY_0 (name) \
1399 { \
1400 TAIL_CALL_2 \
1401 (comutil_apply, (VECTOR_REF (fixed_objects, fobj_index)), (arity)); \
1402 }
1403
1404 COMPILER_ARITH_PRIM (comutil_decrement, GENERIC_TRAMPOLINE_PREDECESSOR, 2)
1405 COMPILER_ARITH_PRIM (comutil_divide, GENERIC_TRAMPOLINE_DIVIDE, 3)
1406 COMPILER_ARITH_PRIM (comutil_equal, GENERIC_TRAMPOLINE_EQUAL_P, 3)
1407 COMPILER_ARITH_PRIM (comutil_greater, GENERIC_TRAMPOLINE_GREATER_P, 3)
1408 COMPILER_ARITH_PRIM (comutil_increment, GENERIC_TRAMPOLINE_SUCCESSOR, 2)
1409 COMPILER_ARITH_PRIM (comutil_less, GENERIC_TRAMPOLINE_LESS_P, 3)
1410 COMPILER_ARITH_PRIM (comutil_minus, GENERIC_TRAMPOLINE_SUBTRACT, 3)
1411 COMPILER_ARITH_PRIM (comutil_modulo, GENERIC_TRAMPOLINE_MODULO, 3)
1412 COMPILER_ARITH_PRIM (comutil_multiply, GENERIC_TRAMPOLINE_MULTIPLY, 3)
1413 COMPILER_ARITH_PRIM (comutil_negative, GENERIC_TRAMPOLINE_NEGATIVE_P, 2)
1414 COMPILER_ARITH_PRIM (comutil_plus, GENERIC_TRAMPOLINE_ADD, 3)
1415 COMPILER_ARITH_PRIM (comutil_positive, GENERIC_TRAMPOLINE_POSITIVE_P, 2)
1416 COMPILER_ARITH_PRIM (comutil_quotient, GENERIC_TRAMPOLINE_QUOTIENT, 3)
1417 COMPILER_ARITH_PRIM (comutil_remainder, GENERIC_TRAMPOLINE_REMAINDER, 3)
1418 COMPILER_ARITH_PRIM (comutil_zero, GENERIC_TRAMPOLINE_ZERO_P, 2)
1419
DEFINE_SCHEME_UTILITY_2(comutil_primitive_error,ret_addr,primitive)1420 DEFINE_SCHEME_UTILITY_2 (comutil_primitive_error, ret_addr, primitive)
1421 {
1422 DECLARE_UTILITY_ARG (insn_t *, ret_addr);
1423 DECLARE_UTILITY_ARG (SCHEME_OBJECT, primitive);
1424 STACK_PUSH (MAKE_CC_ENTRY (ret_addr));
1425 STACK_PUSH (primitive);
1426 SAVE_LAST_RETURN_CODE (RC_COMP_ERROR_RESTART);
1427 RETURN_TO_C (ERR_COMPILED_CODE_ERROR);
1428 }
1429
DEFINE_SCHEME_ENTRY(comp_error_restart)1430 DEFINE_SCHEME_ENTRY (comp_error_restart)
1431 {
1432 RESTORE_LAST_RETURN_CODE ();
1433 (void) STACK_POP (); /* primitive */
1434 JUMP_TO_CC_ENTRY (STACK_POP ());
1435 }
1436
1437 void
apply_compiled_from_primitive(unsigned long n_args,SCHEME_OBJECT procedure)1438 apply_compiled_from_primitive (unsigned long n_args, SCHEME_OBJECT procedure)
1439 {
1440 while ((OBJECT_TYPE (procedure)) == TC_ENTITY)
1441 {
1442 {
1443 unsigned long frame_size = (n_args + 1);
1444 SCHEME_OBJECT data = (MEMORY_REF (procedure, ENTITY_DATA));
1445 if ((VECTOR_P (data))
1446 && (frame_size < (VECTOR_LENGTH (data)))
1447 && (CC_ENTRY_P (VECTOR_REF (data, frame_size)))
1448 && ((VECTOR_REF (data, 0))
1449 == (VECTOR_REF (fixed_objects, ARITY_DISPATCHER_TAG))))
1450 {
1451 procedure = (VECTOR_REF (data, frame_size));
1452 continue;
1453 }
1454 }
1455 {
1456 SCHEME_OBJECT operator = (MEMORY_REF (procedure, ENTITY_OPERATOR));
1457 if (CC_ENTRY_P (operator))
1458 {
1459 STACK_PUSH (procedure);
1460 n_args += 1;
1461 procedure = operator;
1462 }
1463 }
1464 break;
1465 }
1466
1467 if (CC_ENTRY_P (procedure))
1468 setup_compiled_invocation_from_primitive (procedure, n_args);
1469 else
1470 {
1471 STACK_PUSH (procedure);
1472 PUSH_APPLY_FRAME_HEADER (n_args);
1473 PUSH_REFLECTION (REFLECT_CODE_INTERNAL_APPLY);
1474 }
1475 }
1476
1477 void
compiled_with_interrupt_mask(unsigned long old_mask,SCHEME_OBJECT receiver,unsigned long new_mask)1478 compiled_with_interrupt_mask (unsigned long old_mask,
1479 SCHEME_OBJECT receiver,
1480 unsigned long new_mask)
1481 {
1482 STACK_PUSH (ULONG_TO_FIXNUM (old_mask));
1483 PUSH_REFLECTION (REFLECT_CODE_RESTORE_INTERRUPT_MASK);
1484 STACK_PUSH (ULONG_TO_FIXNUM (new_mask));
1485 setup_compiled_invocation_from_primitive (receiver, 1);
1486 }
1487
1488 void
compiled_with_stack_marker(SCHEME_OBJECT thunk)1489 compiled_with_stack_marker (SCHEME_OBJECT thunk)
1490 {
1491 PUSH_REFLECTION (REFLECT_CODE_STACK_MARKER);
1492 setup_compiled_invocation_from_primitive (thunk, 0);
1493 }
1494
1495 static void
setup_compiled_invocation_from_primitive(SCHEME_OBJECT procedure,unsigned long n_args)1496 setup_compiled_invocation_from_primitive (SCHEME_OBJECT procedure,
1497 unsigned long n_args)
1498 {
1499 long code = (setup_compiled_invocation (procedure, n_args));
1500 if (code != PRIM_DONE)
1501 {
1502 if (code != PRIM_APPLY_INTERRUPT)
1503 {
1504 prim_apply_error_code = code;
1505 code = PRIM_APPLY_ERROR;
1506 }
1507 PRIMITIVE_ABORT (code);
1508 }
1509 /* Pun: procedure is being invoked as a return address. Assumes
1510 that the primitive is being called from compiled code. */
1511 STACK_PUSH (procedure);
1512 }
1513
1514 /* Adjust the stack frame for applying a compiled procedure. Returns
1515 PRIM_DONE when successful, otherwise sets up the call frame for
1516 application by the interpreter and returns the appropriate code. */
1517
1518 static long
setup_compiled_invocation(SCHEME_OBJECT procedure,unsigned long n_args)1519 setup_compiled_invocation (SCHEME_OBJECT procedure, unsigned long n_args)
1520 {
1521 cc_entry_type_t cet;
1522 unsigned long n_min;
1523 unsigned long n_max;
1524
1525 if (read_cc_entry_type ((&cet), (CC_ENTRY_ADDRESS (procedure))))
1526 {
1527 recover_from_apply_error (procedure, n_args);
1528 return (ERR_COMPILED_CODE_ERROR);
1529 }
1530 if ((cet.marker) != CET_PROCEDURE)
1531 {
1532 recover_from_apply_error (procedure, n_args);
1533 return (ERR_INAPPLICABLE_OBJECT);
1534 }
1535 n_min = (cet.args.for_procedure.n_required);
1536 if (n_args < n_min)
1537 {
1538 recover_from_apply_error (procedure, n_args);
1539 return (ERR_WRONG_NUMBER_OF_ARGUMENTS);
1540 }
1541 n_max = (n_min + (cet.args.for_procedure.n_optional));
1542 if (cet.args.for_procedure.rest_p)
1543 return (setup_lexpr_invocation (procedure, n_args, n_max));
1544 if (n_args == n_max)
1545 return (PRIM_DONE);
1546 if (n_args > n_max)
1547 {
1548 recover_from_apply_error (procedure, n_args);
1549 return (ERR_WRONG_NUMBER_OF_ARGUMENTS);
1550 }
1551 if (open_gap (n_args, n_max))
1552 {
1553 recover_from_apply_error (procedure, n_args);
1554 return (PRIM_APPLY_INTERRUPT);
1555 }
1556 return (PRIM_DONE);
1557 }
1558
1559 static long
setup_lexpr_invocation(SCHEME_OBJECT procedure,unsigned long n_args,unsigned long n_max)1560 setup_lexpr_invocation (SCHEME_OBJECT procedure,
1561 unsigned long n_args,
1562 unsigned long n_max)
1563 {
1564 if (n_args <= n_max)
1565 {
1566 if (open_gap (n_args, (n_max + 1)))
1567 {
1568 recover_from_apply_error (procedure, n_args);
1569 return (PRIM_APPLY_INTERRUPT);
1570 }
1571 (STACK_REF (n_max)) = EMPTY_LIST;
1572 return (PRIM_DONE);
1573 }
1574 {
1575 unsigned long n_words = ((n_args - n_max) * 2);
1576 if (GC_NEEDED_P (n_words))
1577 {
1578 REQUEST_GC (n_words);
1579 recover_from_apply_error (procedure, n_args);
1580 return (PRIM_APPLY_INTERRUPT);
1581 }
1582 }
1583 {
1584 SCHEME_OBJECT rest_arg = (MAKE_POINTER_OBJECT (TC_LIST, Free));
1585 SCHEME_OBJECT * p1 = (STACK_LOC (n_max));
1586 {
1587 unsigned long i;
1588 for (i = n_max; (i < n_args); i += 1)
1589 {
1590 (Free[0]) = (STACK_LOCATIVE_POP (p1));
1591 (Free[1]) = (MAKE_POINTER_OBJECT (TC_LIST, (Free + 2)));
1592 Free += 2;
1593 }
1594 }
1595 (Free[-1]) = EMPTY_LIST;
1596 (STACK_LOCATIVE_PUSH (p1)) = rest_arg;
1597 {
1598 SCHEME_OBJECT * p2 = (STACK_LOC (n_max));
1599 unsigned long i;
1600 for (i = 0; (i < n_max); i += 1)
1601 (STACK_LOCATIVE_PUSH (p1)) = (STACK_LOCATIVE_PUSH (p2));
1602 }
1603 stack_pointer = p1;
1604 }
1605 return (PRIM_DONE);
1606 }
1607
1608 static bool
open_gap(unsigned long n_args,unsigned long n_needed)1609 open_gap (unsigned long n_args, unsigned long n_needed)
1610 {
1611 unsigned long n_defaults = (n_needed - n_args);
1612
1613 STACK_CHECK (n_defaults);
1614 if (PENDING_INTERRUPTS_P)
1615 return (true);
1616
1617 open_stack_gap (n_args, n_defaults);
1618 {
1619 SCHEME_OBJECT * scan = (STACK_LOC (n_args));
1620 SCHEME_OBJECT * end = (STACK_LOC (n_needed));
1621 while (scan != end)
1622 (STACK_LOCATIVE_POP (scan)) = DEFAULT_OBJECT;
1623 }
1624 return (false);
1625 }
1626
1627 void
make_compiled_procedure_type(cc_entry_type_t * cet,unsigned int n_required,unsigned int n_optional,bool rest_p)1628 make_compiled_procedure_type (cc_entry_type_t * cet,
1629 unsigned int n_required,
1630 unsigned int n_optional,
1631 bool rest_p)
1632 {
1633 (cet->marker) = CET_PROCEDURE;
1634 (cet->args.for_procedure.n_required) = n_required;
1635 (cet->args.for_procedure.n_optional) = n_optional;
1636 (cet->args.for_procedure.rest_p) = rest_p;
1637 }
1638
1639 void
make_compiled_continuation_type(cc_entry_type_t * cet,unsigned long offset)1640 make_compiled_continuation_type (cc_entry_type_t * cet, unsigned long offset)
1641 {
1642 (cet->marker) = CET_CONTINUATION;
1643 (cet->args.for_continuation.offset) = offset;
1644 }
1645
1646 void
make_cc_entry_type(cc_entry_type_t * cet,cc_entry_type_marker_t marker)1647 make_cc_entry_type (cc_entry_type_t * cet, cc_entry_type_marker_t marker)
1648 {
1649 assert (! ((marker == CET_PROCEDURE) || (marker == CET_CONTINUATION)));
1650 (cet->marker) = marker;
1651 memset ((& (cet->args)), 0, (sizeof (cet->marker)));
1652 }
1653
1654 SCHEME_OBJECT
cc_entry_to_block(SCHEME_OBJECT entry)1655 cc_entry_to_block (SCHEME_OBJECT entry)
1656 {
1657 return (MAKE_CC_BLOCK (cc_entry_to_block_address (entry)));
1658 }
1659
1660 SCHEME_OBJECT *
cc_entry_to_block_address(SCHEME_OBJECT entry)1661 cc_entry_to_block_address (SCHEME_OBJECT entry)
1662 {
1663 return (cc_entry_address_to_block_address (CC_ENTRY_ADDRESS (entry)));
1664 }
1665
1666 SCHEME_OBJECT *
cc_entry_address_to_block_address(insn_t * entry)1667 cc_entry_address_to_block_address (insn_t * entry)
1668 {
1669 insn_t * p = entry;
1670 while (1)
1671 {
1672 cc_entry_offset_t ceo;
1673 read_cc_entry_offset ((&ceo), p);
1674 p -= (ceo.offset);
1675 if (! (ceo.continued_p))
1676 {
1677 assert ((((unsigned long) p) % (sizeof (SCHEME_OBJECT))) == 0);
1678 assert (((SCHEME_OBJECT *) entry)
1679 < (CC_BLOCK_ADDR_END ((SCHEME_OBJECT *) p)));
1680 return ((SCHEME_OBJECT *) p);
1681 }
1682 }
1683 }
1684
1685 static bool
plausible_first_cc_entry_p(insn_t * entry,insn_t * zero)1686 plausible_first_cc_entry_p (insn_t * entry, insn_t * zero)
1687 {
1688 cc_entry_type_t cet;
1689 cc_entry_offset_t ceo;
1690
1691 if (read_cc_entry_type ((&cet), entry))
1692 return (false);
1693
1694 if (read_cc_entry_offset ((&ceo), entry))
1695 return (false);
1696
1697 if ((ceo.offset) != (entry - zero))
1698 return (false);
1699
1700 return (true);
1701 }
1702
1703 int
plausible_cc_block_p(SCHEME_OBJECT * block)1704 plausible_cc_block_p (SCHEME_OBJECT * block)
1705 {
1706 insn_t * zero = ((insn_t *) block);
1707 insn_t * entry = (((insn_t *) (block + 2)) + CC_ENTRY_HEADER_SIZE);
1708
1709 if (!plausible_first_cc_entry_p (entry, zero))
1710 {
1711 entry += CC_ENTRY_GC_TRAP_SIZE;
1712 if (!plausible_first_cc_entry_p (entry, zero))
1713 return (0);
1714 }
1715
1716 {
1717 SCHEME_OBJECT * block_end = ((CC_BLOCK_ADDR_END (block)) - 1);
1718 return
1719 ((((HEAP_ADDRESS_P (block)) && (HEAP_ADDRESS_P (block_end)))
1720 || ((ADDRESS_IN_CONSTANT_P (block))
1721 && (ADDRESS_IN_CONSTANT_P (block_end))))
1722 && (ENVIRONMENT_P (*block_end)));
1723 }
1724 }
1725
1726 static bool
unlinked_section_start_p(SCHEME_OBJECT * mp,SCHEME_OBJECT * end)1727 unlinked_section_start_p (SCHEME_OBJECT * mp, SCHEME_OBJECT * end)
1728 {
1729 SCHEME_OBJECT marker = (*mp);
1730 return
1731 ((FIXNUM_P (marker))
1732 && (((OBJECT_DATUM (marker)) >> 16) < N_LINKAGE_SECTION_TYPES)
1733 && ((mp + 1 + ((OBJECT_DATUM (marker)) & 0xFFFFUL)) < end));
1734 }
1735
1736 linkage_section_type_t
linkage_section_type(SCHEME_OBJECT marker)1737 linkage_section_type (SCHEME_OBJECT marker)
1738 {
1739 unsigned long type = ((OBJECT_DATUM (marker)) >> 16);
1740 assert (type < N_LINKAGE_SECTION_TYPES);
1741 return ((linkage_section_type_t) type);
1742 }
1743
1744 #ifndef UUO_WORDS_TO_COUNT
1745 # define UUO_WORDS_TO_COUNT(nw) ((nw) / UUO_LINK_SIZE)
1746 # define UUO_COUNT_TO_WORDS(nc) ((nc) * UUO_LINK_SIZE)
1747 #endif
1748
1749 unsigned long
linkage_section_count(SCHEME_OBJECT marker)1750 linkage_section_count (SCHEME_OBJECT marker)
1751 {
1752 linkage_section_type_t type = (linkage_section_type (marker));
1753 unsigned long n_words = ((OBJECT_DATUM (marker)) & 0xFFFFUL);
1754 return (((type == LINKAGE_SECTION_TYPE_OPERATOR)
1755 || (type == LINKAGE_SECTION_TYPE_GLOBAL_OPERATOR))
1756 ? (UUO_WORDS_TO_COUNT (n_words))
1757 : n_words);
1758 }
1759
1760 SCHEME_OBJECT
make_linkage_section_marker(linkage_section_type_t type,unsigned long count)1761 make_linkage_section_marker (linkage_section_type_t type, unsigned long count)
1762 {
1763 unsigned long n_words;
1764
1765 assert (type < N_LINKAGE_SECTION_TYPES);
1766 n_words
1767 = (((type == LINKAGE_SECTION_TYPE_OPERATOR)
1768 || (type == LINKAGE_SECTION_TYPE_GLOBAL_OPERATOR))
1769 ? (UUO_COUNT_TO_WORDS (count))
1770 : count);
1771 assert (n_words < 0x10000);
1772 return (MAKE_OBJECT (TC_LINKAGE_SECTION,
1773 ((((unsigned long) (type)) << 16) | n_words)));
1774 }
1775
1776 /* Procedures to destructure compiled entries and closures. */
1777
1778 /* Returns the debugging information attached to 'block'. Usually
1779 this is a string that contains the filename where the debugging
1780 info is stored. */
1781
1782 SCHEME_OBJECT
cc_block_debugging_info(SCHEME_OBJECT block)1783 cc_block_debugging_info (SCHEME_OBJECT block)
1784 {
1785 return (VECTOR_REF (block, ((VECTOR_LENGTH (block)) - 2)));
1786 }
1787
1788 /* Returns the environment where 'block' was evaluated. */
1789
1790 SCHEME_OBJECT
cc_block_environment(SCHEME_OBJECT block)1791 cc_block_environment (SCHEME_OBJECT block)
1792 {
1793 return (VECTOR_REF (block, ((VECTOR_LENGTH (block)) - 1)));
1794 }
1795
1796 unsigned long
cc_entry_to_block_offset(SCHEME_OBJECT entry)1797 cc_entry_to_block_offset (SCHEME_OBJECT entry)
1798 {
1799 return ((CC_ENTRY_ADDRESS (entry))
1800 - ((insn_t *) (cc_entry_to_block_address (entry))));
1801 }
1802
1803 bool
cc_block_closure_p(SCHEME_OBJECT block)1804 cc_block_closure_p (SCHEME_OBJECT block)
1805 {
1806 return (cc_block_address_closure_p (OBJECT_ADDRESS (block)));
1807 }
1808
1809 bool
cc_entry_closure_p(SCHEME_OBJECT entry)1810 cc_entry_closure_p (SCHEME_OBJECT entry)
1811 {
1812 return (cc_block_address_closure_p (cc_entry_to_block_address (entry)));
1813 }
1814
1815 static bool
cc_block_address_closure_p(SCHEME_OBJECT * block_addr)1816 cc_block_address_closure_p (SCHEME_OBJECT * block_addr)
1817 {
1818 SCHEME_OBJECT header_word = (*block_addr);
1819 return (((OBJECT_TYPE (header_word)) == TC_MANIFEST_CLOSURE));
1820 }
1821
1822 /* Return the entry point ultimately invoked by the compiled closure
1823 'entry'. */
1824
1825 SCHEME_OBJECT
cc_closure_to_entry(SCHEME_OBJECT entry)1826 cc_closure_to_entry (SCHEME_OBJECT entry)
1827 {
1828 return (compiled_closure_entry_to_target (CC_ENTRY_ADDRESS (entry)));
1829 }
1830
1831 void
declare_compiled_code_block(SCHEME_OBJECT block)1832 declare_compiled_code_block (SCHEME_OBJECT block)
1833 {
1834 #ifdef PUSH_D_CACHE_REGION
1835 PUSH_D_CACHE_REGION ((OBJECT_ADDRESS (block)), (CC_BLOCK_END (block)));
1836 #endif
1837 }
1838
1839 void
write_variable_cache(SCHEME_OBJECT cache,SCHEME_OBJECT block,unsigned long offset)1840 write_variable_cache (SCHEME_OBJECT cache,
1841 SCHEME_OBJECT block,
1842 unsigned long offset)
1843 {
1844 MEMORY_SET (block, offset, ((SCHEME_OBJECT) (OBJECT_ADDRESS (cache))));
1845 }
1846
1847 /* Get a compiled procedure from a cached operator reference. */
1848
1849 SCHEME_OBJECT
read_uuo_link(SCHEME_OBJECT block,unsigned long offset)1850 read_uuo_link (SCHEME_OBJECT block, unsigned long offset)
1851 {
1852 return
1853 (MAKE_CC_ENTRY (read_uuo_target_no_reloc (MEMORY_LOC (block, offset))));
1854 }
1855
1856 static void
write_uuo_link(SCHEME_OBJECT target,SCHEME_OBJECT * cache_address)1857 write_uuo_link (SCHEME_OBJECT target, SCHEME_OBJECT * cache_address)
1858 {
1859 write_uuo_target ((CC_ENTRY_ADDRESS (target)), cache_address);
1860 #ifdef FLUSH_I_CACHE_REGION
1861 if (!linking_cc_block_p)
1862 {
1863 /* The linker will flush the whole region afterwards. */
1864 FLUSH_I_CACHE_REGION (cache_address, UUO_LINK_SIZE);
1865 }
1866 #endif
1867 }
1868
1869 SCHEME_OBJECT *
compiled_closure_objects(SCHEME_OBJECT * block)1870 compiled_closure_objects (SCHEME_OBJECT * block)
1871 {
1872 insn_t * start = (compiled_closure_start (block));
1873 unsigned long count = (compiled_closure_count (block));
1874
1875 /* Skip to end of entries. */
1876 while (count > 0)
1877 {
1878 start = (compiled_closure_next (start));
1879 count -= 1;
1880 }
1881
1882 /* Skip to first object. */
1883 return (skip_compiled_closure_padding (start));
1884 }
1885
1886 bool
decode_old_style_format_word(cc_entry_type_t * cet,uint16_t fw)1887 decode_old_style_format_word (cc_entry_type_t * cet, uint16_t fw)
1888 {
1889 uint16_t low = (fw & 0x00FF);
1890 uint16_t high = ((fw & 0xFF00) >> 8);
1891 bool rest_p = false;
1892
1893 if (high < 0x80)
1894 {
1895 if ((high == 0x00)
1896 || (low == 0x00)
1897 || (low == 0x80))
1898 return (true);
1899 if (low > 0x80)
1900 {
1901 low = (0xFF - low);
1902 rest_p = true;
1903 }
1904 if (! (high <= low))
1905 return (true);
1906 make_compiled_procedure_type (cet, (high - 1), (low - high), rest_p);
1907 return (false);
1908 }
1909 if (low < 0x80)
1910 return (true);
1911 if (low < 0xE0)
1912 {
1913 make_compiled_continuation_type
1914 (cet,
1915 (((low & 0x7F) << 7) | (high & 0x7F)));
1916 return (false);
1917 }
1918 if (high != 0xFF)
1919 return (true);
1920 switch (low)
1921 {
1922 case 0xFF:
1923 make_cc_entry_type (cet, CET_EXPRESSION);
1924 break;
1925 case 0xFE:
1926 make_cc_entry_type (cet, CET_INTERNAL_PROCEDURE);
1927 break;
1928 case 0xFD:
1929 make_cc_entry_type (cet, CET_TRAMPOLINE);
1930 break;
1931 case 0xFC:
1932 make_cc_entry_type (cet, CET_INTERNAL_CONTINUATION);
1933 break;
1934 case 0xFB:
1935 make_cc_entry_type (cet, CET_RETURN_TO_INTERPRETER);
1936 break;
1937 case 0xFA:
1938 make_cc_entry_type (cet, CET_CLOSURE);
1939 break;
1940 default:
1941 return (true);
1942 }
1943 return (false);
1944 }
1945
1946 bool
encode_old_style_format_word(cc_entry_type_t * cet,uint16_t * fw_r)1947 encode_old_style_format_word (cc_entry_type_t * cet, uint16_t * fw_r)
1948 {
1949 unsigned int low;
1950 unsigned int high;
1951
1952 switch (cet->marker)
1953 {
1954 case CET_PROCEDURE:
1955 high = ((cet->args.for_procedure.n_required) + 1);
1956 low = (high + (cet->args.for_procedure.n_optional));
1957 if (! (low < 0x80))
1958 return (true);
1959 if (cet->args.for_procedure.rest_p)
1960 low = (0xFF - low);
1961 break;
1962
1963 case CET_CONTINUATION:
1964 {
1965 unsigned long n = (cet->args.for_continuation.offset);
1966 if (! (n < 0x3000))
1967 return (true);
1968 high = ((n & 0x7F) | 0x80);
1969 low = ((n >> 7) | 0x80);
1970 }
1971 break;
1972
1973 case CET_EXPRESSION:
1974 low = 0xFF;
1975 high = 0xFF;
1976 break;
1977
1978 case CET_INTERNAL_PROCEDURE:
1979 low = 0xFE;
1980 high = 0xFF;
1981 break;
1982
1983 case CET_TRAMPOLINE:
1984 low = 0xFD;
1985 high = 0xFF;
1986 break;
1987
1988 case CET_INTERNAL_CONTINUATION:
1989 low = 0xFC;
1990 high = 0xFF;
1991 break;
1992
1993 case CET_RETURN_TO_INTERPRETER:
1994 low = 0xFB;
1995 high = 0xFF;
1996 break;
1997
1998 case CET_CLOSURE:
1999 low = 0xFA;
2000 high = 0xFF;
2001 break;
2002
2003 default:
2004 return (true);
2005 }
2006 (*fw_r) = ((high << 8) | low);
2007 return (false);
2008 }
2009
2010 /* Trampolines
2011
2012 When a free variable appears in operator position in compiled code,
2013 there must be a directly callable procedure in the corresponding
2014 UUO cell. If, at link time, there is no appropriate value for the
2015 free variable, a fake compiled Scheme procedure that calls one of
2016 these procedures will be placed into the cell instead.
2017
2018 The trampolines themselves are made by 'make_uuo_link',
2019 'make_fake_uuo_link', and 'coerce_to_compiled'. The trampoline
2020 looks like a Scheme closure, containing some code that jumps to one
2021 of these procedures, and additional information to be used by the
2022 procedure.
2023
2024 These procedures expect a single argument, the address of the
2025 information block where they can find the relevant data: typically
2026 the procedure to invoke and the number of arguments to invoke it
2027 with. */
2028
2029 #define DEFINE_TRAMPOLINE(pname) \
2030 DEFINE_SCHEME_UTILITY_1 (pname, TRAMP_store)
2031
2032 #define INIT_TRAMPOLINE_1(av1) \
2033 DECLARE_UTILITY_ARG (SCHEME_OBJECT *, TRAMP_store); \
2034 SCHEME_OBJECT av1 = (TRAMP_store[0])
2035
2036 #define INIT_TRAMPOLINE_2(av1, av2) \
2037 DECLARE_UTILITY_ARG (SCHEME_OBJECT *, TRAMP_store); \
2038 SCHEME_OBJECT av1 = (TRAMP_store[0]); \
2039 SCHEME_OBJECT av2 = (TRAMP_store[1])
2040
2041 #define INIT_TRAMPOLINE_3(av1, av2, av3) \
2042 DECLARE_UTILITY_ARG (SCHEME_OBJECT *, TRAMP_store); \
2043 SCHEME_OBJECT av1 = (TRAMP_store[0]); \
2044 SCHEME_OBJECT av2 = (TRAMP_store[1]); \
2045 SCHEME_OBJECT av3 = (TRAMP_store[2])
2046
2047 /* This is how compiled Scheme code normally returns back to the
2048 Scheme interpreter. It is invoked by a trampoline, which passes
2049 the address of the (empty) trampoline storage block to it. */
2050
DEFINE_TRAMPOLINE(comutil_return_to_interpreter)2051 DEFINE_TRAMPOLINE (comutil_return_to_interpreter)
2052 {
2053 RETURN_TO_C (PRIM_DONE);
2054 }
2055
DEFINE_TRAMPOLINE(comutil_reflect_to_interface)2056 DEFINE_TRAMPOLINE (comutil_reflect_to_interface)
2057 {
2058 SCHEME_OBJECT code = (STACK_POP ());
2059
2060 switch (OBJECT_DATUM (code))
2061 {
2062 case REFLECT_CODE_INTERNAL_APPLY:
2063 {
2064 unsigned long frame_size = (OBJECT_DATUM (STACK_POP ()));
2065 SCHEME_OBJECT procedure = (STACK_POP ());
2066 TAIL_CALL_2 (comutil_apply, procedure, frame_size);
2067 }
2068
2069 case REFLECT_CODE_RESTORE_INTERRUPT_MASK:
2070 SET_INTERRUPT_MASK (OBJECT_DATUM (STACK_POP ()));
2071 INVOKE_RETURN_ADDRESS ();
2072
2073 case REFLECT_CODE_STACK_MARKER:
2074 (void) STACK_POP (); /* marker1 */
2075 (void) STACK_POP (); /* marker2 */
2076 INVOKE_RETURN_ADDRESS ();
2077
2078 case REFLECT_CODE_CC_BKPT:
2079 /* Attempt to process interrupts before really proceeding. */
2080 if (Free >= GET_MEMTOP)
2081 {
2082 PUSH_REFLECTION (REFLECT_CODE_CC_BKPT);
2083 compiler_interrupt_common (DSU_result, 0, SHARP_F);
2084 return;
2085 }
2086 {
2087 insn_t * addr;
2088 long code = (do_bkpt_proceed (&addr));
2089 if (code != PRIM_DONE)
2090 {
2091 STACK_PUSH (code);
2092 RETURN_TO_C (code);
2093 }
2094 RETURN_TO_SCHEME (addr);
2095 }
2096
2097 default:
2098 STACK_PUSH (code);
2099 RETURN_TO_C (ERR_EXTERNAL_RETURN);
2100 }
2101 }
2102
DEFINE_TRAMPOLINE(comutil_operator_apply_trap)2103 DEFINE_TRAMPOLINE (comutil_operator_apply_trap)
2104 {
2105 INIT_TRAMPOLINE_2 (procedure, frame_header);
2106 TAIL_CALL_2 (comutil_apply, procedure, (OBJECT_DATUM (frame_header)));
2107 }
2108
DEFINE_TRAMPOLINE(comutil_operator_primitive_trap)2109 DEFINE_TRAMPOLINE (comutil_operator_primitive_trap)
2110 {
2111 INIT_TRAMPOLINE_1 (primitive);
2112 TAIL_CALL_1 (comutil_primitive_apply, primitive);
2113 }
2114
DEFINE_TRAMPOLINE(comutil_operator_lexpr_trap)2115 DEFINE_TRAMPOLINE (comutil_operator_lexpr_trap)
2116 {
2117 INIT_TRAMPOLINE_2 (procedure, frame_header);
2118 SET_LEXPR_ACTUALS (APPLY_FRAME_HEADER_N_ARGS (frame_header));
2119 TAIL_CALL_1 (comutil_primitive_lexpr_apply, procedure);
2120 }
2121
2122 /* ARITY mismatch handling
2123
2124 These receive the entry point as an argument and must fill the
2125 Scheme stack with the missing default values. They are invoked by
2126 TRAMPOLINE_K_n_m where n and m are the same as in the name of the
2127 procedure. All the arguments are on the Scheme stack. */
2128
DEFINE_TRAMPOLINE(comutil_operator_1_0_trap)2129 DEFINE_TRAMPOLINE (comutil_operator_1_0_trap)
2130 {
2131 INIT_TRAMPOLINE_1 (procedure);
2132 STACK_PUSH (DEFAULT_OBJECT);
2133 RETURN_TO_SCHEME (CC_ENTRY_ADDRESS (procedure));
2134 }
2135
DEFINE_TRAMPOLINE(comutil_operator_2_0_trap)2136 DEFINE_TRAMPOLINE (comutil_operator_2_0_trap)
2137 {
2138 INIT_TRAMPOLINE_1 (procedure);
2139 STACK_PUSH (DEFAULT_OBJECT);
2140 STACK_PUSH (DEFAULT_OBJECT);
2141 RETURN_TO_SCHEME (CC_ENTRY_ADDRESS (procedure));
2142 }
2143
DEFINE_TRAMPOLINE(comutil_operator_2_1_trap)2144 DEFINE_TRAMPOLINE (comutil_operator_2_1_trap)
2145 {
2146 INIT_TRAMPOLINE_1 (procedure);
2147 {
2148 SCHEME_OBJECT a1 = (STACK_POP ());
2149 STACK_PUSH (DEFAULT_OBJECT);
2150 STACK_PUSH (a1);
2151 }
2152 RETURN_TO_SCHEME (CC_ENTRY_ADDRESS (procedure));
2153 }
2154
DEFINE_TRAMPOLINE(comutil_operator_3_0_trap)2155 DEFINE_TRAMPOLINE (comutil_operator_3_0_trap)
2156 {
2157 INIT_TRAMPOLINE_1 (procedure);
2158 STACK_PUSH (DEFAULT_OBJECT);
2159 STACK_PUSH (DEFAULT_OBJECT);
2160 STACK_PUSH (DEFAULT_OBJECT);
2161 RETURN_TO_SCHEME (CC_ENTRY_ADDRESS (procedure));
2162 }
2163
DEFINE_TRAMPOLINE(comutil_operator_3_1_trap)2164 DEFINE_TRAMPOLINE (comutil_operator_3_1_trap)
2165 {
2166 INIT_TRAMPOLINE_1 (procedure);
2167 {
2168 SCHEME_OBJECT a1 = (STACK_POP ());
2169 STACK_PUSH (DEFAULT_OBJECT);
2170 STACK_PUSH (DEFAULT_OBJECT);
2171 STACK_PUSH (a1);
2172 }
2173 RETURN_TO_SCHEME (CC_ENTRY_ADDRESS (procedure));
2174 }
2175
DEFINE_TRAMPOLINE(comutil_operator_3_2_trap)2176 DEFINE_TRAMPOLINE (comutil_operator_3_2_trap)
2177 {
2178 INIT_TRAMPOLINE_1 (procedure);
2179 {
2180 SCHEME_OBJECT a1 = (STACK_POP ());
2181 SCHEME_OBJECT a2 = (STACK_POP ());
2182 STACK_PUSH (DEFAULT_OBJECT);
2183 STACK_PUSH (a2);
2184 STACK_PUSH (a1);
2185 }
2186 RETURN_TO_SCHEME (CC_ENTRY_ADDRESS (procedure));
2187 }
2188
DEFINE_TRAMPOLINE(comutil_operator_4_0_trap)2189 DEFINE_TRAMPOLINE (comutil_operator_4_0_trap)
2190 {
2191 INIT_TRAMPOLINE_1 (procedure);
2192 STACK_PUSH (DEFAULT_OBJECT);
2193 STACK_PUSH (DEFAULT_OBJECT);
2194 STACK_PUSH (DEFAULT_OBJECT);
2195 STACK_PUSH (DEFAULT_OBJECT);
2196 RETURN_TO_SCHEME (CC_ENTRY_ADDRESS (procedure));
2197 }
2198
DEFINE_TRAMPOLINE(comutil_operator_4_1_trap)2199 DEFINE_TRAMPOLINE (comutil_operator_4_1_trap)
2200 {
2201 INIT_TRAMPOLINE_1 (procedure);
2202 {
2203 SCHEME_OBJECT a1 = (STACK_POP ());
2204 STACK_PUSH (DEFAULT_OBJECT);
2205 STACK_PUSH (DEFAULT_OBJECT);
2206 STACK_PUSH (DEFAULT_OBJECT);
2207 STACK_PUSH (a1);
2208 }
2209 RETURN_TO_SCHEME (CC_ENTRY_ADDRESS (procedure));
2210 }
2211
DEFINE_TRAMPOLINE(comutil_operator_4_2_trap)2212 DEFINE_TRAMPOLINE (comutil_operator_4_2_trap)
2213 {
2214 INIT_TRAMPOLINE_1 (procedure);
2215 {
2216 SCHEME_OBJECT a1 = (STACK_POP ());
2217 SCHEME_OBJECT a2 = (STACK_POP ());
2218 STACK_PUSH (DEFAULT_OBJECT);
2219 STACK_PUSH (DEFAULT_OBJECT);
2220 STACK_PUSH (a2);
2221 STACK_PUSH (a1);
2222 }
2223 RETURN_TO_SCHEME (CC_ENTRY_ADDRESS (procedure));
2224 }
2225
DEFINE_TRAMPOLINE(comutil_operator_4_3_trap)2226 DEFINE_TRAMPOLINE (comutil_operator_4_3_trap)
2227 {
2228 INIT_TRAMPOLINE_1 (procedure);
2229 {
2230 SCHEME_OBJECT a1 = (STACK_POP ());
2231 SCHEME_OBJECT a2 = (STACK_POP ());
2232 SCHEME_OBJECT a3 = (STACK_POP ());
2233 STACK_PUSH (DEFAULT_OBJECT);
2234 STACK_PUSH (a3);
2235 STACK_PUSH (a2);
2236 STACK_PUSH (a1);
2237 }
2238 RETURN_TO_SCHEME (CC_ENTRY_ADDRESS (procedure));
2239 }
2240
2241 /* The linker either couldn't find a binding or the binding was
2242 unassigned. This must report the correct name of the missing
2243 variable and the environment in which the lookup begins for the
2244 error cases.
2245
2246 'cache' is the linker object corresponding to the operator variable
2247 (it contains the actual value cell, the name, and linker tables).
2248 'block' and 'offset' point to the cache cell in question. */
2249
DEFINE_TRAMPOLINE(comutil_operator_lookup_trap)2250 DEFINE_TRAMPOLINE (comutil_operator_lookup_trap)
2251 {
2252 INIT_TRAMPOLINE_3 (cache, block, offset);
2253 SCHEME_OBJECT * cache_addr = (MEMORY_LOC (block, (OBJECT_DATUM (offset))));
2254 unsigned long frame_size = (read_uuo_frame_size (cache_addr));
2255 SCHEME_OBJECT procedure;
2256 long code = (compiler_operator_reference_trap (cache, (&procedure)));
2257 if (code != PRIM_DONE)
2258 {
2259 STACK_PUSH (MAKE_CC_ENTRY (read_uuo_target_no_reloc (cache_addr)));
2260 /* Next three for debugger. */
2261 STACK_PUSH (ULONG_TO_FIXNUM (frame_size));
2262 STACK_PUSH (cc_block_environment (block));
2263 STACK_PUSH
2264 (compiler_var_error (cache, block, CACHE_REFERENCES_OPERATOR));
2265 SAVE_LAST_RETURN_CODE (RC_COMP_OP_REF_TRAP_RESTART);
2266 RETURN_TO_C (code);
2267 }
2268 TAIL_CALL_2 (comutil_apply, procedure, frame_size);
2269 }
2270
2271 /* Re-start after processing an error/interrupt encountered in the
2272 previous utility. Extract the new trampoline or procedure (the
2273 user may have defined the missing variable) and invoke it. */
2274
DEFINE_SCHEME_ENTRY(comp_op_lookup_trap_restart)2275 DEFINE_SCHEME_ENTRY (comp_op_lookup_trap_restart)
2276 {
2277 RESTORE_LAST_RETURN_CODE ();
2278 /* Discard debugger info. */
2279 stack_pointer = (STACK_LOC (3));
2280 {
2281 SCHEME_OBJECT * store
2282 = (trampoline_storage (cc_entry_to_block_address (STACK_POP ())));
2283 SCHEME_OBJECT block = (store[1]);
2284 unsigned long offset = (OBJECT_DATUM (store[2]));
2285 ENTER_SCHEME (read_uuo_target_no_reloc (MEMORY_LOC (block, offset)));
2286 }
2287 }
2288
2289 /* make_uuo_link is called by C and initializes a compiled procedure
2290 cache at a location given by a block and an offset. */
2291
2292 long
make_uuo_link(SCHEME_OBJECT procedure,SCHEME_OBJECT cache,SCHEME_OBJECT block,unsigned long offset)2293 make_uuo_link (SCHEME_OBJECT procedure,
2294 SCHEME_OBJECT cache,
2295 SCHEME_OBJECT block,
2296 unsigned long offset)
2297 {
2298 SCHEME_OBJECT * cache_address = (MEMORY_LOC (block, offset));
2299 unsigned long frame_size = (read_uuo_frame_size (cache_address));
2300 trampoline_type_t kind;
2301 long result;
2302 SCHEME_OBJECT trampoline;
2303
2304 if (REFERENCE_TRAP_P (procedure))
2305 return (make_fake_uuo_link (cache, block, offset));
2306
2307 loop:
2308 switch (OBJECT_TYPE (procedure))
2309 {
2310 case TC_COMPILED_ENTRY:
2311 {
2312 insn_t * entry = (CC_ENTRY_ADDRESS (procedure));
2313 unsigned long nargs = (frame_size - 1);
2314 cc_entry_type_t cet;
2315 unsigned long nmin;
2316 unsigned long nmax;
2317
2318 if ((read_cc_entry_type ((&cet), entry))
2319 || ((cet.marker) != CET_PROCEDURE))
2320 return (ERR_COMPILED_CODE_ERROR);
2321 nmin = (cet.args.for_procedure.n_required);
2322 nmax = (nmin + (cet.args.for_procedure.n_optional));
2323 if (cet.args.for_procedure.rest_p)
2324 kind = TRAMPOLINE_K_APPLY;
2325 else if (nargs == nmax)
2326 {
2327 /* No defaulting is needed. */
2328 write_uuo_link (procedure, cache_address);
2329 return (PRIM_DONE);
2330 }
2331 else if ((nargs < nmax)
2332 && (nargs >= nmin)
2333 && (nmin < nmax)
2334 && (nmax <= TRAMPOLINE_TABLE_SIZE))
2335 {
2336 /* We have optimized defaulting for this case. */
2337 kind
2338 = (trampoline_arity_table
2339 [(((nmax - 1) * TRAMPOLINE_TABLE_SIZE) + nargs)]);
2340 assert (kind != TRAMPOLINE_K_APPLY);
2341 frame_size = 0;
2342 }
2343 else
2344 /* Use unoptimized defaulting. */
2345 kind = TRAMPOLINE_K_APPLY;
2346 break;
2347 }
2348
2349 case TC_ENTITY:
2350 {
2351 SCHEME_OBJECT data = (MEMORY_REF (procedure, ENTITY_DATA));
2352 if ((VECTOR_P (data))
2353 && (frame_size < (VECTOR_LENGTH (data)))
2354 && ((VECTOR_REF (data, frame_size)) != SHARP_F)
2355 && ((VECTOR_REF (data, 0))
2356 == (VECTOR_REF (fixed_objects, ARITY_DISPATCHER_TAG))))
2357 {
2358 procedure = (VECTOR_REF (data, frame_size));
2359 goto loop;
2360 }
2361 kind = TRAMPOLINE_K_APPLY;
2362 break;
2363 }
2364
2365 case TC_PRIMITIVE:
2366 {
2367 long arity = (PRIMITIVE_ARITY (procedure));
2368 if (arity == ((long) (frame_size - 1)))
2369 {
2370 kind = TRAMPOLINE_K_PRIMITIVE;
2371 frame_size = 0;
2372 }
2373 else if (arity == LEXPR_PRIMITIVE_ARITY)
2374 kind = TRAMPOLINE_K_LEXPR_PRIMITIVE;
2375 else
2376 kind = TRAMPOLINE_K_APPLY;
2377 break;
2378 }
2379
2380 default:
2381 kind = TRAMPOLINE_K_APPLY;
2382 break;
2383 }
2384 result
2385 = ((frame_size == 0)
2386 ? (make_redirection_trampoline ((&trampoline), kind, procedure))
2387 : (make_apply_trampoline ((&trampoline), kind, procedure, frame_size)));
2388 if (result == PRIM_DONE)
2389 write_uuo_link (trampoline, cache_address);
2390 return (result);
2391 }
2392
2393 static long
make_fake_uuo_link(SCHEME_OBJECT cache,SCHEME_OBJECT block,unsigned long offset)2394 make_fake_uuo_link (SCHEME_OBJECT cache,
2395 SCHEME_OBJECT block,
2396 unsigned long offset)
2397 {
2398 cc_entry_type_t cet;
2399 SCHEME_OBJECT trampoline;
2400
2401 make_cc_entry_type ((&cet), CET_TRAMPOLINE);
2402 {
2403 long result = (make_trampoline ((&trampoline),
2404 (&cet),
2405 TRAMPOLINE_K_LOOKUP,
2406 3,
2407 cache,
2408 block,
2409 (ULONG_TO_FIXNUM (offset))));
2410 if (result != PRIM_DONE)
2411 return (result);
2412 }
2413 {
2414 SCHEME_OBJECT * cache_address = (MEMORY_LOC (block, offset));
2415 write_uuo_link (trampoline, cache_address);
2416 }
2417 return (PRIM_DONE);
2418 }
2419
2420 long
coerce_to_compiled(SCHEME_OBJECT procedure,unsigned int arity,SCHEME_OBJECT * location)2421 coerce_to_compiled (SCHEME_OBJECT procedure,
2422 unsigned int arity,
2423 SCHEME_OBJECT * location)
2424 {
2425 cc_entry_type_t cet;
2426
2427 if (CC_ENTRY_P (procedure))
2428 {
2429 if (read_cc_entry_type ((&cet), (CC_ENTRY_ADDRESS (procedure))))
2430 return (ERR_COMPILED_CODE_ERROR);
2431 if ((cet.marker) == CET_PROCEDURE)
2432 {
2433 (*location) = procedure;
2434 return (PRIM_DONE);
2435 }
2436 }
2437 make_compiled_procedure_type ((&cet), arity, 0, false);
2438 return (make_trampoline (location,
2439 (&cet),
2440 TRAMPOLINE_K_APPLY,
2441 2,
2442 procedure,
2443 (ULONG_TO_FIXNUM (arity + 1))));
2444 }
2445
2446 static long
make_trampoline(SCHEME_OBJECT * slot,cc_entry_type_t * cet,trampoline_type_t kind,unsigned int n_values,...)2447 make_trampoline (SCHEME_OBJECT * slot,
2448 cc_entry_type_t * cet,
2449 trampoline_type_t kind,
2450 unsigned int n_values,
2451 ...)
2452 {
2453 SCHEME_OBJECT h1;
2454 SCHEME_OBJECT h2;
2455 unsigned long n_words;
2456 SCHEME_OBJECT * block;
2457
2458 make_trampoline_headers (1, n_values, (&h1), (&h2), (&n_words));
2459 if (GC_NEEDED_P (n_words))
2460 {
2461 REQUEST_GC (n_words);
2462 return (PRIM_INTERRUPT);
2463 }
2464 block = Free;
2465 Free += n_words;
2466 (block[0]) = h1;
2467 (block[1]) = h2;
2468 if (fill_trampoline (block, 0, cet, kind))
2469 return (ERR_COMPILED_CODE_ERROR);
2470 {
2471 SCHEME_OBJECT * p = (trampoline_storage (block));
2472 va_list ap;
2473
2474 va_start (ap, n_values);
2475 while (n_values > 0)
2476 {
2477 (*p++) = (va_arg (ap, SCHEME_OBJECT));
2478 n_values -= 1;
2479 }
2480 va_end (ap);
2481 }
2482 (*slot) = (MAKE_CC_ENTRY (trampoline_entry_addr (block, 0)));
2483 return (PRIM_DONE);
2484 }
2485
2486 static void
make_trampoline_headers(unsigned long n_entries,unsigned long n_store,SCHEME_OBJECT * h1_r,SCHEME_OBJECT * h2_r,unsigned long * n_words_r)2487 make_trampoline_headers (unsigned long n_entries, unsigned long n_store,
2488 SCHEME_OBJECT * h1_r, SCHEME_OBJECT * h2_r,
2489 unsigned long * n_words_r)
2490 {
2491 unsigned long n1 = (trampoline_entry_size (n_entries));
2492 unsigned long n2 = (1 + n1 + n_store);
2493 (*h1_r) = (MAKE_OBJECT (TC_TRAMPOLINE_HEADER, n2));
2494 (*h2_r) = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, n1));
2495 (*n_words_r) = (1 + n2);
2496 }
2497
2498 static bool
fill_trampoline(SCHEME_OBJECT * block,unsigned long index,cc_entry_type_t * cet,trampoline_type_t kind)2499 fill_trampoline (SCHEME_OBJECT * block,
2500 unsigned long index,
2501 cc_entry_type_t * cet,
2502 trampoline_type_t kind)
2503 {
2504 insn_t * addr = (trampoline_entry_addr (block, index));
2505 if (write_cc_entry_type (cet, addr))
2506 return (true);
2507 {
2508 cc_entry_offset_t ceo;
2509 (ceo.offset) = (addr - ((insn_t *) block));
2510 (ceo.continued_p) = false;
2511 if (write_cc_entry_offset ((&ceo), addr))
2512 return (true);
2513 }
2514 return (store_trampoline_insns (addr, kind));
2515 }
2516
2517 SCHEME_OBJECT *
trampoline_storage(SCHEME_OBJECT * block)2518 trampoline_storage (SCHEME_OBJECT * block)
2519 {
2520 return (block + 2 + (OBJECT_DATUM (block[1])));
2521 }
2522
2523 static long
make_redirection_trampoline(SCHEME_OBJECT * slot,trampoline_type_t kind,SCHEME_OBJECT procedure)2524 make_redirection_trampoline (SCHEME_OBJECT * slot,
2525 trampoline_type_t kind,
2526 SCHEME_OBJECT procedure)
2527 {
2528 cc_entry_type_t cet;
2529 make_cc_entry_type ((&cet), CET_TRAMPOLINE);
2530 return (make_trampoline (slot, (&cet), kind, 1, procedure));
2531 }
2532
2533 static long
make_apply_trampoline(SCHEME_OBJECT * slot,trampoline_type_t kind,SCHEME_OBJECT procedure,unsigned long frame_size)2534 make_apply_trampoline (SCHEME_OBJECT * slot,
2535 trampoline_type_t kind,
2536 SCHEME_OBJECT procedure,
2537 unsigned long frame_size)
2538 {
2539 cc_entry_type_t cet;
2540 make_cc_entry_type ((&cet), CET_TRAMPOLINE);
2541 return (make_trampoline (slot,
2542 (&cet),
2543 kind,
2544 2,
2545 procedure,
2546 (ULONG_TO_FIXNUM (frame_size))));
2547 }
2548
2549 /* Compiled-code breakpoints */
2550
2551 #ifdef HAVE_BKPT_SUPPORT
2552
2553 #define BKPT_PROCEED_FRAME_SIZE 3
2554
2555 SCHEME_OBJECT
bkpt_proceed(insn_t * ep,SCHEME_OBJECT handle,SCHEME_OBJECT state)2556 bkpt_proceed (insn_t * ep, SCHEME_OBJECT handle, SCHEME_OBJECT state)
2557 {
2558 if (! ((CC_ENTRY_P (STACK_REF (BKPT_PROCEED_FRAME_SIZE)))
2559 && ((CC_ENTRY_ADDRESS (STACK_REF (BKPT_PROCEED_FRAME_SIZE))) == ep)))
2560 error_external_return ();
2561 PUSH_REFLECTION (REFLECT_CODE_CC_BKPT);
2562 stack_pointer = (STACK_LOC (-BKPT_PROCEED_FRAME_SIZE));
2563 return (SHARP_F);
2564 }
2565
2566 #else /* not HAVE_BKPT_SUPPORT */
2567
2568 SCHEME_OBJECT
bkpt_install(insn_t * ep)2569 bkpt_install (insn_t * ep)
2570 {
2571 return (SHARP_F);
2572 }
2573
2574 SCHEME_OBJECT
bkpt_closure_install(insn_t * ep)2575 bkpt_closure_install (insn_t * ep)
2576 {
2577 return (SHARP_F);
2578 }
2579
2580 void
bkpt_remove(insn_t * ep,SCHEME_OBJECT handle)2581 bkpt_remove (insn_t * ep, SCHEME_OBJECT handle)
2582 {
2583 error_external_return ();
2584 }
2585
2586 bool
bkpt_p(insn_t * ep)2587 bkpt_p (insn_t * ep)
2588 {
2589 return (false);
2590 }
2591
2592 SCHEME_OBJECT
bkpt_proceed(insn_t * ep,SCHEME_OBJECT handle,SCHEME_OBJECT state)2593 bkpt_proceed (insn_t * ep, SCHEME_OBJECT handle, SCHEME_OBJECT state)
2594 {
2595 error_external_return ();
2596 return (UNSPECIFIC);
2597 }
2598
2599 long
do_bkpt_proceed(insn_t ** addr_r)2600 do_bkpt_proceed (insn_t ** addr_r)
2601 {
2602 return (ERR_EXTERNAL_RETURN);
2603 }
2604
2605 #endif /* not HAVE_BKPT_SUPPORT */
2606
DEFINE_SCHEME_UTILITY_2(comutil_compiled_code_bkpt,entry_addr,state)2607 DEFINE_SCHEME_UTILITY_2 (comutil_compiled_code_bkpt, entry_addr, state)
2608 {
2609 DECLARE_UTILITY_ARG (insn_t *, entry_addr);
2610 DECLARE_UTILITY_ARG (void *, state);
2611 SCHEME_OBJECT entry = (MAKE_CC_ENTRY (entry_addr));
2612 cc_entry_type_t cet;
2613 SCHEME_OBJECT to_save;
2614 SCHEME_OBJECT stack_ptr;
2615
2616 /* Potential bug: This does not preserve the environment for IC
2617 procedures. There is no way to tell that we have an IC procedure
2618 in our hands. It is not safe to preserve it in general because
2619 the contents of the register may be stale (predate the last GC).
2620 However, the compiler no longer generates IC procedures, and will
2621 probably never do it again. */
2622
2623 if (read_cc_entry_type ((&cet), entry_addr))
2624 to_save = SHARP_F;
2625 else
2626 switch (cet.marker)
2627 {
2628 case CET_CONTINUATION:
2629 to_save = GET_VAL;
2630 break;
2631
2632 case CET_INTERNAL_CONTINUATION:
2633 to_save = (MAKE_CC_STACK_ENV ((SCHEME_OBJECT *) state));
2634 break;
2635
2636 case CET_RETURN_TO_INTERPRETER:
2637 to_save = GET_VAL;
2638 break;
2639
2640 case CET_CLOSURE:
2641 to_save = (MAKE_CC_ENTRY ((insn_t *) state));
2642 break;
2643
2644 default:
2645 to_save = SHARP_F;
2646 break;
2647 }
2648
2649 STACK_PUSH (entry);
2650 stack_ptr = (MAKE_CC_STACK_ENV (stack_pointer));
2651 STACK_PUSH (to_save);
2652 STACK_PUSH (stack_ptr);
2653 STACK_PUSH (entry);
2654 TAIL_CALL_2 (comutil_apply,
2655 (VECTOR_REF (fixed_objects, CC_BKPT_PROCEDURE)),
2656 4);
2657 }
2658
DEFINE_SCHEME_UTILITY_1(comutil_compiled_closure_bkpt,entry_addr)2659 DEFINE_SCHEME_UTILITY_1 (comutil_compiled_closure_bkpt, entry_addr)
2660 {
2661 DECLARE_UTILITY_ARG (insn_t *, entry_addr);
2662 SCHEME_OBJECT entry = (MAKE_CC_ENTRY (entry_addr));
2663 SCHEME_OBJECT stack_ptr;
2664
2665 STACK_PUSH (entry);
2666 stack_ptr = (MAKE_CC_STACK_ENV (stack_pointer));
2667 STACK_PUSH (SHARP_F);
2668 STACK_PUSH (stack_ptr);
2669 STACK_PUSH (entry);
2670 TAIL_CALL_2 (comutil_apply,
2671 (VECTOR_REF (fixed_objects, CC_BKPT_PROCEDURE)),
2672 4);
2673 }
2674
2675 /* Utility table used by the assembly language interface to invoke the
2676 SCHEME_UTILITY procedures that appear in this file.
2677
2678 Important: Do NOT reorder this table without changing the indices
2679 defined on the following page and the corresponding table in the
2680 compiler. */
2681
2682 utility_proc_t * utility_table [] =
2683 {
2684 comutil_return_to_interpreter, /* 0x0 */
2685 comutil_operator_apply_trap, /* 0x1 */
2686 comutil_operator_apply_trap, /* 0x2 */
2687 comutil_operator_apply_trap, /* 0x3 */
2688 comutil_operator_apply_trap, /* 0x4 */
2689 comutil_operator_lexpr_trap, /* 0x5 */
2690 comutil_operator_primitive_trap, /* 0x6 */
2691 comutil_operator_lookup_trap, /* 0x7 */
2692 comutil_operator_1_0_trap, /* 0x8 */
2693 comutil_operator_2_1_trap, /* 0x9 */
2694 comutil_operator_2_0_trap, /* 0xa */
2695 comutil_operator_3_2_trap, /* 0xb */
2696 comutil_operator_3_1_trap, /* 0xc */
2697 comutil_operator_3_0_trap, /* 0xd */
2698 comutil_operator_4_3_trap, /* 0xe */
2699 comutil_operator_4_2_trap, /* 0xf */
2700 comutil_operator_4_1_trap, /* 0x10 */
2701 comutil_operator_4_0_trap, /* 0x11 */
2702 comutil_primitive_apply, /* 0x12 */
2703 comutil_primitive_lexpr_apply, /* 0x13 */
2704 comutil_apply, /* 0x14 */
2705 comutil_error, /* 0x15 */
2706 comutil_lexpr_apply, /* 0x16 */
2707 comutil_link, /* 0x17 */
2708 comutil_interrupt_closure, /* 0x18 */
2709 comutil_interrupt_dlink, /* 0x19 */
2710 comutil_interrupt_procedure, /* 0x1a */
2711 comutil_interrupt_continuation, /* 0x1b */
2712 comutil_interrupt_ic_procedure, /* 0x1c */
2713 comutil_assignment_trap, /* 0x1d */
2714 comutil_cache_lookup_apply, /* 0x1e */
2715 comutil_lookup_trap, /* 0x1f */
2716 comutil_safe_lookup_trap, /* 0x20 */
2717 comutil_unassigned_p_trap, /* 0x21 */
2718 comutil_decrement, /* 0x22 */
2719 comutil_divide, /* 0x23 */
2720 comutil_equal, /* 0x24 */
2721 comutil_greater, /* 0x25 */
2722 comutil_increment, /* 0x26 */
2723 comutil_less, /* 0x27 */
2724 comutil_minus, /* 0x28 */
2725 comutil_multiply, /* 0x29 */
2726 comutil_negative, /* 0x2a */
2727 comutil_plus, /* 0x2b */
2728 comutil_positive, /* 0x2c */
2729 comutil_zero, /* 0x2d */
2730 0, /* 0x2e */
2731 0, /* 0x2f */
2732 0, /* 0x30 */
2733 0, /* 0x31 */
2734 0, /* 0x32 */
2735 0, /* 0x33 */
2736 0, /* 0x34 */
2737 0, /* 0x35 */
2738 comutil_primitive_error, /* 0x36 */
2739 comutil_quotient, /* 0x37 */
2740 comutil_remainder, /* 0x38 */
2741 comutil_modulo, /* 0x39 */
2742 comutil_reflect_to_interface, /* 0x3a */
2743 comutil_interrupt_continuation_2, /* 0x3b */
2744 comutil_compiled_code_bkpt, /* 0x3c */
2745 comutil_compiled_closure_bkpt /* 0x3d */
2746 };
2747
2748 unsigned long max_trampoline
2749 = ((sizeof (utility_table)) / (sizeof (utility_proc_t *)));
2750
2751 /* Support for trap handling. */
2752
2753 const char *
utility_index_to_name(unsigned int index)2754 utility_index_to_name (unsigned int index)
2755 {
2756 return (0);
2757 }
2758
2759 int
pc_to_utility_index(unsigned long pc)2760 pc_to_utility_index (unsigned long pc)
2761 {
2762 return (-1);
2763 }
2764
2765 static unsigned int n_builtins = 0;
2766 static unsigned int s_builtins = 0;
2767 static unsigned long * builtins = 0;
2768 static const char ** builtin_names = 0;
2769
2770 void
declare_builtin(unsigned long builtin,const char * name)2771 declare_builtin (unsigned long builtin, const char * name)
2772 {
2773 if (n_builtins == s_builtins)
2774 {
2775 if (s_builtins == 0)
2776 {
2777 s_builtins = 30;
2778 builtins = (malloc (s_builtins * (sizeof (unsigned long))));
2779 builtin_names = (malloc (s_builtins * (sizeof (char *))));
2780 }
2781 else
2782 {
2783 s_builtins += s_builtins;
2784 builtins
2785 = (realloc (builtins, (s_builtins * (sizeof (unsigned long)))));
2786 builtin_names
2787 = (realloc (builtin_names, (s_builtins * (sizeof (char *)))));
2788 }
2789 if ((builtins == 0) || (builtin_names == 0))
2790 {
2791 outf_fatal ("declare_builtin: malloc/realloc failed (size = %d).\n",
2792 s_builtins);
2793 termination_init_error ();
2794 }
2795 }
2796 {
2797 unsigned int low = 0;
2798 unsigned int high = n_builtins;
2799 while (1)
2800 {
2801 if (low < high)
2802 {
2803 unsigned int middle = ((low + high) / 2);
2804 if (builtin < (builtins[middle]))
2805 high = middle;
2806 else if (builtin > (builtins[middle]))
2807 low = (middle + 1);
2808 else
2809 {
2810 (builtin_names[middle]) = name;
2811 return;
2812 }
2813 }
2814 else
2815 {
2816 unsigned int scan = (n_builtins++);
2817 while (low < scan)
2818 {
2819 (builtins [scan]) = (builtins [scan - 1]);
2820 (builtin_names [scan]) = (builtin_names [scan - 1]);
2821 scan -= 1;
2822 }
2823 (builtins [low]) = builtin;
2824 (builtin_names [low]) = name;
2825 return;
2826 }
2827 }
2828 }
2829 }
2830
2831 const char *
builtin_index_to_name(unsigned int index)2832 builtin_index_to_name (unsigned int index)
2833 {
2834 return ((index < n_builtins) ? (builtin_names[index]) : 0);
2835 }
2836
2837 int
pc_to_builtin_index(unsigned long pc)2838 pc_to_builtin_index (unsigned long pc)
2839 {
2840 if (! ((builtins != 0)
2841 && (n_builtins > 0)
2842 && (pc >= (builtins[0]))
2843 && (pc < (builtins [(n_builtins - 1)]))))
2844 return (-1);
2845 {
2846 unsigned int low = 0;
2847 unsigned int high = (n_builtins - 1);
2848 while ((low + 1) < high)
2849 {
2850 unsigned int middle = ((low + high) / 2);
2851 if (pc < (builtins[middle]))
2852 high = middle;
2853 else if (pc > (builtins[middle]))
2854 low = middle;
2855 else
2856 return (middle);
2857 }
2858 return ((pc == (builtins[high])) ? high : low);
2859 }
2860 }
2861
2862 #ifdef __WIN32__
2863 #include "ntscmlib.h"
2864
2865 extern unsigned long * win32_catatonia_block;
2866
2867 #ifndef REGBLOCK_LENGTH
2868 # define REGBLOCK_LENGTH REGBLOCK_MINIMUM_LENGTH
2869 #endif
2870
2871 typedef struct register_storage
2872 {
2873 /* The following must be allocated consecutively */
2874 unsigned long catatonia_block [3];
2875 void * Regstart [32]; /* Negative byte offsets from &Registers[0] */
2876 SCHEME_OBJECT Registers [REGBLOCK_LENGTH];
2877 } REGMEM;
2878
2879 SCHEME_OBJECT * RegistersPtr = 0;
2880 unsigned long * win32_catatonia_block = 0;
2881 static REGMEM regmem;
2882
2883 void
win32_allocate_registers(void)2884 win32_allocate_registers (void)
2885 {
2886 win32_catatonia_block = (regmem.catatonia_block);
2887 Registers = (regmem.Registers);
2888 if (!win32_system_utilities.lock_memory_area ((®mem), (sizeof (regmem))))
2889 {
2890 outf_error ("Unable to lock registers\n");
2891 outf_flush_error ();
2892 }
2893 }
2894
2895 void
win32_deallocate_registers(void)2896 win32_deallocate_registers (void)
2897 {
2898 win32_system_utilities.unlock_memory_area ((®mem), (sizeof (regmem)));
2899 }
2900
2901 #endif /* __WIN32__ */
2902