1 /* -*- C -*-
2
3 Copyright (C) 1992, 1993 Digital Equipment Corporation (D.E.C.)
4 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
5 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
6 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014 Massachusetts
7 Institute of Technology
8
9 This software was developed at the Digital Equipment Corporation
10 Cambridge Research Laboratory. Permission to copy this software, to
11 redistribute it, and to use it for any purpose is granted, subject to
12 the following restrictions and understandings.
13
14 1. Any copy made of this software must include this copyright notice
15 in full.
16
17 2. Users of this software agree to make their best efforts (a) to
18 return to both the Digital Equipment Corporation Cambridge Research
19 Lab (CRL) and the MIT Scheme project any improvements or extensions
20 that they make, so that these may be included in future releases; and
21 (b) to inform CRL and MIT of noteworthy uses of this software.
22
23 3. All materials developed as a consequence of the use of this
24 software shall duly acknowledge such use, in accordance with the usual
25 standards of acknowledging credit in academic research.
26
27 4. D.E.C. has made no warrantee or representation that the operation
28 of this software will be error-free, and D.E.C. is under no obligation
29 to provide any services, by way of maintenance, update, or otherwise.
30
31 5. In conjunction with products arising from the use of this material,
32 there shall be no use of the name of the Digital Equipment Corporation
33 nor of any adaptation thereof in any advertising, promotional, or
34 sales literature without prior written consent from D.E.C. in each
35 case. */
36
37 /*
38 *
39 * Compiled code interface macros.
40 *
41 * See cmpint.txt for a description of these fields.
42 *
43 * Specialized for the Alpha
44 */
45
46 #ifndef SCM_CMPINTMD_H_INCLUDED
47 #define SCM_CMPINTMD_H_INCLUDED
48
49
50 /* Machine parameters to be set by the user. */
51
52 /* Until cmpaux-alpha.m4 is updated. */
53 #define CMPINT_USE_STRUCS
54
55 #define PAGE_SIZE (8 * 1024)
56
57 /* Processor type. Choose a number from the above list, or allocate your own.
58 */
59
60 #define COMPILER_PROCESSOR_TYPE COMPILER_ALPHA_TYPE
61
62 /* Size (in long words) of the contents of a floating point register if
63 different from a double. For example, an MC68881 saves registers
64 in 96 bit (3 longword) blocks.
65 #define COMPILER_TEMP_SIZE 1
66 */
67
68 /* Descriptor size.
69 This is the size of the offset field, and of the format field.
70 This definition probably does not need to be changed.
71 */
72
73 typedef unsigned short format_word; /* 16 bits */
74
75 /* Utilities for manipulating absolute subroutine calls.
76 On the ALPHA this is done with either
77 BR rtarget, displacement
78 <absolute address of destination>
79 or
80 JMP rtarget, closure_hook
81 <absolute address of destination>
82 The latter form is installed by the out-of-line code that allocates
83 and initializes closures and execute caches. The former is
84 generated by the GC when the closure is close enough to the
85 destination address to fit in a branch displacement (4 megabytes).
86
87 Why does EXTRACT_ABSOLUTE_ADDRESS store into the execute cache or
88 closure? Because the GC (which calls it) assumes that if the
89 destination is in constant space there will be no need to modify the
90 cell, since the destination won't move. Since the Alpha uses
91 PC-relative addressing, though, the cell needs to be updated if the
92 cell has moved even if the destination hasn't.
93 */
94
95 #define EXTRACT_ABSOLUTE_ADDRESS(target, address) \
96 (target) = (* ((SCHEME_OBJECT *) (((int *) address) + 1))); \
97 /* The +1 skips over the instruction to the absolute address */ \
98 alpha_store_absolute_address(((void *) target), ((void *) address))
99
100
101 #define STORE_ABSOLUTE_ADDRESS(entry_point, address) \
102 alpha_store_absolute_address (((void *) entry_point), ((void *) address))
103
104 extern void alpha_store_absolute_address(void *, void *);
105
106 #define opJMP 0x1A
107 #define fnJMP 0x00
108 #define JMP(linkage, dest, displacement) \
109 ((opJMP << 26) | ((linkage) << 21) | \
110 ((dest) << 16) | (fnJMP << 14) | \
111 (((displacement)>>2) & ((1<<14)-1)))
112
113 /* Compiled Code Register Conventions */
114 /* This must match the compiler and cmpaux-alpha.m4 */
115
116 #define COMP_REG_UTILITY_CODE 1
117 #define COMP_REG_TRAMP_INDEX COMP_REG_UTILITY_CODE
118 #define COMP_REG_STACK_POINTER 2
119 #define COMP_REG_MEMTOP 3
120 #define COMP_REG_FREE 4
121 #define COMP_REG_REGISTERS 9
122 #define COMP_REG_SCHEME_INTERFACE 10
123 #define COMP_REG_CLOSURE_HOOK 11
124 #define COMP_REG_LONGJUMP COMP_REG_CLOSURE_HOOK
125 #define COMP_REG_FIRST_ARGUMENT 17
126 #define COMP_REG_LINKAGE 26
127 #define COMP_REG_TEMPORARY 28
128 #define COMP_REG_ZERO 31
129
130 #ifdef IN_CMPINT_C
131 #define PC_FIELD_SIZE 21
132 #define MAX_PC_DISPLACEMENT (1<<22)
133 #define MIN_PC_DISPLACEMENT (-MAX_PC_DISPLACEMENT)
134 #define opBR 0x30
135
136 void
alpha_store_absolute_address(void * entry_point,void * address)137 alpha_store_absolute_address (void *entry_point, void *address)
138 {
139 extern void scheme_closure_hook (void);
140 int *Instruction_Address = (int *) address;
141 SCHEME_OBJECT *Addr = (SCHEME_OBJECT *) (Instruction_Address + 1);
142 SCHEME_OBJECT *Entry_Point = (SCHEME_OBJECT *) entry_point;
143 long offset = ((char *) Entry_Point) - ((char *) Addr);
144 *Addr = (SCHEME_OBJECT) Entry_Point;
145 if ((offset < MAX_PC_DISPLACEMENT) &&
146 (offset >= MIN_PC_DISPLACEMENT))
147 *Instruction_Address =
148 (opBR << 26) | (COMP_REG_LINKAGE << 21) |
149 ((offset>>2) & ((1L<<PC_FIELD_SIZE)-1));
150 else
151 *Instruction_Address =
152 JMP(COMP_REG_LINKAGE, COMP_REG_LONGJUMP,
153 (((char *) scheme_closure_hook) - ((char *) Addr)));
154 return;
155 }
156 #endif
157
158 /* Interrupt/GC polling. */
159
160 /* Procedure entry points look like:
161
162 CONTINUATIONS AND ORDINARY PROCEDURES
163
164 GC_Handler: <code sequence 1> -- call interrupt handler
165 <entry descriptor> (32 bits)
166 label: <code sequence 2> -- test for interrupts
167 <code for procedure>
168 Interrupt: BR GC_Handler -- to help branch predictor in
169 code sequences 2
170
171 It is a good idea to align the GC_Handler (hence the label) so that
172 we dual issue nicely.
173
174 Code sequence 1 (call interrupt handler):
175 LDA UTILITY_CODE,#code(ZERO)
176 JMP LINKAGE,(SCHEME-TO-INTERFACE-JSR)
177
178 Code sequence 2 (test for interrupts):
179 CMPLT FREE,MEMTOP,temp
180 LDQ MEMTOP, 0(BLOCK)
181 BEQ temp,Interrupt
182
183 CLOSURES
184
185 <entry descriptor> (32 bits)
186 label: <code sequence 3> -- test for interrupts
187 merge: <code for procedure>
188 Internal-Label:
189 <code sequence 4> -- test for interrupts, and
190 branch to merge: if none
191 Interrupt: <code sequence 5> -- call interrupt handler
192 to help branch predictor in
193 code sequence 3
194
195 Code sequence 3 (test for interrupts):
196 ...SUBQ SP,#8,SP -- in closure object before entry
197 SUBQ LINKAGE,#8,temp -- bump ret. addr. back to entry point
198 CMPLT FREE,MEMTOP,temp2 -- interrupt/gc check
199 LDQ MEMTOP,0(BLOCK) -- Fill MemTop register
200 BIS CC_ENTRY_TYPE,temp,temp -- put tag on closure object
201 STQ temp,0(SP) -- save closure on top of stack
202 BEQ temp2,Interrupt -- possible interrupt ...
203
204 Code sequence 4 (test for interrupts):
205 *Note*: In most machines code sequence 3 and 4 are the same and are
206 shared. We've carefully optimized sequence 3 for dual issue, so it
207 differs from sequence 4. Time over space ...
208 CMPLT FREE,MEMTOP,temp -- interrupt/gc check
209 LDQ MEMTOP,0(BLOCK) -- Fill MemTop register
210 BNE temp,Merge -- branch back if no interrupt
211
212 Code sequence 5 (call interrupt handler):
213 LDA UTILITY_CODE,#code(ZERO)
214 JMP LINKAGE,(SCHEME-TO-INTERFACE)
215
216 */
217
218 #define INSTRUCTIONS *4 /* bytes/instruction */
219
220 /* The length of code sequence 1, above */
221 #define ENTRY_PREFIX_LENGTH (2 INSTRUCTIONS)
222
223 /* Compiled closures */
224
225 /* On the Alpha (byte offsets from start of closure):
226
227 -16: TC_MANIFEST_CLOSURE || length of object
228 -8 : count of entry points
229 -4 : Format word and GC offset
230 0 : SUBQ SP,#8,SP
231 +4 : BR or JMP instruction
232 +8 : absolute target address
233 +16: more entry points (i.e. repetitions from -8 through +8)
234 and/or closed variables
235 ...
236
237 Note: On other machines, there is a different format used for one
238 entry point closures and closures with more than one entry point.
239 This is not needed on the Alpha, because we have a "wasted" 32 bit
240 pad area in all closures.
241 */
242
243 #define CLOSURE_OFFSET_OF_FIRST_ENTRY_POINT 16
244 /* Bytes from manifest header to SUBQ in first entry point code */
245
246 /* A NOP on machines where closure entry points are aligned at object */
247 /* boundaries, as on the Alpha. */
248
249 #define ADJUST_CLOSURE_AT_CALL(entry_point, location) \
250 do { \
251 } while (0)
252
253 /* Manifest closure entry block size.
254 Size in bytes of a compiled closure's header excluding the
255 TC_MANIFEST_CLOSURE header.
256
257 On the Alpha this is 32 bits (one instruction) of padding, 16 bits
258 of format_word, 16 bits of GC offset word, 2 32-bit instructions
259 (SUBQ and JMP or BR), and a 64-bit absolute address.
260 */
261
262 #define COMPILED_CLOSURE_ENTRY_SIZE \
263 ((1 INSTRUCTIONS) + (2*(sizeof(format_word)) + \
264 (2 INSTRUCTIONS) + (sizeof(SCHEME_OBJECT *))))
265
266 /* Override the default definition of MANIFEST_CLOSURE_END in cmpgc.h */
267
268 #define MANIFEST_CLOSURE_END(start, count) \
269 (((SCHEME_OBJECT *) (start)) \
270 + (CHAR_TO_SCHEME_OBJECT (((count) * COMPILED_CLOSURE_ENTRY_SIZE))))
271
272 /* Manifest closure entry destructuring.
273
274 Given the entry point of a closure, extract the `real entry point'
275 (the address of the real code of the procedure, ie. one indirection)
276 from the closure.
277 */
278
279 #define EXTRACT_CLOSURE_ENTRY_ADDRESS(returned_address, entry_point) \
280 { EXTRACT_ABSOLUTE_ADDRESS (returned_address, \
281 (((unsigned int *) entry_point) + 1)); \
282 }
283
284 /* This is the inverse of EXTRACT_CLOSURE_ENTRY_ADDRESS.
285 Given a closure's entry point and a code entry point, store the
286 code entry point in the closure.
287 */
288
289 #define STORE_CLOSURE_ENTRY_ADDRESS(address_to_store, entry_point) \
290 { STORE_ABSOLUTE_ADDRESS (address_to_store, \
291 (((unsigned int *) entry_point) + 1)); \
292 }
293
294 /* Trampolines
295
296 On the Alpha, here's a picture of a trampoline (offset in bytes
297 from entry point)
298
299 -24: MANIFEST vector header
300 -16: NON_MARKED header
301 - 8: 0
302 - 4: Format word
303 - 2: 0xC (GC Offset to start of block from .+2)
304 Note the encoding -- divided by 2, low bit for
305 extended distances (see OFFSET_WORD_TO_BYTE_OFFSET)
306 0: BIS ZERO, #index, TRAMP_INDEX
307 4: JMP Utility_Argument_1, (SCHEME_TO_INTERFACE)
308 8: trampoline dependent storage (0 - 3 objects)
309
310 TRAMPOLINE_ENTRY_SIZE is the size in longwords of the machine
311 dependent portion of a trampoline, including the GC and format
312 headers. The code in the trampoline must store an index (used to
313 determine which C SCHEME_UTILITY procedure to invoke) in a
314 register, jump to "scheme_to_interface" and leave the address of
315 the storage following the code in a standard location.
316
317 TRAMPOLINE_ENTRY_POINT takes the address of the manifest vector
318 header of a trampoline and returns the address of its first
319 instruction.
320
321 TRAMPOLINE_STORAGE takes the address of the first instruction in a
322 trampoline (not the start of the trampoline block) and returns the
323 address of the first storage word in the trampoline.
324
325 STORE_TRAMPOLINE_ENTRY gets the address of the first instruction in
326 the trampoline and stores the instructions. It also receives the
327 index of the C SCHEME_UTILITY to be invoked.
328 */
329
330 #define TRAMPOLINE_ENTRY_SIZE 2
331 #define TRAMPOLINE_ENTRY_POINT(tramp) \
332 ((void *) (((SCHEME_OBJECT *) (tramp)) + 3))
333 #define TRAMPOLINE_STORAGE(tramp_entry) \
334 ((SCHEME_OBJECT *) (((char *) (tramp_entry)) + (2 INSTRUCTIONS)))
335
336 #define opBIS 0x11
337 #define opSUBQ 0x10
338 #define funcBIS 0x20
339 #define funcSUBQ 0x29
340
341 #define constantBIS(source, constant, target) \
342 ((opBIS << 26) | ((source) << 21) | \
343 ((constant) << 13) | (1 << 12) | (funcBIS << 5) | (target))
344
345 #define constantSUBQ(source, constant, target) \
346 ((opSUBQ << 26) | ((source) << 21) | \
347 ((constant) << 13) | (1 << 12) | (funcSUBQ << 5) | (target))
348
349 #define STORE_TRAMPOLINE_ENTRY(entry_address, index) \
350 { unsigned int *PC; \
351 extern void scheme_to_interface(void); \
352 PC = ((unsigned int *) (entry_address)); \
353 *PC++ = constantBIS(COMP_REG_ZERO, index, COMP_REG_TRAMP_INDEX);\
354 *PC = JMP(COMP_REG_FIRST_ARGUMENT, \
355 COMP_REG_SCHEME_INTERFACE, \
356 (((char *) scheme_to_interface) - \
357 ((char *) (PC+1)))); \
358 PC += 1; \
359 }
360
361 /* Execute cache entries.
362
363 Execute cache entry size in longwords. The cache itself
364 contains both the number of arguments provided by the caller and
365 code to jump to the destination address. Before linkage, the cache
366 contains the callee's name instead of the jump code.
367
368 On Alpha: 2 machine words (64 bits each).
369 */
370
371 #define EXECUTE_CACHE_ENTRY_SIZE 2
372
373 /* Execute cache destructuring. */
374
375 /* Given a target location and the address of the first word of an
376 execute cache entry, extract from the cache cell the number of
377 arguments supplied by the caller and store it in target. */
378
379 /* For the Alpha, addresses in bytes from the start of the cache:
380
381 Before linking
382 +0: number of supplied arguments, +1
383 +4: TC_FIXNUM | 0
384 +8: TC_SYMBOL || symbol address
385
386 After linking
387 +0: number of supplied arguments, +1
388 +4: BR or JMP instruction
389 +8: absolute target address
390 */
391
392 #define EXTRACT_EXECUTE_CACHE_ARITY(target, address) \
393 (target) = ((long) (((unsigned int *) (address)) [0]))
394
395 #define EXTRACT_EXECUTE_CACHE_SYMBOL(target, address) \
396 (target) = ((SCHEME_OBJECT *) (address))[1]
397
398 /* Extract the target address (not the code to get there) from an
399 execute cache cell.
400 */
401
402 #define EXTRACT_EXECUTE_CACHE_ADDRESS(target, address) \
403 { \
404 EXTRACT_ABSOLUTE_ADDRESS (target, (((unsigned int *)address)+1)); \
405 }
406
407 /* This is the inverse of EXTRACT_EXECUTE_CACHE_ADDRESS.
408 */
409
410 #define STORE_EXECUTE_CACHE_ADDRESS(address, entry) \
411 { \
412 STORE_ABSOLUTE_ADDRESS (entry, (((unsigned int *)address)+1)); \
413 }
414
415 /* This stores the fixed part of the instructions leaving the
416 destination address and the number of arguments intact. These are
417 split apart so the GC can call EXTRACT/STORE...ADDRESS but it does
418 NOT need to store the instructions back. On this architecture the
419 instructions may change due to GC and thus STORE_EXECUTE_CACHE_CODE
420 is a no-op; all of the work is done by STORE_EXECUTE_CACHE_ADDRESS
421 instead.
422 */
423
424 #define STORE_EXECUTE_CACHE_CODE(address) { }
425
426 /* This flushes the Scheme portion of the I-cache.
427 It is used after a GC or disk-restore.
428 It's needed because the GC has moved code around, and closures
429 and execute cache cells have absolute addresses that the
430 processor might have old copies of.
431 */
432
433 extern long Synchronize_Caches(void);
434 extern void Flush_I_Cache(void);
435
436 #if 1
437 #define FLUSH_I_CACHE() ((void) Synchronize_Caches())
438 #else
439 #define FLUSH_I_CACHE() (Flush_I_Cache())
440 #endif
441
442 /* This flushes a region of the I-cache.
443 It is used after updating an execute cache while running.
444 Not needed during GC because FLUSH_I_CACHE will be used.
445 */
446
447 #define FLUSH_I_CACHE_REGION(address, nwords) FLUSH_I_CACHE()
448 #define PUSH_D_CACHE_REGION(address, nwords) FLUSH_I_CACHE()
449 #define SPLIT_CACHES
450
451 #ifdef IN_CMPINT_C
452 #include <sys/mman.h>
453 #include <sys/types.h>
454
455 #define VM_PROT_SCHEME (PROT_READ | PROT_WRITE | PROT_EXEC)
456
457 #define ASM_RESET_HOOK() interface_initialize((void *) &utility_table[0])
458
459 #define REGBLOCK_EXTRA_SIZE 8 /* See lapgen.scm */
460 #define COMPILER_REGBLOCK_N_FIXED 16
461 #define REGBLOCK_FIRST_EXTRA COMPILER_REGBLOCK_N_FIXED
462 #define REGBLOCK_ADDRESS_OF_STACK_POINTER REGBLOCK_FIRST_EXTRA
463 #define REGBLOCK_ADDRESS_OF_FREE REGBLOCK_FIRST_EXTRA+1
464 #define REGBLOCK_ADDRESS_OF_UTILITY_TABLE REGBLOCK_FIRST_EXTRA+2
465 #define REGBLOCK_ALLOCATE_CLOSURE REGBLOCK_FIRST_EXTRA+3
466 #define REGBLOCK_DIVQ REGBLOCK_FIRST_EXTRA+4
467 #define REGBLOCK_REMQ REGBLOCK_FIRST_EXTRA+5
468 #define COMPILER_REGBLOCK_N_TEMPS 256
469
470 void *
alpha_heap_malloc(long Size)471 alpha_heap_malloc (long Size)
472 { int pagesize;
473 caddr_t Heap_Start_Page;
474 void *Area;
475
476 pagesize = getpagesize();
477 Area = (void *) malloc(Size+pagesize);
478 if (Area==NULL) return Area;
479 Heap_Start_Page =
480 ((caddr_t) (((((long) Area)+(pagesize-1)) /
481 pagesize) *
482 pagesize));
483 if (mprotect (Heap_Start_Page, Size, VM_PROT_SCHEME) == -1)
484 { perror("compiler_reset: unable to change protection for Heap");
485 fprintf(stderr, "mprotect(0x%lx, %d (0x%lx), 0x%lx)\n",
486 Heap_Start_Page, Size, Size, VM_PROT_SCHEME);
487 Microcode_Termination (TERM_EXIT);
488 /*NOTREACHED*/
489 }
490 return (void *) Heap_Start_Page;
491 }
492
493 /* ASSUMPTION: Direct mapped first level cache, with
494 shared secondary caches. Sizes in bytes.
495 */
496 #define DCACHE_SIZE (8*1024)
497 #define DCACHE_LINE_SIZE 32
498 #define WRITE_BUFFER_SIZE (4*DCACHE_LINE_SIZE)
499
500 long
Synchronize_Caches(void)501 Synchronize_Caches (void)
502 { long Foo=0;
503
504 Flush_I_Cache();
505 { static volatile long Fake_Out[WRITE_BUFFER_SIZE/(sizeof (long))];
506 volatile long *Ptr, *End, i=0;
507
508 for (End = &(Fake_Out[WRITE_BUFFER_SIZE/(sizeof (long))]),
509 Ptr = &(Fake_Out[0]);
510 Ptr < End;
511 Ptr += DCACHE_LINE_SIZE/(sizeof (long)))
512 { Foo += *Ptr;
513 *Ptr = Foo;
514 i += 1;
515 }
516 }
517 #if 0
518 { static volatile long Fake_Out[DCACHE_SIZE/(sizeof (long))];
519 volatile long *Ptr, *End;
520
521 for (End = &(Fake_Out[DCACHE_SIZE/(sizeof (long))]),
522 Ptr = &(Fake_Out[0]);
523 Ptr < End;
524 Ptr += DCACHE_LINE_SIZE/(sizeof (long)))
525 Foo += *Ptr;
526 }
527 #endif
528 return Foo;
529 }
530
531 extern char *allocate_closure(long, char *);
532
533 static void
interface_initialize(void * table)534 interface_initialize (void * table)
535 { extern void __divq();
536 extern void __remq();
537
538 Registers[REGBLOCK_ADDRESS_OF_STACK_POINTER] =
539 ((SCHEME_OBJECT) &stack_pointer);
540 Registers[REGBLOCK_ADDRESS_OF_FREE] =
541 ((SCHEME_OBJECT) &Free);
542 Registers[REGBLOCK_ADDRESS_OF_UTILITY_TABLE] =
543 ((SCHEME_OBJECT) table);
544 Registers[REGBLOCK_ALLOCATE_CLOSURE] =
545 ((SCHEME_OBJECT) allocate_closure);
546 Registers[REGBLOCK_DIVQ] = ((SCHEME_OBJECT) __divq);
547 Registers[REGBLOCK_REMQ] = ((SCHEME_OBJECT) __remq);
548 return;
549 }
550
551 #define CLOSURE_ENTRY_WORDS \
552 (COMPILED_CLOSURE_ENTRY_SIZE / (sizeof (SCHEME_OBJECT)))
553
554 static long closure_chunk = (1024 * CLOSURE_ENTRY_WORDS);
555 static long last_chunk_size;
556
557 char *
allocate_closure(long size,char * this_block)558 allocate_closure (long size, char *this_block)
559 /* size in Scheme objects of the block we need to allocate.
560 this_block is a pointer to the first entry point in the block we
561 didn't manage to allocate.
562 */
563 { long space;
564 SCHEME_OBJECT *free_closure, *limit;
565
566 free_closure = (SCHEME_OBJECT *)
567 (this_block-CLOSURE_OFFSET_OF_FIRST_ENTRY_POINT);
568 limit = GET_CLOSURE_SPACE;
569 space = limit - free_closure;
570 if (size > space)
571 { SCHEME_OBJECT *ptr;
572 unsigned int *wptr;
573 /* Clear remaining words from last chunk so that the heap can be scanned
574 forward.
575 */
576 if (space > 0)
577 { for (ptr = free_closure; ptr < limit; ptr++) *ptr = SHARP_F;
578 /* We can reformat the closures (from JMPs to BRs) using
579 last_chunk_size. The start of the area is
580 (limit - last_chunk_size), and all closures are contiguous
581 and have appropriate headers.
582 */
583 }
584 free_closure = Free;
585 if ((size <= closure_chunk) && (!GC_NEEDED_P (closure_chunk)))
586 { limit = (free_closure + closure_chunk);
587 }
588 else
589 { if (GC_NEEDED_P (size))
590 { if ((heap_end - Free) < size)
591 { /* No way to back out -- die. */
592 fprintf (stderr, "\nC_allocate_closure (%d): No space.\n", size);
593 Microcode_Termination (TERM_NO_SPACE);
594 /* NOTREACHED */
595 }
596 REQUEST_GC (0);
597 }
598 else if (size <= closure_chunk)
599 { REQUEST_GC (0);
600 }
601 limit = (free_closure + size);
602 }
603 Free = limit;
604 last_chunk_size = limit-free_closure; /* For next time, maybe. */
605 for (wptr = (unsigned int *) free_closure;
606 wptr < (unsigned int *) limit;)
607 { extern void scheme_closure_hook (void);
608 *wptr++ = constantSUBQ (COMP_REG_STACK_POINTER,
609 8,
610 COMP_REG_STACK_POINTER);
611 *wptr = JMP(COMP_REG_LINKAGE, COMP_REG_LONGJUMP,
612 (((char *) scheme_closure_hook) -
613 ((char *) (wptr + 1))));
614 wptr += 1;
615 }
616 PUSH_D_CACHE_REGION (free_closure, last_chunk_size);
617 SET_CLOSURE_SPACE (limit);
618 }
619 SET_CLOSURE_FREE (free_closure + size);
620 return (((char *) free_closure)+CLOSURE_OFFSET_OF_FIRST_ENTRY_POINT);
621 }
622 #endif /* IN_CMPINT_C */
623
624 /* Derived parameters and macros.
625
626 These macros expect the above definitions to be meaningful.
627 If they are not, the macros below may have to be changed as well.
628 */
629
630 #define COMPILED_ENTRY_OFFSET_WORD(entry) (((format_word *) (entry)) [-1])
631 #define COMPILED_ENTRY_FORMAT_WORD(entry) (((format_word *) (entry)) [-2])
632
633 /* The next one assumes 2's complement integers....*/
634 #define CLEAR_LOW_BIT(word) ((word) & ((unsigned long) -2))
635 #define OFFSET_WORD_CONTINUATION_P(word) (((word) & 1) != 0)
636
637 #define BYTE_OFFSET_TO_OFFSET_WORD(offset) ((offset) >> 1)
638 #define OFFSET_WORD_TO_BYTE_OFFSET(word) ((CLEAR_LOW_BIT (word)) << 1)
639
640 #define MAKE_OFFSET_WORD(entry, block, continue) \
641 ((BYTE_OFFSET_TO_OFFSET_WORD(((char *) (entry)) - \
642 ((char *) (block)))) | \
643 ((continue) ? 1 : 0))
644
645 #if (EXECUTE_CACHE_ENTRY_SIZE == 2)
646 #define EXECUTE_CACHE_COUNT_TO_ENTRIES(count) \
647 ((count) >> 1)
648 #define EXECUTE_CACHE_ENTRIES_TO_COUNT(entries) \
649 ((entries) << 1)
650 #endif
651
652 #if (EXECUTE_CACHE_ENTRY_SIZE == 4)
653 #define EXECUTE_CACHE_COUNT_TO_ENTRIES(count) \
654 ((count) >> 2)
655 #define EXECUTE_CACHE_ENTRIES_TO_COUNT(entries) \
656 ((entries) << 2)
657 #endif
658
659 #if (!defined(EXECUTE_CACHE_COUNT_TO_ENTRIES))
660 #define EXECUTE_CACHE_COUNT_TO_ENTRIES(count) \
661 ((count) / EXECUTE_CACHE_ENTRY_SIZE)
662 #define EXECUTE_CACHE_ENTRIES_TO_COUNT(entries) \
663 ((entries) * EXECUTE_CACHE_ENTRY_SIZE)
664 #endif
665
666 /* The first entry in a cc block is preceeded by 2 headers (block and nmv),
667 a format word and a gc offset word. See the early part of the
668 TRAMPOLINE picture, above.
669 */
670
671 #define CC_BLOCK_FIRST_ENTRY_OFFSET \
672 (2 * ((sizeof(SCHEME_OBJECT)) + (sizeof(format_word))))
673
674 /* Format words */
675
676 #define FORMAT_BYTE_EXPR 0xFF
677 #define FORMAT_BYTE_COMPLR 0xFE
678 #define FORMAT_BYTE_CMPINT 0xFD
679 #define FORMAT_BYTE_DLINK 0xFC
680 #define FORMAT_BYTE_RETURN 0xFB
681
682 #define FORMAT_WORD_EXPR (MAKE_FORMAT_WORD(0xFF, FORMAT_BYTE_EXPR))
683 #define FORMAT_WORD_CMPINT (MAKE_FORMAT_WORD(0xFF, FORMAT_BYTE_CMPINT))
684 #define FORMAT_WORD_RETURN (MAKE_FORMAT_WORD(0xFF, FORMAT_BYTE_RETURN))
685
686 /* This assumes that a format word is at least 16 bits,
687 and the low order field is always 8 bits.
688 */
689
690 #define MAKE_FORMAT_WORD(field1, field2) \
691 (((field1) << 8) | ((field2) & 0xff))
692
693 #define SIGN_EXTEND_FIELD(field, size) \
694 (((field) & ((1 << (size)) - 1)) | \
695 ((((field) & (1 << ((size) - 1))) == 0) ? 0 : \
696 ((-1) << (size))))
697
698 #define FORMAT_WORD_LOW_BYTE(word) \
699 (SIGN_EXTEND_FIELD ((((unsigned long) (word)) & 0xff), 8))
700
701 #define FORMAT_WORD_HIGH_BYTE(word) \
702 (SIGN_EXTEND_FIELD \
703 ((((unsigned long) (word)) >> 8), \
704 (((sizeof (format_word)) * CHAR_BIT) - 8)))
705
706 #define COMPILED_ENTRY_FORMAT_HIGH(addr) \
707 (FORMAT_WORD_HIGH_BYTE (COMPILED_ENTRY_FORMAT_WORD (addr)))
708
709 #define COMPILED_ENTRY_FORMAT_LOW(addr) \
710 (FORMAT_WORD_LOW_BYTE (COMPILED_ENTRY_FORMAT_WORD (addr)))
711
712 #define FORMAT_BYTE_FRAMEMAX 0x7f
713
714 #define COMPILED_ENTRY_MAXIMUM_ARITY COMPILED_ENTRY_FORMAT_LOW
715 #define COMPILED_ENTRY_MINIMUM_ARITY COMPILED_ENTRY_FORMAT_HIGH
716
717 #endif /* !SCM_CMPINTMD_H_INCLUDED */
718