Bug Summary

File:mem.c
Location:line 2161, column 11
Description:Value stored to 'subtype' is never read

Annotated Source Code

1/* File: "mem.c" */
2
3/* Copyright (c) 1994-2013 by Marc Feeley, All Rights Reserved. */
4
5#define ___INCLUDED_FROM_MEM
6#define ___VERSION407000 407000
7#include "gambit.h"
8
9#include "os_base.h"
10#include "os_time.h"
11#include "setup.h"
12#include "mem.h"
13#include "c_intf.h"
14
15/* The following includes are needed for debugging. */
16
17#include <stdlib.h>
18#include <string.h>
19
20/**********************************/
21#ifdef ___DEBUG
22#ifdef ___DEBUG_ALLOC_MEM_TRACE
23#define ___alloc_mem(bytes) ___alloc_mem_debug(bytes,__LINE__23,__FILE__"mem.c")
24#endif
25#endif
26
27
28/*---------------------------------------------------------------------------*/
29
30#ifdef ___DEBUG
31
32/*
33 * Defining the symbol ENABLE_CONSISTENCY_CHECKS will enable the GC to
34 * perform checks that detect when the heap is in an inconsistent
35 * state. This is useful to detect bugs in the GC and the rest of the
36 * system. To perform the consistency checks, the verbosity level in
37 * ___setup_params.debug_settings must be at least 1. The checks are
38 * very extensive and consequently are expensive. They should only be
39 * used for debugging.
40 */
41
42#define ENABLE_CONSISTENCY_CHECKS
43
44
45/*
46 * Defining the symbol GATHER_STATS will cause the GC to gather
47 * statistics on the objects it encounters in the heap.
48 */
49
50#define GATHER_STATS
51
52
53/*
54 * Defining the symbol SHOW_FRAMES will cause the GC to print out a
55 * trace of the continuation frames that are processed.
56 */
57
58#undef SHOW_FRAMES
59
60#endif
61
62
63/*---------------------------------------------------------------------------*/
64
65/*
66 * Object representation.
67 *
68 * Memory allocated Scheme objects can be allocated using one of three
69 * allocation strategies:
70 *
71 * Permanently allocated:
72 * These objects, called 'permanent objects' for short, are never
73 * moved or reclaimed, and all pointers to memory allocated
74 * objects they contain must point to permanent objects. As a
75 * consequence, the GC does not have to scan permanent objects.
76 * Permanent objects can be allocated on the C heap, but they are
77 * typically allocated in C global variables and structures that
78 * are set up when the program starts up or when a module is
79 * dynamically loaded.
80 *
81 * Still dynamically allocated:
82 * These objects, called 'still objects' for short, are allocated
83 * on the C heap. Still objects are never moved but they can be
84 * reclaimed by the GC. A mark-and-sweep GC is used to
85 * garbage-collect still objects.
86 *
87 * Movable dynamically allocated:
88 * These objects, called 'movable objects' for short, are allocated
89 * in an area of memory that is managed by a compacting GC. The GC
90 * can move and reclaim movable objects.
91 *
92 * Scheme objects are encoded using integers of type ___WORD. A
93 * ___WORD either encodes an immediate value or encodes a pointer
94 * when the object is memory allocated. The two lower bits of a
95 * ___WORD contain a primary type tag for the object and the other
96 * bits contain the immediate value or the pointer. Because all
97 * memory allocated objects are aligned on ___WORD boundaries (and a
98 * ___WORD is either 4 or 8 bytes), the two lower bits of pointers
99 * are zero and can be used to store the tag without reducing the
100 * address space. The four tags are:
101 *
102 * immediate:
103 * ___tFIXNUM object is a small integer (fixnum)
104 * ___tSPECIAL object is a boolean, character, or other immediate
105 *
106 * memory allocated:
107 * if ___USE_SAME_TAG_FOR_PAIRS_AND_SUBTYPED is defined
108 * ___tMEM1 = ___tSUBTYPED = ___tPAIR subtyped object, possibly a pair
109 * ___tMEM2 contained object, or a pair
110 * otherwise
111 * ___tMEM1 = ___tSUBTYPED subtyped object, but not a pair
112 * ___tMEM2 = ___tPAIR a pair
113 *
114 * A special type of object exists to support object finalization:
115 * 'will' objects. Wills contain a weak reference to an object, the
116 * testator and a strong reference to a procedure, the action
117 * procedure. A will becomes executable when its testator object is
118 * not strongly reachable (i.e. the testator object is either
119 * unreachable or only reachable using paths from the roots that
120 * traverse at least one weak reference). When the GC detects that a
121 * will has become executable it is placed on a list of executable
122 * wills. Following the GC, this list is traversed to invoke the
123 * action procedures.
124 *
125 * All memory allocated objects, including pairs, are composed of at
126 * least a head and a body. The head is a single ___WORD that
127 * contains 3 "head" tag bits (the 3 lower bits), a subtype tag (the
128 * next 5 bits), and the length of the object in bytes (the remaining
129 * bits). The head immediately precedes the body of the object, which
130 * contains the rest of the information associated with the object.
131 * Depending on the subtype, the body can contain raw binary data
132 * (such as when the object is a string) and Scheme objects (such as
133 * when the object is a vector). Memory allocated objects have the
134 * following layout:
135 *
136 * _head_ _____body______
137 * / \ / \
138 * +--------+--------+--------+
139 * |llllssst| | |
140 * +--------+--------+--------+
141 * ^ ^ ^
142 * | | |
143 * length | |
144 * subtype head tag
145 *
146 * Of the 8 possible head tags, only 5 are currently used:
147 *
148 * ___PERM (P) the object is a permanent object
149 * ___STILL (S) the object is a still object
150 * ___MOVABLE0 (M) the object is a movable object in generation 0
151 * ___FORW (F) the object has been moved by the GC (counts as 2 tags)
152 *
153 * Permanent objects have the following layout:
154 *
155 * _head_ _____body______
156 * / \ / \
157 * +--------+--------+--------+
158 * | P| | |
159 * +--------+--------+--------+
160 *
161 * Still objects have the following layout:
162 *
163 * _link_ _ref__ length _mark_ _head_ _____body______
164 * / \ / count\ / \ / \ / \ / \
165 * +--------+--------+--------+--------+--------+--------+--------+
166 * | | | | | S| | |
167 * +--------+--------+--------+--------+--------+--------+--------+
168 *
169 * All still objects are linked in a list using the 'link' field. The
170 * 'refcount' field contains a reference count, which counts the
171 * number of pointers to this object that are hidden from the GC
172 * (typically these hidden pointers are in C data structures). When
173 * 'refcount' is zero, the object will survive a GC only if it is
174 * pointed to by a GC root or a live Scheme object. The 'length'
175 * field contains the length of the object and is only used to
176 * maintain statistics on the space allocated. The 'mark' field is
177 * used by the GC to indicate that the object has been marked (at the
178 * start of a GC it is set to -1). The 'mark' field links all objects
179 * that have been marked but have not yet been scanned. It contains a
180 * pointer to the next still object that needs to be scanned.
181 *
182 * Movable objects have the following layout:
183 *
184 * _head_ _____body______
185 * / \ / \
186 * +--------+--------+--------+
187 * | M| | |
188 * +--------+--------+--------+
189 *
190 * When a movable object is moved by the GC, the head is replaced
191 * with a pointer to the copy, tagged with ___FORW.
192 *
193 * Layout of body.
194 *
195 * _head_ __________body__________
196 * / \ / \
197 * +--------+--------+--------+--------+
198 * | | field_0| field_1| etc. |
199 * +--------+--------+--------+--------+
200 *
201 * Some types of objects have bodies that only contain pointers to
202 * other Scheme objects. For example, pairs have two fields (car and
203 * cdr) and vectors have one field per element. Other object types
204 * have bodies that only contain raw binary data (such as strings and
205 * bignums). The remaining object types have bodies that contain both
206 * pointers to Scheme objects and raw binary data. Their layout is
207 * summarized below.
208 *
209 * Symbols:
210 * subtype = ___sSYMBOL
211 * field_0 = name (a Scheme string)
212 * field_1 = hash code (fixnum)
213 * field_2 = C pointer to global variable (0 if none allocated)
214 *
215 * Note: interned symbols must be permanently allocated;
216 * uninterned symbols can be permanent, still or movable
217 *
218 * Keywords:
219 * subtype = ___sKEYWORD
220 * field_0 = name (a Scheme string) not including the trailing ':'
221 * field_1 = hash code (fixnum)
222 *
223 * Procedures:
224 *
225 * nonclosures (toplevel procedures)
226 * subtype = ___sPROCEDURE (length contains parameter descriptor)
227 * field_0 = C pointer to field_0 - ___BODY_OFS
228 * field_1 = C pointer to label (only when using gcc)
229 * field_2 = C pointer to host C procedure
230 *
231 * closures:
232 * subtype = ___sPROCEDURE
233 * field_0 = C pointer to field_0 of entry procedure - ___BODY_OFS
234 * field_1 = free variable 1
235 * field_2 = free variable 2
236 * ...
237 *
238 * Note: the entry procedure must be a nonclosure procedure
239 *
240 * Return points:
241 * subtype = ___sPROCEDURE
242 * field_0 = return frame descriptor
243 * field_1 = C pointer to label (only when using gcc)
244 * field_2 = C pointer to host C procedure
245 *
246 * Wills:
247 * subtype = ___sWEAK
248 * field_0 = next will in list with special tag in lower bits
249 * field_1 = testator object
250 * field_2 = action procedure
251 *
252 * Note: wills must be movable
253 *
254 * GC hash tables:
255 * subtype = ___sWEAK
256 * field_0 = next GC hash table in list with special tag in lower bits
257 * field_1 = flags
258 * field_2 = count*2 (twice number of active key-value entries)
259 * field_3 = used*2 (twice number of total entries including deleted)
260 * field_4 = key of entry #0
261 * field_5 = value of entry #0
262 * ...
263 *
264 * Continuations:
265 * subtype = ___sCONTINUATION
266 * field_0 = first frame (C pointer to stack at first and then Scheme obj)
267 * field_1 = dynamic environment (#f when continuation is delimited)
268 *
269 * Frame:
270 * subtype = ___sFRAME
271 * field_0 = return address
272 * field_1 = frame slot 1
273 * field_2 = frame slot 2
274 * ...
275 */
276
277
278/*---------------------------------------------------------------------------*/
279
280/*
281 * Movable Scheme objects are allocated in an area of memory
282 * distributed in multiple noncontiguous sections (collectively
283 * called the "msections"). All sections are of the same size and are
284 * allocated through the '___alloc_mem' function. The number of
285 * sections can expand and contract to accommodate the needs of the
286 * program.
287 */
288
289typedef struct msect
290 {
291 int index; /* index in list of sections */
292 int pos; /* position in msections's 'sections' array */
293 ___WORDlong *alloc; /* heap allocation pointer, grows towards high addr. */
294 struct msect *prev; /* previous section in list of sections */
295 struct msect *next; /* next section in list of sections */
296 ___WORDlong base[1]; /* content of section */
297 } msection;
298
299#define sizeof_msection(n)(sizeof (msection) + ((n)-1) * 8) (sizeof (msection) + ((n)-1) * ___WS8)
300
301typedef struct
302 {
303 int max_nb_sections; /* actual size of 'sections' array */
304 int nb_sections; /* number of sections */
305 msection *head; /* head of doubly-linked list of sections */
306 msection *tail; /* tail of doubly-linked list of sections */
307 msection *sections[1]; /* each section ordered by address */
308 /* (increasing order if ___ALLOC_MEM_UP */
309 /* is defined otherwise decreasing order) */
310 } msections;
311
312#define sizeof_msections(n)(sizeof (msections) + ((n)-1) * sizeof (msection*)) (sizeof (msections) + ((n)-1) * sizeof (msection*))
313
314
315/* size of heap in words (number of words that can be occupied) */
316___HIDDENstatic ___SIZE_TSlong heap_size;
317
318/*
319 * 'normal_overflow_reserve' is the number of words reserved in the
320 * heap in normal circumstances for handling heap overflows.
321 */
322___HIDDENstatic ___SIZE_TSlong normal_overflow_reserve;
323
324/*
325 * 'overflow_reserve' is the number of words currently reserved in the
326 * heap for handling heap overflows. Initially 'overflow_reserve' is
327 * set to 'normal_overflow_reserve'. When a heap overflow occurs,
328 * some fraction of the 'overflow_reserve' is made available to the
329 * heap overflow handler. When a GC makes at least
330 * 'normal_overflow_reserve' free, then 'overflow_reserve' is reset to
331 * 'normal_overflow_reserve'.
332 */
333___HIDDENstatic ___SIZE_TSlong overflow_reserve;
334
335/* words occupied by nonmovable objects */
336___HIDDENstatic ___SIZE_TSlong words_nonmovable;
337
338/* words occupied in heap by movable objects excluding current msections */
339___HIDDENstatic ___SIZE_TSlong words_prev_msections;
340
341/* words occupied in heap by movable objects including current msections */
342#define WORDS_MOVABLE(2*(words_prev_msections + (alloc_stack_start - alloc_stack_ptr
) + (alloc_heap_ptr - alloc_heap_start)))
\
343(2*(words_prev_msections + \
344(alloc_stack_start - alloc_stack_ptr) + \
345(alloc_heap_ptr - alloc_heap_start)))
346
347/* words occupied in heap including current msections */
348#define WORDS_OCCUPIED(words_nonmovable + (2*(words_prev_msections + (alloc_stack_start
- alloc_stack_ptr) + (alloc_heap_ptr - alloc_heap_start))))
(words_nonmovable + WORDS_MOVABLE(2*(words_prev_msections + (alloc_stack_start - alloc_stack_ptr
) + (alloc_heap_ptr - alloc_heap_start)))
)
349
350/* words usable in msections */
351#define WORDS_MOVABLE_USABLE(2*the_msections->nb_sections*((long)(((131072>>1)-(
8192 +1+1)+1))))
\
352(2*the_msections->nb_sections*___CAST(___SIZE_TS,((___MSECTION_SIZE>>1)-___MSECTION_FUDGE+1))((long)(((131072>>1)-(8192 +1+1)+1))))
353
354/* words available in heap */
355#define WORDS_AVAILABLE(words_nonmovable + (2*the_msections->nb_sections*((long)(
((131072>>1)-(8192 +1+1)+1)))) - overflow_reserve - 2*(
8192 +1+1))
\
356(words_nonmovable + WORDS_MOVABLE_USABLE(2*the_msections->nb_sections*((long)(((131072>>1)-(
8192 +1+1)+1))))
- \
357overflow_reserve - 2*___MSECTION_FUDGE(8192 +1+1))
358
359/* list of still objects */
360___HIDDENstatic ___WORDlong still_objs;
361
362/* still objects remaining to scan */
363___HIDDENstatic ___WORDlong still_objs_to_scan;
364
365/* the msections */
366___HIDDENstatic msections *the_msections;
367
368/* location of tospace in each msection */
369___HIDDENstatic ___BOOLint tospace_at_top;
370
371/* number of msections used */
372___HIDDENstatic int nb_msections_used;
373
374/* last msection allocated */
375___HIDDENstatic msection *alloc_msection;
376
377/* msection where continuation frames are currently being allocated */
378___HIDDENstatic msection *stack_msection;
379
380/* start of allocation of continuation frames in stack_msection */
381___HIDDENstatic ___WORDlong *alloc_stack_start;
382
383/* allocation pointer for continuation frames in stack_msection */
384___HIDDENstatic ___WORDlong *alloc_stack_ptr;
385
386/* allocation limit for continuation frames in stack_msection */
387___HIDDENstatic ___WORDlong *alloc_stack_limit;
388
389/* msection where movable objects are currently being allocated */
390___HIDDENstatic msection *heap_msection;
391
392/* start of allocation of movable objects in heap_msection */
393___HIDDENstatic ___WORDlong *alloc_heap_start;
394
395/* allocation pointer for movable objects in heap_msection */
396___HIDDENstatic ___WORDlong *alloc_heap_ptr;
397
398/* allocation limit for movable objects in heap_msection */
399___HIDDENstatic ___WORDlong *alloc_heap_limit;
400
401/* msection currently being scanned */
402___HIDDENstatic msection *scan_msection;
403
404/* scan pointer in msection being scanned */
405___HIDDENstatic ___WORDlong *scan_ptr;
406
407/* indicates if weak references must be traversed */
408___HIDDENstatic ___BOOLint traverse_weak_refs;
409
410/* GC hash tables reached by GC */
411___HIDDENstatic ___WORDlong reached_gc_hash_tables;
412
413#ifdef CALL_GC_FREQUENTLY
414int ___gc_calls_to_punt = 2000; /* for GC stress test */
415#endif
416
417/*
418 * A given msection can be used for allocating movable objects, or for
419 * allocating continuation frames, or for both. The position of the
420 * various pointers is as follows.
421 *
422 * Msection only used for allocating movable objects:
423 *
424 * <-------------------------- ___MSECTION_SIZE/2 ------------------------->
425 * +----+----+---------------------------------------------------------------+
426 * |obj1|obj2| |<-___MSECTION_FUDGE->|
427 * +----+----+---------------------------------------------------------------+
428 * ^ ^ ^ ^
429 * | | | |
430 * | alloc_heap_ptr ___ps->heap_limit alloc_heap_limit
431 * alloc_heap_start
432 *
433 * Msection only used for allocating continuation frames:
434 *
435 * <-------------------------- ___MSECTION_SIZE/2 ------------------------->
436 * +-----------------------------------------------------------+------+------+
437 * |<-___MSECTION_FUDGE->| |frame2|frame1|
438 * +-----------------------------------------------------------+------+------+
439 * ^ ^ ^ ^
440 * | | | |
441 * alloc_stack_limit ___ps->stack_limit alloc_stack_ptr |
442 * alloc_stack_start
443 *
444 * Msection used for allocating movable objects and allocating
445 * continuation frames:
446 *
447 * <-------------------------- ___MSECTION_SIZE/2 ------------------------->
448 * +----+-------------------------------------------------------------+------+
449 * |objs| |<-___MSECTION_FUDGE->| O.R. |<-___MSECTION_FUDGE->| |frames|
450 * +----+-------------------------------------------------------------+------+
451 * ^ ^ ^ ^ ^ ^ ^ ^
452 * | | | | | | | |
453 * | | | alloc_heap_limit alloc_stack_limit | | |
454 * | | ___ps->heap_limit ___ps->stack_limit | |
455 * | alloc_heap_ptr alloc_stack_ptr |
456 * alloc_heap_start alloc_stack_start
457 */
458
459
460/*---------------------------------------------------------------------------*/
461
462/* Constants related to representation of permanent and still objects: */
463
464#ifdef ___USE_HANDLES
465#define ___PERM_HAND_OFS1 0
466#define ___PERM_BODY_OFS1 2
467#else
468#define ___PERM_HAND_OFS1 ___PERM_BODY_OFS1
469#define ___PERM_BODY_OFS1 1
470#endif
471
472#define ___STILL_LINK_OFS0 0
473#define ___STILL_REFCOUNT_OFS1 1
474#define ___STILL_LENGTH_OFS2 2
475#define ___STILL_MARK_OFS3 3
476#ifdef ___USE_HANDLES
477#define ___STILL_HAND_OFS(5+1) 4
478#define ___STILL_BODY_OFS(5+1) 6
479#else
480#define ___STILL_HAND_OFS(5+1) ___STILL_BODY_OFS(5+1)
481#define ___STILL_BODY_OFS(5+1) (5+1)/************/
482#endif
483
484
485/*---------------------------------------------------------------------------*/
486
487/* Allocation and reclamation of aligned blocks of memory. */
488
489
490/*
491 * 'alloc_mem_aligned (words, multiplier, modulus)' allocates an
492 * aligned block of memory through the '___alloc_mem' function.
493 * 'words' is the size of the block in words and 'multiplier' and
494 * 'modulus' specify its alignment in words. 'multiplier' must be a
495 * power of two and 0<=modulus<multiplier. The pointer returned
496 * corresponds to an address that is equal to
497 * (i*multiplier+modulus)*sizeof (___WORD) for some 'i'.
498 */
499
500___HIDDENstatic void *alloc_mem_aligned
501 ___P((___SIZE_TS words,(long words, unsigned int multiplier, unsigned int modulus)
502 unsigned int multiplier,(long words, unsigned int multiplier, unsigned int modulus)
503 unsigned int modulus),(long words, unsigned int multiplier, unsigned int modulus)
504 (words,(long words, unsigned int multiplier, unsigned int modulus)
505 multiplier,(long words, unsigned int multiplier, unsigned int modulus)
506 modulus)(long words, unsigned int multiplier, unsigned int modulus)
507___SIZE_TS words;(long words, unsigned int multiplier, unsigned int modulus)
508unsigned int multiplier;(long words, unsigned int multiplier, unsigned int modulus)
509unsigned int modulus;)(long words, unsigned int multiplier, unsigned int modulus)
510{
511 void *container; /* pointer to block returned by ___alloc_mem */
512 unsigned int extra; /* space for alignment to multiplier */
513
514 /* Make sure alignment is sufficient for pointers */
515
516 if (multiplier < sizeof (void*) / ___WS8)
517 multiplier = sizeof (void*) / ___WS8;
518
519 /* How many extra bytes are needed for padding */
520
521 extra = (multiplier * ___WS8) - 1;
522 if (modulus < sizeof (void*) / ___WS8)
523 extra += sizeof (void*);
524
525 container = ___alloc_mem (extra + (words+modulus) * ___WS8);
526
527 if (container == 0)
528 return 0;
529 else
530 {
531 void *ptr = ___CAST(void*,((void*)((((((long)(container)) + extra) & -((long)(multiplier
* 8))) + modulus * 8)))
532 (((___CAST(___WORD,container) + extra) &((void*)((((((long)(container)) + extra) & -((long)(multiplier
* 8))) + modulus * 8)))
533 -___CAST(___WORD,multiplier * ___WS)) +((void*)((((((long)(container)) + extra) & -((long)(multiplier
* 8))) + modulus * 8)))
534 modulus * ___WS))((void*)((((((long)(container)) + extra) & -((long)(multiplier
* 8))) + modulus * 8)))
;
535 void **cptr = ___CAST(void**,((void**)((((long)(ptr)) - ((long)(sizeof (void*)))) & -(
(long)(sizeof (void*)))))
536 (___CAST(___WORD,ptr) - ___CAST(___WORD,sizeof (void*))) &((void**)((((long)(ptr)) - ((long)(sizeof (void*)))) & -(
(long)(sizeof (void*)))))
537 -___CAST(___WORD,sizeof (void*)))((void**)((((long)(ptr)) - ((long)(sizeof (void*)))) & -(
(long)(sizeof (void*)))))
;
538
539 *cptr = container;
540 return ptr;
541 }
542}
543
544
545/*
546 * 'free_mem_aligned (ptr)' reclaims the aligned block of memory 'ptr'
547 * that was allocated using 'alloc_mem_aligned'.
548 */
549
550___HIDDENstatic void free_mem_aligned
551 ___P((void *ptr),(void *ptr)
552 (ptr)(void *ptr)
553void *ptr;)(void *ptr)
554{
555 void **cptr = ___CAST(void**,((void**)((((long)(ptr)) - ((long)(sizeof (void*)))) & -(
(long)(sizeof (void*)))))
556 (___CAST(___WORD,ptr) - ___CAST(___WORD,sizeof (void*))) &((void**)((((long)(ptr)) - ((long)(sizeof (void*)))) & -(
(long)(sizeof (void*)))))
557 -___CAST(___WORD,sizeof (void*)))((void**)((((long)(ptr)) - ((long)(sizeof (void*)))) & -(
(long)(sizeof (void*)))))
;
558 ___free_mem (*cptr);
559}
560
561
562/*---------------------------------------------------------------------------*/
563
564/* Allocation of reference counted blocks of memory. */
565
566typedef struct rc_header_struct
567 {
568 struct rc_header_struct *prev;
569 struct rc_header_struct *next;
570 ___SCMOBJlong refcount; /* integer but declared ___SCMOBJ for alignment */
571 ___SCMOBJlong data; /* needed for C closures */
572 } rc_header;
573
574
575___HIDDENstatic rc_header rc_head;
576
577
578___HIDDENstatic void setup_rc ___PVOID(void)
579{
580 rc_head.prev = &rc_head;
581 rc_head.next = &rc_head;
582 rc_head.refcount = 1;
583 rc_head.data = ___FAL((((long)(-1))<<2)+2);
584}
585
586___HIDDENstatic void cleanup_rc ___PVOID(void)
587{
588 rc_header *h = rc_head.next;
589
590 rc_head.prev = &rc_head;
591 rc_head.next = &rc_head;
592
593 while (h != &rc_head)
594 {
595 rc_header *next = h->next;
596 ___free_mem (h);
597 h = next;
598 }
599}
600
601
602___EXP_FUNC(void*,___alloc_rc)void* ___alloc_rc
603 ___P((___SIZE_T bytes),(unsigned long bytes)
604 (bytes)(unsigned long bytes)
605___SIZE_T bytes;)(unsigned long bytes)
606{
607 rc_header *h = ___CAST(rc_header*,((rc_header*)(___alloc_mem (bytes + sizeof (rc_header))))
608 ___alloc_mem (bytes + sizeof (rc_header)))((rc_header*)(___alloc_mem (bytes + sizeof (rc_header))));
609
610 if (h != 0)
611 {
612 rc_header *head = &rc_head;
613 rc_header *tail = head->prev;
614
615 h->prev = tail;
616 h->next = head;
617 head->prev = h;
618 tail->next = h;
619
620 h->refcount = 1;
621 h->data = ___FAL((((long)(-1))<<2)+2);
622
623 return ___CAST(void*,h+1)((void*)(h+1));
624 }
625
626 return 0;
627}
628
629
630___EXP_FUNC(void,___release_rc)void ___release_rc
631 ___P((void *ptr),(void *ptr)
632 (ptr)(void *ptr)
633void *ptr;)(void *ptr)
634{
635 if (ptr != 0)
636 {
637 rc_header *h = ___CAST(rc_header*,ptr)((rc_header*)(ptr)) - 1;
638
639 if (--h->refcount == 0)
640 {
641 rc_header *prev = h->prev;
642 rc_header *next = h->next;
643
644 next->prev = prev;
645 prev->next = next;
646
647 ___free_mem (h);
648 }
649 }
650}
651
652
653___EXP_FUNC(void,___addref_rc)void ___addref_rc
654 ___P((void *ptr),(void *ptr)
655 (ptr)(void *ptr)
656void *ptr;)(void *ptr)
657{
658 if (ptr != 0)
659 {
660 rc_header *h = ___CAST(rc_header*,ptr)((rc_header*)(ptr)) - 1;
661 h->refcount++;
662 }
663}
664
665
666___EXP_FUNC(___SCMOBJ,___data_rc)long ___data_rc
667 ___P((void *ptr),(void *ptr)
668 (ptr)(void *ptr)
669void *ptr;)(void *ptr)
670{
671 rc_header *h = ___CAST(rc_header*,ptr)((rc_header*)(ptr)) - 1;
672 return h->data;
673}
674
675
676___EXP_FUNC(void,___set_data_rc)void ___set_data_rc
677 ___P((void *ptr,(void *ptr, long val)
678 ___SCMOBJ val),(void *ptr, long val)
679 (ptr,(void *ptr, long val)
680 val)(void *ptr, long val)
681void *ptr;(void *ptr, long val)
682___SCMOBJ val;)(void *ptr, long val)
683{
684 rc_header *h = ___CAST(rc_header*,ptr)((rc_header*)(ptr)) - 1;
685 h->data = val;
686}
687
688
689/*---------------------------------------------------------------------------*/
690
691/* Allocation of movable objects. */
692
693/*
694 * 'find_msection (ms, ptr)' finds the position in the 'ms->sections'
695 * array of the msection that contains the pointer 'ptr'. More
696 * precisely, if ___ALLOC_MEM_UP is defined, it returns the integer
697 * 'i' (-1<=i<=n-1) such that 'ptr' is between the start of section i
698 * and section i+1. -1 is returned if 'ptr' is lower than the lowest
699 * section and 'n' is returned if 'ptr' is not lower than the highest
700 * section. If ___ALLOC_MEM_UP is not defined, it returns the integer
701 * 'i' (0<=i<=n) such that 'ptr' is between the start of section i and
702 * section i-1. n is returned if 'ptr' is lower than the lowest
703 * section and 0 is returned if 'ptr' is not lower than the highest
704 * section.
705 */
706
707___HIDDENstatic int find_msection
708 ___P((msections *ms,(msections *ms, void *ptr)
709 void *ptr),(msections *ms, void *ptr)
710 (ms,(msections *ms, void *ptr)
711 ptr)(msections *ms, void *ptr)
712msections *ms;(msections *ms, void *ptr)
713void *ptr;)(msections *ms, void *ptr)
714{
715 int ns = ms->nb_sections;
716 msection **sections = ms->sections;
717 int lo, hi;
718
719#ifdef ___ALLOC_MEM_UP
720 if (ns == 0 ||
721 ptr < ___CAST(void*,sections[0])((void*)(sections[0])))
722 return -1;
723#else
724 if (ns == 0 ||
725 ptr < ___CAST(void*,sections[ns-1])((void*)(sections[ns-1])))
726 return ns;
727#endif
728
729 /* binary search */
730
731 lo = 0;
732 hi = ns-1;
733
734 /* loop invariant: lo <= find_msection (ms, ptr) <= hi */
735
736 while (lo < hi)
737 {
738 int mid = (lo+hi) / 2; /* lo <= mid < hi */
739#ifdef ___ALLOC_MEM_UP
740 if (ptr < ___CAST(void*,sections[mid+1])((void*)(sections[mid+1]))) hi = mid; else lo = mid+1;
741#else
742 if (ptr < ___CAST(void*,sections[mid])((void*)(sections[mid]))) lo = mid+1; else hi = mid;
743#endif
744 }
745
746 return lo;
747}
748
749
750/*
751 * 'adjust_msections (msp, n)' contracts or expands the msections
752 * pointed to by 'msp' so that it contains 'n' sections. When the
753 * msections is contracted, the last sections allocated (i.e. those at
754 * the end of the doubly-linked list of sections) will be reclaimed.
755 * When expanding the msections there may not be enough memory to
756 * allocate new sections so the operation may fail. However
757 * 'adjust_msections' will always leave the msections in a consistent
758 * state and there will be at least as many sections as when the
759 * expansion was started. Failure can be detected by checking the
760 * 'nb_sections' field.
761 */
762
763___HIDDENstatic void adjust_msections
764 ___P((msections **msp,(msections **msp, int n)
765 int n),(msections **msp, int n)
766 (msp,(msections **msp, int n)
767 n)(msections **msp, int n)
768msections **msp;(msections **msp, int n)
769int n;)(msections **msp, int n)
770{
771 int max_ns, ns;
772 msections *ms = *msp;
773 msection *hd;
774 msection *tl;
775
776 if (ms == 0)
777 {
778 max_ns = 0;
779 ns = 0;
780 hd = 0;
781 tl = 0;
782 }
783 else
784 {
785 max_ns = ms->max_nb_sections;
786 ns = ms->nb_sections;
787 hd = ms->head;
788 tl = ms->tail;
789 }
790
791 if (ms == 0 || n > max_ns)
792 {
793 /* must allocate a new msections structure */
794
795 msections *new_ms;
796 int i;
797
798 while (n > max_ns) /* grow max_nb_sections until big enough */
799 max_ns = 2*max_ns + 1;
800
801 new_ms = ___CAST(msections*,((msections*)(alloc_mem_aligned (((((sizeof (msections) + ((max_ns
)-1) * sizeof (msection*)))+8 -1)>>3), 1, 0)))
802 alloc_mem_aligned((msections*)(alloc_mem_aligned (((((sizeof (msections) + ((max_ns
)-1) * sizeof (msection*)))+8 -1)>>3), 1, 0)))
803 (___WORDS(sizeof_msections(max_ns)),((msections*)(alloc_mem_aligned (((((sizeof (msections) + ((max_ns
)-1) * sizeof (msection*)))+8 -1)>>3), 1, 0)))
804 1,((msections*)(alloc_mem_aligned (((((sizeof (msections) + ((max_ns
)-1) * sizeof (msection*)))+8 -1)>>3), 1, 0)))
805 0))((msections*)(alloc_mem_aligned (((((sizeof (msections) + ((max_ns
)-1) * sizeof (msection*)))+8 -1)>>3), 1, 0)))
;
806
807 if (new_ms == 0)
808 return;
809
810 new_ms->max_nb_sections = max_ns;
811 new_ms->nb_sections = ns;
812 new_ms->head = hd;
813 new_ms->tail = tl;
814
815 for (i=ns-1; i>=0; i--)
816 new_ms->sections[i] = ms->sections[i];
817
818 if (ms != 0)
819 free_mem_aligned (ms);
820
821 ms = new_ms;
822
823 *msp = ms;
824 }
825
826 if (n < ns)
827 {
828 /* contraction of the msections */
829
830 int j;
831
832 while (ns > n)
833 {
834 msection *s = tl;
835
836 tl = tl->prev;
837
838 if (tl == 0)
839 hd = 0;
840 else
841 tl->next = 0;
842
843 for (j=s->pos; j<ns-1; j++)
844 {
845 ms->sections[j] = ms->sections[j+1];
846 ms->sections[j]->pos = j;
847 }
848
849 free_mem_aligned (s);
850
851 ns--;
852 }
853
854 ms->nb_sections = ns;
855 ms->head = hd;
856 ms->tail = tl;
857
858 /*
859 * Contraction of the msections structure is not performed
860 * because there is typically very little memory to be
861 * reclaimed.
862 */
863 }
864 else
865 {
866 /* expansion of the msections */
867
868 int i, j;
869
870 while (ns < n)
871 {
872 msection *s = ___CAST(msection*,((msection*)(alloc_mem_aligned (((((sizeof (msection) + ((131072
)-1) * 8))+8 -1)>>3), 1, 0)))
873 alloc_mem_aligned((msection*)(alloc_mem_aligned (((((sizeof (msection) + ((131072
)-1) * 8))+8 -1)>>3), 1, 0)))
874 (___WORDS(sizeof_msection(___MSECTION_SIZE)),((msection*)(alloc_mem_aligned (((((sizeof (msection) + ((131072
)-1) * 8))+8 -1)>>3), 1, 0)))
875 1,((msection*)(alloc_mem_aligned (((((sizeof (msection) + ((131072
)-1) * 8))+8 -1)>>3), 1, 0)))
876 0))((msection*)(alloc_mem_aligned (((((sizeof (msection) + ((131072
)-1) * 8))+8 -1)>>3), 1, 0)))
;
877
878 if (s == 0)
879 return;
880
881 i = find_msection (ms, ___CAST(void*,s)((void*)(s)));
882
883#ifdef ___ALLOC_MEM_UP
884 i++;
885#endif
886
887 for (j=ns; j>i; j--)
888 {
889 ms->sections[j] = ms->sections[j-1];
890 ms->sections[j]->pos = j;
891 }
892
893 ms->sections[i] = s;
894
895 if (tl == 0)
896 {
897 hd = s;
898 s->index = 0;
899 }
900 else
901 {
902 tl->next = s;
903 s->index = tl->index + 1;
904 }
905
906 s->pos = i;
907 s->prev = tl;
908 s->next = 0;
909
910 tl = s;
911
912 ms->nb_sections = ++ns;
913 ms->head = hd;
914 ms->tail = tl;
915 }
916 }
917}
918
919
920/*
921 * 'free_msections (msp)' releases all memory associated with the
922 * msections pointed to by 'msp'.
923 */
924
925___HIDDENstatic void free_msections
926 ___P((msections **msp),(msections **msp)
927 (msp)(msections **msp)
928msections **msp;)(msections **msp)
929{
930 msections *ms = *msp;
931
932 if (ms != 0)
933 {
934 int i;
935
936 for (i=ms->nb_sections-1; i>=0; i--)
937 free_mem_aligned (ms->sections[i]);
938
939 free_mem_aligned (ms);
940
941 *msp = 0;
942 }
943}
944
945
946/*---------------------------------------------------------------------------*/
947
948/* Allocation of permanent objects. */
949
950/*
951 * Permanent objects are allocated in sections called "psections".
952 * Each section contains multiple objects. The sections are kept in a
953 * list so that the storage they occupy can be reclaimed when the
954 * program terminates.
955 */
956
957___HIDDENstatic void *psections; /* list of psections */
958___HIDDENstatic ___WORDlong *palloc_ptr; /* allocation pointer in current psection */
959___HIDDENstatic ___WORDlong *palloc_limit; /* allocation limit in current psection */
960
961
962/*
963 * 'alloc_mem_aligned_psection (words, multiplier, modulus)' allocates
964 * an aligned block of memory inside a new psection. 'words' is the
965 * size of the block in words and 'multiplier' and 'modulus' specify
966 * its alignment in words. 'multiplier' must be a power of two and
967 * 0<=modulus<multiplier. The pointer returned corresponds to an
968 * address that is equal to (i*multiplier+modulus)*sizeof (___WORD) for
969 * some 'i'.
970 */
971
972___HIDDENstatic void *alloc_mem_aligned_psection
973 ___P((___SIZE_TS words,(long words, unsigned int multiplier, unsigned int modulus)
974 unsigned int multiplier,(long words, unsigned int multiplier, unsigned int modulus)
975 unsigned int modulus),(long words, unsigned int multiplier, unsigned int modulus)
976 (words,(long words, unsigned int multiplier, unsigned int modulus)
977 multiplier,(long words, unsigned int multiplier, unsigned int modulus)
978 modulus)(long words, unsigned int multiplier, unsigned int modulus)
979___SIZE_TS words;(long words, unsigned int multiplier, unsigned int modulus)
980unsigned int multiplier;(long words, unsigned int multiplier, unsigned int modulus)
981unsigned int modulus;)(long words, unsigned int multiplier, unsigned int modulus)
982{
983 void *container;
984
985 /* Make sure alignment is sufficient for pointers */
986
987 if (multiplier < sizeof (void*) / ___WS8)
988 multiplier = sizeof (void*) / ___WS8;
989
990 /* Make space for psection link and modulus */
991
992 if (modulus < (sizeof (void*) + ___WS8 - 1) / ___WS8)
993 modulus += ((sizeof (void*) + multiplier * ___WS8 - 1) / ___WS8) &
994 -multiplier;
995
996 /* Allocate container */
997
998 container = alloc_mem_aligned (words+modulus, multiplier, 0);
999
1000 if (container == 0)
1001 return 0;
1002
1003 *___CAST(void**,container)((void**)(container)) = psections;
1004 psections = container;
1005 return ___CAST(void*,___CAST(___WORD*,container) + modulus)((void*)(((long*)(container)) + modulus));
1006}
1007
1008
1009/*
1010 * 'alloc_mem_aligned_perm (words, multiplier, modulus)' allocates an
1011 * aligned block of memory inside a psection. If there is enough free
1012 * space in a previously allocated psection that psection is used,
1013 * otherwise a new psection is allocated. 'words' is the size of the
1014 * block in words and 'multiplier' and 'modulus' specify its alignment
1015 * in words. 'multiplier' must be a power of two and
1016 * 0<=modulus<multiplier. The pointer returned corresponds to an
1017 * address that is equal to (i*multiplier+modulus)*sizeof (___WORD) for
1018 * some 'i'.
1019 */
1020
1021___HIDDENstatic void *alloc_mem_aligned_perm
1022 ___P((___SIZE_TS words,(long words, int multiplier, int modulus)
1023 int multiplier,(long words, int multiplier, int modulus)
1024 int modulus),(long words, int multiplier, int modulus)
1025 (words,(long words, int multiplier, int modulus)
1026 multiplier,(long words, int multiplier, int modulus)
1027 modulus)(long words, int multiplier, int modulus)
1028___SIZE_TS words;(long words, int multiplier, int modulus)
1029int multiplier;(long words, int multiplier, int modulus)
1030int modulus;)(long words, int multiplier, int modulus)
1031{
1032 ___SIZE_TSlong waste;
1033 ___WORDlong *base;
1034
1035 /*
1036 * Try to satisfy request in current psection.
1037 */
1038
1039 if (palloc_ptr != 0)
1040 {
1041 ___WORDlong *new_palloc_ptr;
1042
1043 base = ___CAST(___WORD*,((long*)(((long)(palloc_ptr+multiplier-1-modulus)) & (multiplier
* -8)))
1044 ___CAST(___WORD,palloc_ptr+multiplier-1-modulus) &((long*)(((long)(palloc_ptr+multiplier-1-modulus)) & (multiplier
* -8)))
1045 (multiplier * -___WS))((long*)(((long)(palloc_ptr+multiplier-1-modulus)) & (multiplier
* -8)))
+
1046 modulus;
1047
1048 new_palloc_ptr = base + words;
1049
1050 if (new_palloc_ptr <= palloc_limit) /* did it fit in the psection? */
1051 {
1052 palloc_ptr = new_palloc_ptr;
1053 return base;
1054 }
1055
1056 waste = palloc_limit - palloc_ptr;
1057 }
1058 else
1059 waste = 0;
1060
1061 /*
1062 * Request can't be satisfied in current psection so we must
1063 * allocate a new psection.
1064 */
1065
1066 if (waste > ___PSECTION_WASTE32 || words > ___PSECTION_SIZE4096)
1067 return alloc_mem_aligned_psection (words, multiplier, modulus);
1068
1069 base = ___CAST(___WORD*,((long*)(alloc_mem_aligned_psection (4096, multiplier, modulus
)))
1070 alloc_mem_aligned_psection((long*)(alloc_mem_aligned_psection (4096, multiplier, modulus
)))
1071 (___PSECTION_SIZE,((long*)(alloc_mem_aligned_psection (4096, multiplier, modulus
)))
1072 multiplier,((long*)(alloc_mem_aligned_psection (4096, multiplier, modulus
)))
1073 modulus))((long*)(alloc_mem_aligned_psection (4096, multiplier, modulus
)))
;
1074
1075 if (base != 0)
1076 {
1077 palloc_ptr = base + words;
1078 palloc_limit = base + ___PSECTION_SIZE4096;
1079 }
1080
1081 return base;
1082}
1083
1084
1085___HIDDENstatic void free_psections ___PVOID(void)
1086{
1087 void *base = psections;
1088
1089 psections = 0;
1090
1091 while (base != 0)
1092 {
1093 void *link = *___CAST(void**,base)((void**)(base));
1094 free_mem_aligned (base);
1095 base = link;
1096 }
1097}
1098
1099
1100___SCMOBJlong ___alloc_global_var
1101 ___P((___glo_struct **glo),(___glo_struct **glo)
1102 (glo)(___glo_struct **glo)
1103___glo_struct **glo;)(___glo_struct **glo)
1104{
1105 ___glo_struct *p = ___CAST(___glo_struct*,((___glo_struct*)(alloc_mem_aligned_perm ((((sizeof (___glo_struct
))+8 -1)>>3), 1, 0)))
1106 alloc_mem_aligned_perm((___glo_struct*)(alloc_mem_aligned_perm ((((sizeof (___glo_struct
))+8 -1)>>3), 1, 0)))
1107 (___WORDS(sizeof (___glo_struct)),((___glo_struct*)(alloc_mem_aligned_perm ((((sizeof (___glo_struct
))+8 -1)>>3), 1, 0)))
1108 1,((___glo_struct*)(alloc_mem_aligned_perm ((((sizeof (___glo_struct
))+8 -1)>>3), 1, 0)))
1109 0))((___glo_struct*)(alloc_mem_aligned_perm ((((sizeof (___glo_struct
))+8 -1)>>3), 1, 0)))
;
1110 if (p == 0)
1111 return ___FIX(___HEAP_OVERFLOW_ERR)(((long)((((((int)(-1))<<29)+(((int)(448))<<16)+(
0))+5)))<<2)
;
1112 *glo = p;
1113 return ___FIX(___NO_ERR)(((long)(0))<<2);
1114}
1115
1116
1117/*---------------------------------------------------------------------------*/
1118
1119/*
1120 * '___still_obj_refcount_inc (obj)' increments the reference count of
1121 * the still object 'obj'.
1122 */
1123
1124___EXP_FUNC(void,___still_obj_refcount_inc)void ___still_obj_refcount_inc
1125 ___P((___WORD obj),(long obj)
1126 (obj)(long obj)
1127___WORD obj;)(long obj)
1128{
1129 ___UNTAG(obj)((long*)((obj)&-(1<<2)))[___BODY_OFS1 - ___STILL_BODY_OFS(5+1) + ___STILL_REFCOUNT_OFS1]++;
1130}
1131
1132
1133/*
1134 * '___still_obj_refcount_dec (obj)' decrements the reference count of
1135 * the still object 'obj'.
1136 */
1137
1138___EXP_FUNC(void,___still_obj_refcount_dec)void ___still_obj_refcount_dec
1139 ___P((___WORD obj),(long obj)
1140 (obj)(long obj)
1141___WORD obj;)(long obj)
1142{
1143 ___UNTAG(obj)((long*)((obj)&-(1<<2)))[___BODY_OFS1 - ___STILL_BODY_OFS(5+1) + ___STILL_REFCOUNT_OFS1]--;
1144}
1145
1146
1147/*---------------------------------------------------------------------------*/
1148
1149/*
1150 * '___alloc_scmobj (subtype, bytes, kind)' allocates a permanent or
1151 * still Scheme object (depending on 'kind') of subtype 'subtype' with
1152 * a body containing 'bytes' bytes, and returns it as an encoded
1153 * Scheme object. A permanent object is allocated when 'kind' =
1154 * ___PERM and a still object is allocated when 'kind' = ___STILL.
1155 * The initialization of the object's body must be done by the caller.
1156 * In the case of still objects this initialization must be done
1157 * before the next allocation is requested. The 'refcount' field of
1158 * still objects is initially 1. A fixnum error code is returned when
1159 * there is an error.
1160 */
1161
1162___EXP_FUNC(___WORD,___alloc_scmobj)long ___alloc_scmobj
1163 ___P((int subtype,(int subtype, long bytes, int kind)
1164 ___SIZE_TS bytes,(int subtype, long bytes, int kind)
1165 int kind),(int subtype, long bytes, int kind)
1166 (subtype,(int subtype, long bytes, int kind)
1167 bytes,(int subtype, long bytes, int kind)
1168 kind)(int subtype, long bytes, int kind)
1169int subtype;(int subtype, long bytes, int kind)
1170___SIZE_TS bytes;(int subtype, long bytes, int kind)
1171int kind;)(int subtype, long bytes, int kind)
1172{
1173 void *ptr;
1174 ___processor_state ___ps = ___PSTATE(&(&___gstate)->pstate);
1175 ___SIZE_TSlong words = (kind==___PERM6 ? ___PERM_BODY_OFS1 : ___STILL_BODY_OFS(5+1))
1176 + ___WORDS(bytes)(((bytes)+8 -1)>>3);
1177
1178 alloc_stack_ptr = ___ps->fp; /* needed by 'WORDS_OCCUPIED' */
1179 alloc_heap_ptr = ___ps->hp; /* needed by 'WORDS_OCCUPIED' */
1180
1181 if (kind != ___PERM6)
1182 {
1183 /*
1184 * Account for words allocated only for non-permanent objects.
1185 */
1186
1187 words_nonmovable += words;
1188
1189 if (WORDS_OCCUPIED(words_nonmovable + (2*(words_prev_msections + (alloc_stack_start
- alloc_stack_ptr) + (alloc_heap_ptr - alloc_heap_start))))
> heap_size
1190#ifdef CALL_GC_FREQUENTLY
1191 || --___gc_calls_to_punt < 0
1192#endif
1193 )
1194 {
1195 ___BOOLint overflow;
1196
1197 words_nonmovable -= words;
1198
1199 overflow = ___garbage_collect (words);
1200
1201 words_nonmovable += words;
1202
1203 alloc_stack_ptr = ___ps->fp; /* needed by 'WORDS_OCCUPIED' */
1204 alloc_heap_ptr = ___ps->hp; /* needed by 'WORDS_OCCUPIED' */
1205
1206 if (overflow || WORDS_OCCUPIED(words_nonmovable + (2*(words_prev_msections + (alloc_stack_start
- alloc_stack_ptr) + (alloc_heap_ptr - alloc_heap_start))))
> heap_size)
1207 {
1208 words_nonmovable -= words;
1209 return ___FIX(___HEAP_OVERFLOW_ERR)(((long)((((((int)(-1))<<29)+(((int)(448))<<16)+(
0))+5)))<<2)
;
1210 }
1211 }
1212 }
1213
1214 /*
1215 * Some objects, such as ___sFOREIGN, ___sS64VECTOR, ___sU64VECTOR,
1216 * ___sF64VECTOR, ___sFLONUM and ___sBIGNUM, must have a body that
1217 * is aligned on a multiple of 8 on some machines. Here, we force
1218 * alignment to a multiple of 8 even if not necessary in all cases
1219 * because it is typically more efficient due to a better
1220 * utilization of the cache.
1221 */
1222
1223 if (kind == ___PERM6)
1224 ptr = alloc_mem_aligned_perm (words,
1225 8>>___LWS3,
1226 (-___PERM_BODY_OFS1)&((8>>___LWS3)-1));
1227 else
1228 ptr = alloc_mem_aligned (words,
1229 8>>___LWS3,
1230 (-___STILL_BODY_OFS(5+1))&((8>>___LWS3)-1));
1231
1232 if (ptr == 0)
1233 {
1234 if (kind != ___PERM6)
1235 words_nonmovable -= words;
1236 return ___FIX(___HEAP_OVERFLOW_ERR)(((long)((((((int)(-1))<<29)+(((int)(448))<<16)+(
0))+5)))<<2)
;
1237 }
1238 else if (kind == ___PERM6)
1239 {
1240 ___WORDlong *base = ___CAST(___WORD*,ptr)((long*)(ptr));
1241
1242#ifdef ___USE_HANDLES
1243 base[___PERM_HAND_OFS1] = ___CAST(___WORD,base+___PERM_BODY_OFS-___BODY_OFS)((long)(base+1 -1));
1244#endif
1245 base[___PERM_BODY_OFS1-1] = ___MAKE_HD(bytes, subtype, ___PERM)(((bytes)<<(3 +5))+((subtype)<<3)+(6));
1246
1247 return ___TAG((base + ___PERM_HAND_OFS - ___BODY_OFS), (subtype == ___sPAIR ? ___tPAIR : ___tSUBTYPED))(((long)((base + 1 - 1)))+((subtype == 1 ? 3 : 1)));
1248 }
1249 else
1250 {
1251 ___WORDlong *base = ___CAST(___WORD*,ptr)((long*)(ptr));
1252
1253 base[___STILL_LINK_OFS0] = still_objs;
1254 still_objs = ___CAST(___WORD,base)((long)(base));
1255 base[___STILL_REFCOUNT_OFS1] = 1;
1256 base[___STILL_LENGTH_OFS2] = words;
1257#ifdef ___USE_HANDLES
1258 base[___STILL_HAND_OFS(5+1)] = ___CAST(___WORD,base+___STILL_BODY_OFS-___BODY_OFS)((long)(base+(5+1)-1));
1259#endif
1260 base[___STILL_BODY_OFS(5+1)-1] = ___MAKE_HD(bytes, subtype, ___STILL)(((bytes)<<(3 +5))+((subtype)<<3)+(5));
1261
1262 return ___TAG((base + ___STILL_HAND_OFS - ___BODY_OFS), (subtype == ___sPAIR ? ___tPAIR : ___tSUBTYPED))(((long)((base + (5+1) - 1)))+((subtype == 1 ? 3 : 1)));
1263 }
1264}
1265
1266
1267___EXP_FUNC(void,___release_scmobj)void ___release_scmobj
1268 ___P((___WORD obj),(long obj)
1269 (obj)(long obj)
1270___WORD obj;)(long obj)
1271{
1272 if (___MEM_ALLOCATED(obj)((obj)&1) &&
1273 ___HD_TYP(___BODY(obj)[-1])(((((long*)((obj)&-(1<<2)))+1)[-1])&((1<<
3)-1))
== ___STILL5)
1274 ___still_obj_refcount_dec (obj);
1275}
1276
1277
1278/*
1279 * '___make_pair (car, cdr, kind)' creates a Scheme pair having the
1280 * values 'car' and 'cdr' in its CAR and CDR fields. The 'car' and
1281 * 'cdr' arguments must not be movable objects and any still object
1282 * must be reachable some other way or have a nonzero refcount. A
1283 * permanent or still object is allocated, depending on 'kind'
1284 * (___PERM for permanent object, ___STILL for still object). A
1285 * fixnum error code is returned when there is an error.
1286 */
1287
1288___EXP_FUNC(___WORD,___make_pair)long ___make_pair
1289 ___P((___WORD car,(long car, long cdr, int kind)
1290 ___WORD cdr,(long car, long cdr, int kind)
1291 int kind),(long car, long cdr, int kind)
1292 (car,(long car, long cdr, int kind)
1293 cdr,(long car, long cdr, int kind)
1294 kind)(long car, long cdr, int kind)
1295___WORD car;(long car, long cdr, int kind)
1296___WORD cdr;(long car, long cdr, int kind)
1297int kind;)(long car, long cdr, int kind)
1298{
1299 ___WORDlong obj = ___alloc_scmobj (___sPAIR1, ___PAIR_SIZE2<<___LWS3, kind);
1300
1301 if (!___FIXNUMP(obj)(((obj)&((1<<2)-1))==(0)))
1302 {
1303 ___PAIR_CAR(obj)(*((((long*)((obj)-(3)))+1)+1)) = car;
1304 ___PAIR_CDR(obj)(*((((long*)((obj)-(3)))+1)+0)) = cdr;
1305 }
1306
1307 return obj;
1308}
1309
1310
1311/*
1312 * '___make_vector (length, init, kind)' creates a Scheme vector of
1313 * length 'length' and initialized with the value 'init'. The 'init'
1314 * argument must not be a movable object and if it is a still object
1315 * it must be reachable some other way or have a nonzero refcount. A
1316 * permanent or still object is allocated, depending on 'kind'
1317 * (___PERM for permanent object, ___STILL for still object). A
1318 * fixnum error code is returned when there is an error.
1319 */
1320
1321___EXP_FUNC(___WORD,___make_vector)long ___make_vector
1322 ___P((___SIZE_TS length,(long length, long init, int kind)
1323 ___WORD init,(long length, long init, int kind)
1324 int kind),(long length, long init, int kind)
1325 (length,(long length, long init, int kind)
1326 init,(long length, long init, int kind)
1327 kind)(long length, long init, int kind)
1328___SIZE_TS length;(long length, long init, int kind)
1329___WORD init;(long length, long init, int kind)
1330int kind;)(long length, long init, int kind)
1331{
1332 if (length > ___CAST(___WORD,___LMASK >> (___LF+___LWS))((long)((~((unsigned long)(0))<<(3 +5)) >> ((3 +5
)+3)))
)
1333 return ___FIX(___HEAP_OVERFLOW_ERR)(((long)((((((int)(-1))<<29)+(((int)(448))<<16)+(
0))+5)))<<2)
;
1334 else
1335 {
1336 ___WORDlong obj = ___alloc_scmobj (___sVECTOR0, length<<___LWS3, kind);
1337
1338 if (!___FIXNUMP(obj)(((obj)&((1<<2)-1))==(0)))
1339 {
1340 int i;
1341 for (i=0; i<length; i++)
1342 ___FIELD(obj, i)(*((((long*)((obj)-(1)))+1)+i)) = init;
1343 }
1344
1345 return obj;
1346 }
1347}
1348
1349
1350/*---------------------------------------------------------------------------*/
1351
1352___HIDDENstatic ___WORDlong *start_of_fromspace
1353 ___P((msection *s),(msection *s)
1354 (s)(msection *s)
1355msection *s;)(msection *s)
1356{
1357 if (tospace_at_top)
1358 return s->base;
1359 else
1360 return s->base + (___MSECTION_SIZE131072>>1);
1361}
1362
1363
1364___HIDDENstatic ___WORDlong *start_of_tospace
1365 ___P((msection *s),(msection *s)
1366 (s)(msection *s)
1367msection *s;)(msection *s)
1368{
1369 if (tospace_at_top)
1370 return s->base + (___MSECTION_SIZE131072>>1);
1371 else
1372 return s->base;
1373}
1374
1375
1376___HIDDENstatic void fatal_heap_overflow ___PVOID(void)
1377{
1378 char *msgs[2];
1379 msgs[0] = "Heap overflow";
1380 msgs[1] = 0;
1381 ___fatal_error (msgs);
1382}
1383
1384
1385___HIDDENstatic msection *next_msection
1386 ___P((msection *ms),(msection *ms)
1387 (ms)(msection *ms)
1388msection *ms;)(msection *ms)
1389{
1390 msection *result;
1391
1392 if (nb_msections_used == 0)
1393 result = the_msections->head;
1394 else
1395 result = alloc_msection->next;
1396
1397 if (result == 0)
1398 {
1399 if (stack_msection == heap_msection)
1400 fatal_heap_overflow ();
1401 result = ms;
1402 }
1403 else
1404 {
1405 alloc_msection = result;
1406 nb_msections_used++;
1407 }
1408
1409 return result;
1410}
1411
1412
1413___HIDDENstatic void next_stack_msection ___PVOID(void)
1414{
1415 if (stack_msection != 0)
1416 words_prev_msections += alloc_stack_start - alloc_stack_ptr;
1417
1418 stack_msection = next_msection (heap_msection);
1419 alloc_stack_limit = start_of_tospace (stack_msection);
1420 alloc_stack_start = alloc_stack_limit + (___MSECTION_SIZE131072>>1);
1421 alloc_stack_ptr = alloc_stack_start;
1422}
1423
1424
1425___HIDDENstatic void next_heap_msection ___PVOID(void)
1426{
1427 if (heap_msection != 0)
1428 {
1429 words_prev_msections += alloc_heap_ptr - alloc_heap_start;
1430 heap_msection->alloc = alloc_heap_ptr;
1431 }
1432
1433 heap_msection = next_msection (stack_msection);
1434 alloc_heap_start = start_of_tospace (heap_msection);
1435 alloc_heap_limit = alloc_heap_start + (___MSECTION_SIZE131072>>1);
1436 alloc_heap_ptr = alloc_heap_start;
1437}
1438
1439
1440/*---------------------------------------------------------------------------*/
1441
1442#ifdef ___DEBUG
1443
1444
1445#define ZAP_PATTERN ___CAST(___WORD,0xcafebabe)((long)(0xcafebabe))
1446
1447
1448char *subtype_to_string
1449 ___P((int subtype),(int subtype)
1450 (subtype)(int subtype)
1451int subtype;)(int subtype)
1452{
1453 switch (subtype)
1454 {
1455 case ___sVECTOR0: return "vector";
1456 case ___sPAIR1: return "pair";
1457 case ___sRATNUM2: return "ratnum";
1458 case ___sCPXNUM3: return "cpxnum";
1459 case ___sSTRUCTURE4: return "structure";
1460 case ___sBOXVALUES5: return "boxvalues";
1461 case ___sMEROON6: return "meroon";
1462 case ___sJAZZ7: return "jazz";
1463 case ___sSYMBOL8: return "symbol";
1464 case ___sKEYWORD9: return "keyword";
1465 case ___sFRAME10: return "frame";
1466 case ___sCONTINUATION11: return "continuation";
1467 case ___sPROMISE12: return "promise";
1468 case ___sWEAK13: return "weak";
1469 case ___sPROCEDURE14: return "procedure";
1470 case ___sRETURN15: return "return";
1471 case ___sFOREIGN18: return "foreign";
1472 case ___sSTRING19: return "string";
1473 case ___sS8VECTOR20: return "s8vector";
1474 case ___sU8VECTOR21: return "u8vector";
1475 case ___sS16VECTOR22: return "s16vector";
1476 case ___sU16VECTOR23: return "u16vector";
1477 case ___sS32VECTOR24: return "s32vector";
1478 case ___sU32VECTOR25: return "u32vector";
1479 case ___sF32VECTOR26: return "f32vector";
1480 case ___sS64VECTOR27: return "s64vector";
1481 case ___sU64VECTOR28: return "u64vector";
1482 case ___sF64VECTOR29: return "f64vector";
1483 case ___sFLONUM30: return "flonum";
1484 case ___sBIGNUM31: return "bignum";
1485 default: return "UNKNOWN SUBTYPE";
1486 }
1487}
1488
1489void print_value
1490 ___P((___SCMOBJ val),(long val)
1491 (val)(long val)
1492___SCMOBJ val;)(long val)
1493{
1494 ___SCMOBJlong ___temp;
1495 if (___FIXNUMP(val)(((val)&((1<<2)-1))==(0)))
1496 ___printf ("%d", ___INT(val)((val)>>2));
1497 else if (val == ___FAL((((long)(-1))<<2)+2))
1498 ___printf ("#f");
1499 else if (val == ___TRU((((long)(-2))<<2)+2))
1500 ___printf ("#t");
1501 else if (val == ___NUL((((long)(-3))<<2)+2))
1502 ___printf ("()");
1503 else if (val == ___EOF((((long)(-4))<<2)+2))
1504 ___printf ("#!eof");
1505 else if (val == ___VOID((((long)(-5))<<2)+2))
1506 ___printf ("#!void");
1507 else if (___CHARP(val)((((___temp=val))&((1<<2)-1))==2&&___temp>=
0)
)
1508 ___printf ("#\\x%x", ___INT(val)((val)>>2));
1509 else
1510 {
1511 ___WORDlong* body = ___BODY(val)(((long*)((val)&-(1<<2)))+1);
1512 ___WORDlong head = body[-1];
1513 int subtype;
1514
1515 if (___TYP(head)((head)&((1<<2)-1)) == ___FORW3)
1516 {
1517 /* indirect forwarding pointer */
1518 body = ___UNTAG_AS(head, ___FORW)((long*)((head)-(3))) + ___BODY_OFS1;
1519 head = body[-1];
1520 }
1521
1522 if (head == ZAP_PATTERN)
1523 ___printf ("[WARNING: HEAD=ZAP_PATTERN] ");
1524
1525 subtype = ___HD_SUBTYPE(head)((head)>>3&((1<<5)-1));
1526
1527 if (subtype == ___sPAIR1)
1528 {
1529 ___printf ("0x%08x (... . ...)", val);
1530 }
1531 else
1532 {
1533 ___SCMOBJlong sym;
1534 if (subtype == ___sPROCEDURE14 || subtype == ___sRETURN15)
1535 {
1536 if (subtype == ___sPROCEDURE14)
1537 ___printf ("#<procedure ");
1538 else
1539 ___printf ("#<return ");
1540 if ((sym = find_global_var_bound_to (val)) != ___NUL((((long)(-3))<<2)+2))
1541 print_value (___FIELD(sym,___SYMKEY_NAME)(*((((long*)((sym)-(1)))+1)+0)));
1542 else
1543 {
1544 if (___HD_TYP(head)((head)&((1<<3)-1)) == ___PERM6)
1545 {
1546 ___SCMOBJlong *start = &body[-1];
1547 ___SCMOBJlong *ptr = start;
1548 while (!___TESTHEADERTAG(*ptr,___sVECTOR)(((*ptr)&(((1<<5)-1)<<3))==((0)<<3)))
1549 ptr -= ___LS4;
1550 ptr += ___LS4;
1551 if (ptr == start)
1552 ___printf ("???");
1553 else
1554 {
1555 ___printf ("%d in ", (start-ptr)/___LS4);
1556 print_value (___TAG(ptr,___tSUBTYPED)(((long)(ptr))+(1)));
1557 }
1558 }
1559 else
1560 ___printf ("???");
1561 }
1562 ___printf (">");
1563 }
1564 else if (subtype == ___sSTRING19)
1565 {
1566 int i;
1567 ___SCMOBJlong str = ___TAG((body-1),___tSUBTYPED)(((long)((body-1)))+(1));
1568 ___printf ("\"");
1569 for (i=0; i<___INT(___STRINGLENGTH(str))(((((long)(((((unsigned long)((*((long*)((str)-(1))))))>>
(3 +5))>>2)))<<2))>>2)
; i++)
1570 ___printf ("%c", ___INT(___STRINGREF(str,___FIX(i)))((((((long)(((unsigned int)(*(((unsigned int*)((((long*)((str
)-(1)))+1)))+(((((long)(i))<<2))>>2))))))<<
2)+2))>>2)
);
1571 ___printf ("\"");
1572 }
1573 else
1574 {
1575 ___printf ("#<%s>", subtype_to_string (subtype));
1576 }
1577 }
1578 }
1579}
1580
1581#endif
1582
1583
1584#ifdef ENABLE_CONSISTENCY_CHECKS
1585
1586___HIDDENstatic int reference_location; /* where is offending reference located */
1587
1588#define IN_OBJECT 0
1589#define IN_REGISTER 1
1590#define IN_GLOBAL_VAR 2
1591#define IN_WILL_LIST 3
1592#define IN_CONTINUATION 4
1593#define IN_RC 5
1594
1595___HIDDENstatic ___WORDlong *container_body; /* pointer to body of object */
1596 /* containing offending reference */
1597
1598___HIDDENstatic int mark_array_call_line;
1599
1600
1601___HIDDENstatic void print_prefix
1602 ___P((char *prefix,(char *prefix, int indent)
1603 int indent),(char *prefix, int indent)
1604 (prefix,(char *prefix, int indent)
1605 indent)(char *prefix, int indent)
1606char *prefix;(char *prefix, int indent)
1607int indent;)(char *prefix, int indent)
1608{
1609 int i;
1610
1611 ___printf ("%s", prefix);
1612
1613 for (i=0; i<indent; i++)
1614 ___printf (" ");
1615}
1616
1617
1618___HIDDENstatic void print_object
1619 ___P((___WORD obj,(long obj, int max_depth, char *prefix, int indent)
1620 int max_depth,(long obj, int max_depth, char *prefix, int indent)
1621 char *prefix,(long obj, int max_depth, char *prefix, int indent)
1622 int indent),(long obj, int max_depth, char *prefix, int indent)
1623 (obj,(long obj, int max_depth, char *prefix, int indent)
1624 max_depth,(long obj, int max_depth, char *prefix, int indent)
1625 prefix,(long obj, int max_depth, char *prefix, int indent)
1626 indent)(long obj, int max_depth, char *prefix, int indent)
1627___WORD obj;(long obj, int max_depth, char *prefix, int indent)
1628int max_depth;(long obj, int max_depth, char *prefix, int indent)
1629char *prefix;(long obj, int max_depth, char *prefix, int indent)
1630int indent;)(long obj, int max_depth, char *prefix, int indent)
1631{
1632 int typ = ___TYP(obj)((obj)&((1<<2)-1));
1633
1634 print_prefix (prefix, indent);
1635
1636 if (typ == ___tFIXNUM0)
1637 ___printf ("%d\n", ___INT(obj)((obj)>>2));
1638 else if (typ == ___tSPECIAL2)
1639 {
1640 if (obj >= 0)
1641 ___printf ("#\\%c\n", ___INT(obj)((obj)>>2));
1642 else if (obj == ___FAL((((long)(-1))<<2)+2))
1643 ___printf ("#f\n");
1644 else if (obj == ___TRU((((long)(-2))<<2)+2))
1645 ___printf ("#t\n");
1646 else if (obj == ___NUL((((long)(-3))<<2)+2))
1647 ___printf ("()\n");
1648 else if (obj == ___EOF((((long)(-4))<<2)+2))
1649 ___printf ("#!eof\n");
1650 else if (obj == ___VOID((((long)(-5))<<2)+2))
1651 ___printf ("#!void\n");
1652 else if (obj == ___ABSENT((((long)(-6))<<2)+2))
1653 ___printf ("#<absent>\n");
1654 else if (obj == ___UNB1((((long)(-7))<<2)+2))
1655 ___printf ("#<unbound1>\n");
1656 else if (obj == ___UNB2((((long)(-8))<<2)+2))
1657 ___printf ("#<unbound2>\n");
1658 else if (obj == ___OPTIONAL((((long)(-9))<<2)+2))
1659 ___printf ("#!optional\n");
1660 else if (obj == ___KEYOBJ((((long)(-10))<<2)+2))
1661 ___printf ("#!key\n");
1662 else if (obj == ___REST((((long)(-11))<<2)+2))
1663 ___printf ("#!rest\n");
1664 else if (obj == ___UNUSED((((long)(-14))<<2)+2))
1665 ___printf ("#<unused>\n");
1666 else if (obj == ___DELETED((((long)(-15))<<2)+2))
1667 ___printf ("#<deleted>\n");
1668 else
1669 ___printf ("#<unknown>\n");
1670 }
1671 else
1672 {
1673 ___WORDlong* body = ___BODY(obj)(((long*)((obj)&-(1<<2)))+1);
1674 ___WORDlong head = body[-1];
1675 int subtype = ___HD_SUBTYPE(head)((head)>>3&((1<<5)-1));
1676
1677 switch (subtype)
1678 {
1679 case ___sVECTOR0:
1680 if (max_depth > 0)
1681 {
1682 int i;
1683 ___printf ("#(\n");
1684 for (i=0; i<___CAST(int,___HD_WORDS(head))((int)((((((unsigned long)(head))+((8 -1)<<(3 +5))))>>
((3 +5)+3))))
; i++)
1685 print_object (___FIELD(obj,i)(*((((long*)((obj)-(1)))+1)+i)), max_depth-1, prefix, indent+2);
1686 print_prefix (prefix, indent);
1687 ___printf (")\n");
1688 }
1689 else
1690 ___printf ("#(...)\n");
1691 break;
1692 case ___sPAIR1:
1693 if (max_depth > 0)
1694 {
1695 ___printf ("(\n");
1696 print_object (___CAR(obj)(*((((long*)((obj)-(3)))+1)+1)), max_depth-1, prefix, indent+1);
1697 print_prefix (prefix, indent);
1698 ___printf (" .\n");
1699 print_object (___CDR(obj)(*((((long*)((obj)-(3)))+1)+0)), max_depth-1, prefix, indent+1);
1700 print_prefix (prefix, indent);
1701 ___printf (")\n");
1702 }
1703 else
1704 ___printf ("(...)\n");
1705 break;
1706 case ___sRATNUM2:
1707 ___printf ("RATNUM\n");
1708 break;
1709 case ___sCPXNUM3:
1710 ___printf ("CPXNUM\n");
1711 break;
1712 case ___sSTRUCTURE4:
1713 ___printf ("STRUCTURE\n");
1714 break;
1715 case ___sBOXVALUES5:
1716 ___printf ("BOXVALUES\n");
1717 break;
1718 case ___sMEROON6:
1719 ___printf ("MEROON\n");
1720 break;
1721 case ___sSYMBOL8:
1722 ___printf ("SYMBOL\n");
1723 break;
1724 case ___sKEYWORD9:
1725 ___printf ("KEYWORD\n");
1726 break;
1727 case ___sFRAME10:
1728 ___printf ("FRAME\n");
1729 break;
1730 case ___sCONTINUATION11:
1731 ___printf ("CONTINUATION\n");
1732 break;
1733 case ___sPROMISE12:
1734 ___printf ("PROMISE\n");
1735 break;
1736 case ___sWEAK13:
1737 ___printf ("WEAK\n");
1738 break;
1739 case ___sPROCEDURE14:
1740 ___printf ("PROCEDURE\n");
1741 break;
1742 case ___sRETURN15:
1743 ___printf ("RETURN\n");
1744 break;
1745 case ___sFOREIGN18:
1746 ___printf ("FOREIGN\n");
1747 break;
1748 case ___sSTRING19:
1749 ___printf ("STRING\n");
1750 break;
1751 case ___sS8VECTOR20:
1752 ___printf ("S8VECTOR\n");
1753 break;
1754 case ___sU8VECTOR21:
1755 ___printf ("U8VECTOR\n");
1756 break;
1757 case ___sS16VECTOR22:
1758 ___printf ("S16VECTOR\n");
1759 break;
1760 case ___sU16VECTOR23:
1761 ___printf ("U16VECTOR\n");
1762 break;
1763 case ___sS32VECTOR24:
1764 ___printf ("S32VECTOR\n");
1765 break;
1766 case ___sU32VECTOR25:
1767 ___printf ("U32VECTOR\n");
1768 break;
1769 case ___sF32VECTOR26:
1770 ___printf ("F32VECTOR\n");
1771 break;
1772 case ___sS64VECTOR27:
1773 ___printf ("S64VECTOR\n");
1774 break;
1775 case ___sU64VECTOR28:
1776 ___printf ("U64VECTOR\n");
1777 break;
1778 case ___sF64VECTOR29:
1779 ___printf ("F64VECTOR\n");
1780 break;
1781 case ___sFLONUM30:
1782 ___printf ("FLONUM\n");
1783 break;
1784 case ___sBIGNUM31:
1785 ___printf ("BIGNUM\n");
1786 break;
1787 default:
1788 ___printf ("UNKNOWN\n");
1789 break;
1790 }
1791 }
1792}
1793
1794
1795___HIDDENstatic void print_global_var_name
1796 ___P((___glo_struct *glo),(___glo_struct *glo)
1797 (glo)(___glo_struct *glo)
1798___glo_struct *glo;)(___glo_struct *glo)
1799{
1800 ___SCMOBJlong sym = ___NUL((((long)(-3))<<2)+2);
1801 int i;
1802
1803 for (i = ___INT(___VECTORLENGTH(___GSTATE->symbol_table))(((((long)((((unsigned long)((*((long*)(((&___gstate)->
symbol_table)-(1))))))>>((3 +5)+3))))<<2))>>
2)
- 1; i>0; i--)
1804 {
1805 sym = ___FIELD(___GSTATE->symbol_table,i)(*((((long*)(((&___gstate)->symbol_table)-(1)))+1)+i));
1806
1807 while (sym != ___NUL((((long)(-3))<<2)+2))
1808 {
1809 ___SCMOBJlong g = ___FIELD(sym,___SYMBOL_GLOBAL)(*((((long*)((sym)-(1)))+1)+3));
1810
1811 if (g != ___FIX(0)(((long)(0))<<2))
1812 {
1813 ___glo_struct *p = ___CAST(___glo_struct*,g)((___glo_struct*)(g));
1814
1815 if (p == glo)
1816 {
1817 ___SCMOBJlong name = ___FIELD(sym,___SYMKEY_NAME)(*((((long*)((sym)-(1)))+1)+0));
1818 for (i=0; i<___INT(___STRINGLENGTH(name))(((((long)(((((unsigned long)((*((long*)((name)-(1))))))>>
(3 +5))>>2)))<<2))>>2)
; i++)
1819 ___printf ("%c", ___INT(___STRINGREF(name,___FIX(i)))((((((long)(((unsigned int)(*(((unsigned int*)((((long*)((name
)-(1)))+1)))+(((((long)(i))<<2))>>2))))))<<
2)+2))>>2)
);
1820 i = 0;
1821 break;
1822 }
1823 }
1824
1825 sym = ___FIELD(sym,___SYMKEY_NEXT)(*((((long*)((sym)-(1)))+1)+2));
1826 }
1827 }
1828}
1829
1830
1831___HIDDENstatic void dump_memory_map ___PVOID(void)
1832{
1833 int ns = the_msections->nb_sections;
1834 msection **sections = the_msections->sections;
1835 int i;
1836
1837 ___printf (">>> Memory map:\n");
1838
1839 for (i=0; i<ns; i++)
1840 ___printf (">>> msection %2d: 0x%08x .. 0x%08x .. 0x%08x\n",
1841 i,
1842 sections[i]->base,
1843 sections[i]->base + (___MSECTION_SIZE131072>>1),
1844 sections[i]->base + ___MSECTION_SIZE131072);
1845
1846 ___printf (">>> alloc_msection = 0x%08x\n", alloc_msection);
1847 ___printf (">>> stack_msection = 0x%08x\n", stack_msection);
1848 ___printf (">>> heap_msection = 0x%08x\n", heap_msection);
1849 ___printf (">>> scan_msection = 0x%08x\n", scan_msection);
1850 ___printf (">>> alloc_stack_ptr = 0x%08x\n", alloc_stack_ptr);
1851 ___printf (">>> alloc_stack_limit = 0x%08x\n", alloc_stack_limit);
1852 ___printf (">>> alloc_heap_limit = 0x%08x\n", alloc_heap_limit);
1853 ___printf (">>> alloc_heap_ptr = 0x%08x\n", alloc_heap_ptr);
1854 ___printf (">>> scan_ptr = 0x%08x\n", scan_ptr);
1855 ___printf (">>> scan_msection->alloc = 0x%08x\n", scan_msection->alloc);
1856}
1857
1858___HIDDENstatic void explain_problem
1859 ___P((___WORD obj,(long obj, char *msg)
1860 char *msg),(long obj, char *msg)
1861 (obj,(long obj, char *msg)
1862 msg)(long obj, char *msg)
1863___WORD obj;(long obj, char *msg)
1864char *msg;)(long obj, char *msg)
1865{
1866 dump_memory_map ();
1867
1868 ___printf (">>> The object 0x%08x %s\n", obj, msg);
1869
1870 {
1871 int j;
1872 for (j=-1; j<10; j++)
1873 {
1874 ___printf (">>> body[%2d] = 0x%08x\n", j, ___BODY(obj)(((long*)((obj)&-(1<<2)))+1)[j]);
1875 print_object (___BODY(obj)(((long*)((obj)&-(1<<2)))+1)[j], 1, ">>> ", 0);
1876 }
1877 }
1878
1879 switch (reference_location)
1880 {
1881 case IN_OBJECT:
1882 {
1883 ___WORDlong container;
1884 ___WORDlong head = container_body[-1];
1885 ___SIZE_TSlong words = ___HD_WORDS(head)(((((unsigned long)(head))+((8 -1)<<(3 +5))))>>((
3 +5)+3))
;
1886 int subtype = ___HD_SUBTYPE(head)((head)>>3&((1<<5)-1));
1887 int i;
1888
1889#if ___tPAIR3 != ___tSUBTYPED1
1890 if (subtype == ___sPAIR1)
1891 container = ___TAG(container_body-___BODY_OFS,___tPAIR)(((long)(container_body-1))+(3));
1892 else
1893#endif
1894 container = ___TAG(container_body-___BODY_OFS,___tSUBTYPED)(((long)(container_body-1))+(1));
1895
1896 ___printf (">>> The reference was found in ");
1897 if (___HD_TYP(head)((head)&((1<<3)-1)) == ___PERM6)
1898 ___printf ("___PERM ");
1899 else if (___HD_TYP(head)((head)&((1<<3)-1)) == ___STILL5)
1900 ___printf ("___STILL ");
1901 else if (___HD_TYP(head)((head)&((1<<3)-1)) == ___MOVABLE00)
1902 ___printf ("___MOVABLE0 ");
1903 else if (___TYP(head)((head)&((1<<2)-1)) == ___FORW3)
1904 ___printf ("___FORW ");
1905 else
1906 ___printf ("UNKNOWN ");
1907 ___printf ("object with body at 0x%08x:\n", container_body);
1908
1909 ___printf (">>> subtype = %d\n", subtype);
1910 ___printf (">>> length = %ld words\n", words);
1911 if (words <= 100)
1912 {
1913 for (i=0; i<words; i++)
1914 ___printf (">>> body[%2d] = 0x%08x\n", i, container_body[i]);
1915 }
1916 else
1917 {
1918 for (i=0; i<50; i++)
1919 ___printf (">>> body[%2d] = 0x%08x\n", i, container_body[i]);
1920 ___printf ("...\n");
1921 for (i=words-50; i<words; i++)
1922 ___printf (">>> body[%2d] = 0x%08x\n", i, container_body[i]);
1923 }
1924 ___printf (">>> container =\n");
1925 print_object (container, 4, ">>> ", 0);
1926 break;
1927 }
1928
1929 case IN_REGISTER:
1930 ___printf (">>> The reference was found in a register\n");
1931 break;
1932
1933 case IN_GLOBAL_VAR:
1934 ___printf (">>> The reference was found in a global variable\n");
1935 break;
1936
1937 case IN_WILL_LIST:
1938 ___printf (">>> The reference was found in a will list\n");
1939 break;
1940
1941 case IN_CONTINUATION:
1942 ___printf (">>> The reference was found in a continuation\n");
1943 break;
1944
1945 case IN_RC:
1946 ___printf (">>> The reference was found in a reference counted object\n");
1947 break;
1948 }
1949}
1950
1951
1952___HIDDENstatic void bug
1953 ___P((___WORD obj,(long obj, char *msg)
1954 char *msg),(long obj, char *msg)
1955 (obj,(long obj, char *msg)
1956 msg)(long obj, char *msg)
1957___WORD obj;(long obj, char *msg)
1958char *msg;)(long obj, char *msg)
1959{
1960 char *msgs[2];
1961 ___printf (">>> The GC has detected the following inconsistency\n");
1962 ___printf (">>> during call of mark_array on line %d of mem.c:\n",
1963 mark_array_call_line);
1964 explain_problem (obj, msg);
1965 msgs[0] = "GC inconsistency detected";
1966 msgs[1] = 0;
1967 ___fatal_error (msgs);
1968}
1969
1970
1971___HIDDENstatic void validate_old_obj
1972 ___P((___WORD obj),(long obj)
1973 (obj)(long obj)
1974___WORD obj;)(long obj)
1975{
1976 ___WORDlong *hd_ptr = ___BODY(obj)(((long*)((obj)&-(1<<2)))+1)-1;
1977 ___WORDlong head;
1978 int i = find_msection (the_msections, hd_ptr);
1979 if (i >= 0 && i < the_msections->nb_sections)
1980 {
1981 ___PTRDIFF_Tlong pos = hd_ptr - the_msections->sections[i]->base;
1982 if (pos >= 0 && pos < ___MSECTION_SIZE131072)
1983 {
1984 head = *hd_ptr;
1985 if (___TYP(head)((head)&((1<<2)-1)) == ___FORW3)
1986 {
1987 ___WORDlong *hd_ptr2 = ___UNTAG_AS(head,___FORW)((long*)((head)-(3)))+___BODY_OFS1-1;
1988 int i2 = find_msection (the_msections, hd_ptr2);
1989 if (i2 >= 0 && i2 < the_msections->nb_sections)
1990 {
1991 ___PTRDIFF_Tlong pos2 = hd_ptr2 - the_msections->sections[i2]->base;
1992 if (tospace_at_top
1993 ? (pos2 < ___MSECTION_SIZE131072>>1 ||
1994 pos2 >= ___MSECTION_SIZE131072)
1995 : (pos2 < 0 ||
1996 pos2 >= ___MSECTION_SIZE131072>>1))
1997 bug (obj, "was copied outside of tospace");
1998 else if (___HD_TYP((*hd_ptr2))(((*hd_ptr2))&((1<<3)-1)) != ___MOVABLE00)
1999 bug (obj, "was copied and copy is not ___MOVABLE0");
2000 }
2001 else
2002 bug (obj, "was copied outside of tospace");
2003 }
2004 else if (___HD_TYP(head)((head)&((1<<3)-1)) != ___MOVABLE00)
2005 bug (obj, "should be ___MOVABLE0");
2006 else if (tospace_at_top
2007 ? (pos >= ___MSECTION_SIZE131072>>1 &&
2008 pos < ___MSECTION_SIZE131072)
2009 : (pos >= 0 &&
2010 pos < ___MSECTION_SIZE131072>>1))
2011 bug (obj, "is in tospace");
2012 return;
2013 }
2014 }
2015 head = *hd_ptr; /* this dereference will likely bomb if there is a bug */
2016 if (___HD_TYP(head)((head)&((1<<3)-1)) != ___PERM6 && ___HD_TYP(head)((head)&((1<<3)-1)) != ___STILL5)
2017 bug (obj, "is not ___PERM or ___STILL");
2018}
2019
2020
2021___HIDDENstatic void zap_section
2022 ___P((___WORD *start,(long *start, int words)
2023 int words),(long *start, int words)
2024 (start,(long *start, int words)
2025 words)(long *start, int words)
2026___WORD *start;(long *start, int words)
2027int words;)(long *start, int words)
2028{
2029 while (words > 0)
2030 {
2031 *start++ = ZAP_PATTERN;
2032 words--;
2033 }
2034}
2035
2036
2037___HIDDENstatic int unzapped_words
2038 ___P((___WORD *start,(long *start, int words)
2039 int words),(long *start, int words)
2040 (start,(long *start, int words)
2041 words)(long *start, int words)
2042___WORD *start;(long *start, int words)
2043int words;)(long *start, int words)
2044{
2045 ___WORDlong *ptr = start;
2046
2047 while (words > 0 && *ptr++ == ZAP_PATTERN)
2048 words--;
2049
2050 return words;
2051}
2052
2053
2054___HIDDENstatic int stack_fudge_used; /* space used in msection stack fudge */
2055___HIDDENstatic int heap_fudge_used; /* space used in msection heap fudge */
2056
2057
2058___HIDDENstatic void check_fudge_used ___PVOID(void)
2059{
2060 ___processor_state ___ps = ___PSTATE(&(&___gstate)->pstate);
2061 int n;
2062
2063 n = unzapped_words (___ps->stack_limit - ___MSECTION_FUDGE(8192 +1+1),
2064 ___MSECTION_FUDGE(8192 +1+1));
2065
2066 if (n > stack_fudge_used)
2067 stack_fudge_used = n;
2068
2069#ifdef ___DEBUG_GARBAGE_COLLECT
2070 ___printf ("********* used stack fudge = %d\n", n);
2071#endif
2072
2073 n = ___ps->hp - ___ps->heap_limit;
2074
2075 if (n > heap_fudge_used)
2076 heap_fudge_used = n;
2077
2078#ifdef ___DEBUG_GARBAGE_COLLECT
2079 ___printf ("********* used heap fudge = %d\n", n);
2080#endif
2081}
2082
2083
2084___HIDDENstatic void zap_fromspace ___PVOID(void)
2085{
2086 int i;
2087 for (i=0; i<the_msections->nb_sections; i++)
2088 zap_section (start_of_fromspace (the_msections->sections[i]),
2089 ___MSECTION_SIZE131072>>1);
2090}
2091
2092#endif
2093
2094
2095/*---------------------------------------------------------------------------*/
2096
2097#ifdef GATHER_STATS
2098
2099#define MAX_STAT_SIZE 20
2100
2101___HIDDENstatic ___SIZE_TSlong movable_pair_objs;
2102___HIDDENstatic ___SIZE_TSlong movable_subtyped_objs[MAX_STAT_SIZE+2];
2103
2104#endif
2105
2106
2107/*---------------------------------------------------------------------------*/
2108
2109#ifdef ENABLE_CONSISTENCY_CHECKS
2110
2111#define mark_array(start,n) mark_array_debug (start, n, __LINE__2111)
2112
2113___HIDDENstatic void mark_array_debug
2114 ___P((___WORD *start,(long *start, long n, int line)
2115 ___WORD n,(long *start, long n, int line)
2116 int line),(long *start, long n, int line)
2117 (start,(long *start, long n, int line)
2118 n,(long *start, long n, int line)
2119 line)(long *start, long n, int line)
2120___WORD *start;(long *start, long n, int line)
2121___WORD n;(long *start, long n, int line)
2122int line;)(long *start, long n, int line)
2123
2124#else
2125
2126___HIDDENstatic void mark_array
2127 ___P((___WORD *start,(long *start, long n)
2128 ___WORD n),(long *start, long n)
2129 (start,(long *start, long n)
2130 n)(long *start, long n)
2131___WORD *start;(long *start, long n)
2132___WORD n;)(long *start, long n)
2133
2134#endif
2135{
2136 ___WORDlong *alloc = alloc_heap_ptr;
2137 ___WORDlong *limit = alloc_heap_limit;
2138
2139#ifdef ENABLE_CONSISTENCY_CHECKS
2140 mark_array_call_line = line;
2141#endif
2142
2143 while (n > 0)
2144 {
2145 ___WORDlong obj = *start;
2146
2147 if (___MEM_ALLOCATED(obj)((obj)&1))
2148 {
2149 ___WORDlong *body;
2150 ___WORDlong head;
2151 int head_typ;
2152 int subtype;
2153
2154#ifdef ENABLE_CONSISTENCY_CHECKS
2155 if (___DEBUG_SETTINGS_LEVEL(___setup_params.debug_settings)(((___setup_params.debug_settings) & 15) >> 0) >= 1)
2156 validate_old_obj (obj);
2157#endif
2158
2159 body = ___UNTAG(obj)((long*)((obj)&-(1<<2))) + ___BODY_OFS1;
2160 head = body[-1];
2161 subtype = ___HD_SUBTYPE(head)((head)>>3&((1<<5)-1));
Value stored to 'subtype' is never read
2162 head_typ = ___HD_TYP(head)((head)&((1<<3)-1));
2163
2164 if (head_typ == ___MOVABLE00)
2165 {
2166 ___SIZE_TSlong words = ___HD_WORDS(head)(((((unsigned long)(head))+((8 -1)<<(3 +5))))>>((
3 +5)+3))
;
2167#if ___WS8 == 4
2168 ___BOOLint pad = 0;
2169 while (alloc + words + (subtype >= ___sS64VECTOR27 ? 2 : 1) >
2170 limit)
2171#else
2172 while (alloc + words + 1 > limit)
2173#endif
2174 {
2175 alloc_heap_ptr = alloc;
2176 next_heap_msection ();
2177 alloc = alloc_heap_ptr;
2178 limit = alloc_heap_limit;
2179 }
2180#if ___WS8 != 8
2181 /*
2182 * ___sS64VECTOR, ___sU64VECTOR, ___sF64VECTOR,
2183 * ___sFLONUM and ___sBIGNUM need to be aligned on a
2184 * multiple of 8.
2185 */
2186 if (subtype >= ___sS64VECTOR27)
2187 {
2188 if ((___CAST(___WORD,alloc)((long)(alloc)) & (8-1)) == 0)
2189 *alloc++ = ___MAKE_HD_WORDS(0, ___sVECTOR)(((((0)<<3))<<(3 +5))+((0)<<3)+(0));
2190 else
2191 pad = 1;
2192 }
2193#endif
2194#ifdef GATHER_STATS
2195 if (subtype == ___sPAIR1)
2196 movable_pair_objs++;
2197 else if (words <= MAX_STAT_SIZE)
2198 movable_subtyped_objs[words]++;
2199 else
2200 movable_subtyped_objs[MAX_STAT_SIZE+1]++;
2201#endif
2202 *alloc++ = head;
2203 *start = ___TAG((alloc - ___BODY_OFS), ___TYP(obj))(((long)((alloc - 1)))+(((obj)&((1<<2)-1))));
2204 body[-1] = ___TAG((alloc - ___BODY_OFS), ___FORW)(((long)((alloc - 1)))+(3));
2205 while (words > 0)
2206 {
2207 *alloc++ = *body++;
2208 words--;
2209 }
2210#if ___WS8 == 4
2211 if (pad)
2212 *alloc++ = ___MAKE_HD_WORDS(0, ___sVECTOR)(((((0)<<3))<<(3 +5))+((0)<<3)+(0));
2213#endif
2214 }
2215 else if (head_typ == ___STILL5)
2216 {
2217 if (body[___STILL_MARK_OFS3 - ___STILL_BODY_OFS(5+1)] == -1)
2218 {
2219 body[___STILL_MARK_OFS3 - ___STILL_BODY_OFS(5+1)]
2220 = ___CAST(___WORD,still_objs_to_scan)((long)(still_objs_to_scan));
2221 still_objs_to_scan
2222 = ___CAST(___WORD,body - ___STILL_BODY_OFS)((long)(body - (5+1)));
2223 }
2224 }
2225 else if (___TYP(head_typ)((head_typ)&((1<<2)-1)) == ___FORW3)
2226 {
2227 ___WORDlong *copy_body = ___UNTAG_AS(head, ___FORW)((long*)((head)-(3))) + ___BODY_OFS1;
2228 *start = ___TAG((copy_body - ___BODY_OFS), ___TYP(obj))(((long)((copy_body - 1)))+(((obj)&((1<<2)-1))));
2229 }
2230#ifdef ENABLE_CONSISTENCY_CHECKS
2231 else if (___DEBUG_SETTINGS_LEVEL(___setup_params.debug_settings)(((___setup_params.debug_settings) & 15) >> 0) >= 1 &&
2232 head_typ != ___PERM6)
2233 bug (obj, "was not ___PERM, ___STILL, ___MOVABLE0 or ___FORW");
2234#endif
2235 }
2236
2237 start++;
2238 n--;
2239 }
2240
2241 alloc_heap_ptr = alloc;
2242}
2243
2244
2245___HIDDENstatic void mark_captured_continuation
2246 ___P((___WORD *orig_ptr),(long *orig_ptr)
2247 (orig_ptr)(long *orig_ptr)
2248___WORD *orig_ptr;)(long *orig_ptr)
2249{
2250 ___processor_state ___ps = ___PSTATE(&(&___gstate)->pstate);
2251 ___WORDlong *ptr = orig_ptr;
2252 int fs, link, i;
2253 ___WORDlong *fp;
2254 ___WORDlong ra1;
2255 ___WORDlong ra2;
2256 ___WORDlong cf;
2257
2258 cf = *ptr;
2259
2260#if 0
2261 printf("-------------\n");;;;;;;;;;;;;;;;;;;;;;;;;;
2262 fflush(stdoutstdout);
2263#endif
2264
2265 if (___TYP(cf)((cf)&((1<<2)-1)) == ___tFIXNUM0 && cf != ___FIX(0)(((long)(0))<<2))
2266 {
2267 /* continuation frame is in the stack */
2268
2269 ___WORDlong *alloc = alloc_heap_ptr;
2270 ___WORDlong *limit = alloc_heap_limit;
2271
2272 next_frame:
2273
2274 fp = ___CAST(___WORD*,cf)((long*)(cf));
2275
2276 ra1 = ___FP_STK(fp,-___FRAME_STACK_RA)fp[-(-0)];
2277
2278 if (ra1 == ___GSTATE(&___gstate)->internal_return)
2279 {
2280 ___WORDlong actual_ra = ___FP_STK(fp,___RETI_RA)fp[-((-((((((5 +1)+3)+(4)-1)/(4))*(4))-(5 +1))))];
2281 ___RETI_GET_FS_LINK(actual_ra,fs,link){ long descr = (*((long*)((actual_ra)+((1<<3)-1)))); if
(((descr)&3)) { fs = (((((((descr)>>2)&((1<<
5)-1)))+(4)-1)/(4))*(4))+(((((5 +1)+3)+(4)-1)/(4))*(4))-3; link
= (((descr)>>7)&((1<<5)-1)); } else { descr =
*(long*)descr; fs = (((((((descr)>>2)&((1<<14
)-1)))+(4)-1)/(4))*(4))+(((((5 +1)+3)+(4)-1)/(4))*(4))-3; link
= (((descr)>>16)&((1<<14)-1)); } }
2282 ___COVER_MARK_CAPTURED_CONTINUATION_RETI;
2283 }
2284 else
2285 {
2286 ___RETN_GET_FS_LINK(ra1,fs,link){ long descr = (*((long*)((ra1)+((1<<3)-1)))); if (((descr
)&3)) { fs = (((descr)>>2)&((1<<5)-1)); link
= (((descr)>>7)&((1<<5)-1)); } else { descr =
*(long*)descr; fs = (((descr)>>2)&((1<<14)-1
)); link = (((descr)>>16)&((1<<14)-1)); } }
2287 ___COVER_MARK_CAPTURED_CONTINUATION_RETN;
2288 }
2289
2290#if 0
2291 printf("fp=0x%08lx ra1=0x%08lx fs=%d link=%d\n", fp, ra1, fs, link);;;;;;;;;;;;;;;;;;;;;;;;;;
2292 fflush(stdoutstdout);
2293#endif
2294
2295 /* with reserve=1
2296bash-3.2$ gsi/gsi
2297-------------
2298Gambit v4.5.2
2299
2300> -------------
2301fp=0x1006fff68 ra1=0x1001f9bc1 fs=3 link=0
2302fp=0x1006fff88 ra1=0x1002efc21 fs=7 link=0
2303fp=0x1006fffc8 ra1=0x1002efda1 fs=3 link=0
2304fp=0x1006fffe8 ra1=0x1001f4e01 fs=3 link=0
2305-------------
2306-------------
2307fp=0x1006fff68 ra1=0x1001f9bc1 fs=3 link=0
2308-------------
2309fp=0x1006fff68 ra1=0x1001f9bc1 fs=3 link=0
2310 */
2311
2312 ___FP_ADJFP(fp,-___FRAME_SPACE(fs))fp-=(-(((((fs)+3)+(4)-1)/(4))*(4)));; /* get base of frame */
2313
2314 ra2 = ___FP_STK(fp,link+1)fp[-(link+1)];
2315
2316 if (___TYP(ra2)((ra2)&((1<<2)-1)) == ___tFIXNUM0)
2317 {
2318 ___COVER_MARK_CAPTURED_CONTINUATION_ALREADY_COPIED;
2319 *ptr = ra2; /* already copied, replace by forwarding pointer */
2320 }
2321 else
2322 {
2323 ___WORDlong forw;
2324 ___SIZE_TSlong words;
2325
2326 ___COVER_MARK_CAPTURED_CONTINUATION_COPY;
2327
2328 words = fs + ___FRAME_EXTRA_SLOTS1;
2329
2330 while (alloc + words + ___SUBTYPED_OVERHEAD1 > limit)
2331 {
2332 alloc_heap_ptr = alloc;
2333 next_heap_msection ();
2334 alloc = alloc_heap_ptr;
2335 limit = alloc_heap_limit;
2336 }
2337
2338 *alloc++ = ___MAKE_HD_WORDS(words, ___sFRAME)(((((words)<<3))<<(3 +5))+((10)<<3)+(0));
2339#if ___SUBTYPED_OVERHEAD1 != 1
2340 #error "___SUBTYPED_OVERHEAD != 1"
2341#endif
2342 forw = ___TAG((alloc - ___BODY_OFS), ___tFIXNUM)(((long)((alloc - 1)))+(0));
2343 *alloc++ = ra1;
2344#if ___FRAME_EXTRA_SLOTS1 != 1
2345 #error "___FRAME_EXTRA_SLOTS != 1"
2346#endif
2347
2348 for (i=fs; i>0; i--)
2349 *alloc++ = ___FP_STK(fp,i)fp[-(i)];
2350
2351 if (ra2 == ___GSTATE(&___gstate)->handler_break)
2352 {
2353 /* first frame of that section */
2354
2355 ___COVER_MARK_CAPTURED_CONTINUATION_FIRST_FRAME;
2356
2357 cf = ___FP_STK(fp,-___BREAK_FRAME_NEXT)fp[-(-1)];
2358 }
2359 else
2360 {
2361 /* not the first frame of that section */
2362
2363 ___COVER_MARK_CAPTURED_CONTINUATION_NOT_FIRST_FRAME;
2364
2365 ___FP_SET_STK(fp,-___FRAME_STACK_RA,ra2)fp[-(-0)]=(ra2);
2366 cf = ___CAST(___WORD,fp)((long)(fp));
2367 }
2368
2369 ___FP_SET_STK(alloc,link+1,cf)alloc[-(link+1)]=(cf);
2370 ___FP_SET_STK(fp,link+1,forw)fp[-(link+1)]=(forw); /* leave a forwarding pointer */
2371
2372 *ptr = forw;
2373
2374 ptr = &___FP_STK(alloc,link+1)alloc[-(link+1)];
2375
2376 if (___TYP(cf)((cf)&((1<<2)-1)) == ___tFIXNUM0 && cf != ___FIX(0)(((long)(0))<<2))
2377 goto next_frame;
2378 }
2379
2380 *orig_ptr = ___TAG(___UNTAG_AS(*orig_ptr, ___tFIXNUM), ___tSUBTYPED)(((long)(((long*)((*orig_ptr)-(0)))))+(1));
2381
2382 alloc_heap_ptr = alloc;
2383 }
2384 else
2385 mark_array (orig_ptr, 1);
2386}
2387
2388
2389___HIDDENstatic void mark_frame
2390 ___P((___WORD *fp,(long *fp, int fs, long gcmap, long *nextgcmap)
2391 int fs,(long *fp, int fs, long gcmap, long *nextgcmap)
2392 ___WORD gcmap,(long *fp, int fs, long gcmap, long *nextgcmap)
2393 ___WORD *nextgcmap),(long *fp, int fs, long gcmap, long *nextgcmap)
2394 (fp,(long *fp, int fs, long gcmap, long *nextgcmap)
2395 fs,(long *fp, int fs, long gcmap, long *nextgcmap)
2396 gcmap,(long *fp, int fs, long gcmap, long *nextgcmap)
2397 nextgcmap)(long *fp, int fs, long gcmap, long *nextgcmap)
2398___WORD *fp;(long *fp, int fs, long gcmap, long *nextgcmap)
2399int fs;(long *fp, int fs, long gcmap, long *nextgcmap)
2400___WORD gcmap;(long *fp, int fs, long gcmap, long *nextgcmap)
2401___WORD *nextgcmap;)(long *fp, int fs, long gcmap, long *nextgcmap)
2402{
2403 int i = 1;
2404
2405#ifdef SHOW_FRAMESzzz
2406
2407 {
2408 int k = 1;
2409 while (k <= fs)
2410 {
2411 ___WORDlong obj = ___FP_STK(fp,k)fp[-(k)];
2412 ___printf (" %2d: ", k);
2413 print_value (obj);
2414 ___printf ("\n");
2415 k++;
2416 }
2417 }
2418
2419#endif
2420
2421 for (;;)
2422 {
2423 if (gcmap & 1)
2424 {
2425 int j = i;
2426 do
2427 {
2428 if (i == fs)
2429 {
2430#ifdef SHOW_FRAMES
2431 {
2432 int k = j;
2433 while (k <= i)
2434 {
2435 ___WORDlong obj = ___FP_STK(fp,k)fp[-(k)];
2436 ___printf (" %2d: ", k);
2437 print_value (obj);
2438 ___printf ("\n");
2439 k++;
2440 }
2441 }
2442#endif
2443 mark_array (&___FP_STK(fp,i)fp[-(i)], i-j+1);
2444 return;
2445 }
2446 if ((i & (___WORD_WIDTH64-1)) == 0)
2447 gcmap = *nextgcmap++;
2448 else
2449 gcmap >>= 1;
2450 i++;
2451 } while (gcmap & 1);
2452#ifdef SHOW_FRAMES
2453 {
2454 int k = j;
2455 while (k < i)
2456 {
2457 ___WORDlong obj = ___FP_STK(fp,k)fp[-(k)];
2458 ___printf (" %2d: ", k);
2459 print_value (obj);
2460 ___printf ("\n");
2461 k++;
2462 }
2463 }
2464#endif
2465 mark_array (&___FP_STK(fp,i-1)fp[-(i-1)], i-j);
2466 }
2467 if (i == fs)
2468 return;
2469 if ((i & (___WORD_WIDTH64-1)) == 0)
2470 {
2471 gcmap = *nextgcmap++;
2472#ifdef SHOW_FRAMES
2473 ___printf ("gcmap = 0x%08x\n", gcmap);
2474#endif
2475 }
2476 else
2477 gcmap >>= 1;
2478 i++;
2479 }
2480}
2481
2482
2483___HIDDENstatic void mark_continuation ___PVOID(void)
2484{
2485 ___processor_state ___ps = ___PSTATE(&(&___gstate)->pstate);
2486 int fs, link;
2487 ___WORDlong *fp;
2488 ___WORDlong ra1;
2489 ___WORDlong ra2;
2490 ___WORDlong gcmap;
2491 ___WORDlong *nextgcmap = 0;
2492
2493 fp = ___ps->fp;
2494
2495 if (fp != ___ps->stack_break)
2496 for (;;)
2497 {
2498 ra1 = ___FP_STK(fp,-___FRAME_STACK_RA)fp[-(-0)];
2499
2500#ifdef SHOW_FRAMES
2501 ___printf ("continuation frame, ");
2502#endif
2503
2504 if (ra1 == ___GSTATE(&___gstate)->internal_return)
2505 {
2506 ___WORDlong actual_ra = ___FP_STK(fp,___RETI_RA)fp[-((-((((((5 +1)+3)+(4)-1)/(4))*(4))-(5 +1))))];
2507 ___RETI_GET_FS_LINK_GCMAP(actual_ra,fs,link,gcmap,nextgcmap){ long descr = (*((long*)((actual_ra)+((1<<3)-1)))); if
(((descr)&3)) { fs = (((((((descr)>>2)&((1<<
5)-1)))+(4)-1)/(4))*(4))+(((((5 +1)+3)+(4)-1)/(4))*(4))-3; link
= (((descr)>>7)&((1<<5)-1)); gcmap = (((descr
)>>12)&((1<<20)-1)); } else { nextgcmap = (long
*)descr; descr = *nextgcmap++; gcmap = *nextgcmap++; fs = (((
((((descr)>>2)&((1<<14)-1)))+(4)-1)/(4))*(4))
+(((((5 +1)+3)+(4)-1)/(4))*(4))-3; link = (((descr)>>16
)&((1<<14)-1)); } }
2508 ___COVER_MARK_CONTINUATION_RETI;
2509 }
2510 else
2511 {
2512 ___RETN_GET_FS_LINK_GCMAP(ra1,fs,link,gcmap,nextgcmap){ long descr = (*((long*)((ra1)+((1<<3)-1)))); if (((descr
)&3)) { gcmap = (((descr)>>12)&((1<<20)-1
)); fs = (((descr)>>2)&((1<<5)-1)); link = ((
(descr)>>7)&((1<<5)-1)); } else { nextgcmap =
(long*)descr; descr = *nextgcmap++; gcmap = *nextgcmap++; fs
= (((descr)>>2)&((1<<14)-1)); link = (((descr
)>>16)&((1<<14)-1)); } }
2513 ___COVER_MARK_CONTINUATION_RETN;
2514 }
2515
2516#ifdef SHOW_FRAMES
2517 ___printf ("fs=%d link=%d fp=0x%08x ra=", fs, link, ___CAST(___WORD,fp)((long)(fp)));
2518 print_value (ra1);
2519#endif
2520
2521 ___FP_ADJFP(fp,-___FRAME_SPACE(fs))fp-=(-(((((fs)+3)+(4)-1)/(4))*(4)));; /* get base of frame */
2522
2523 ra2 = ___FP_STK(fp,link+1)fp[-(link+1)];
2524
2525#ifdef SHOW_FRAMES
2526 if (fp == ___ps->stack_break)
2527 ___printf (" (first frame)\n");
2528 else
2529 ___printf (" (not first frame)\n");
2530#endif
2531
2532 mark_frame (fp, fs, gcmap, nextgcmap);
2533
2534 if (fp == ___ps->stack_break)
2535 break;
2536
2537 ___FP_SET_STK(fp,-___FRAME_STACK_RA,ra2)fp[-(-0)]=(ra2);
2538 }
2539
2540 mark_captured_continuation (&___FP_STK(fp,-___BREAK_FRAME_NEXT)fp[-(-1)]);
2541}
2542
2543
2544___HIDDENstatic void mark_rc ___PVOID(void)
2545{
2546 rc_header *h = rc_head.next;
2547
2548 while (h != &rc_head)
2549 {
2550 rc_header *next = h->next;
2551 mark_array (&h->data, 1);
2552 h = next;
2553 }
2554}
2555
2556
2557#define UNMARKED_MOVABLE(obj)((unmarked_typ = (((unmarked_body=(((long*)((obj)&-(1<<
2)))+1))[-1])&((1<<3)-1))) == 0)
\
2558((unmarked_typ = ___HD_TYP((unmarked_body=___BODY(obj))[-1])(((unmarked_body=(((long*)((obj)&-(1<<2)))+1))[-1])
&((1<<3)-1))
) == ___MOVABLE00)
2559
2560#define UNMARKED_STILL(obj)(unmarked_typ == 5 && unmarked_body[3 - (5+1)] == -1) \
2561(unmarked_typ == ___STILL5 && \
2562 unmarked_body[___STILL_MARK_OFS3 - ___STILL_BODY_OFS(5+1)] == -1)
2563
2564#define UNMARKED(obj)(((unmarked_typ = (((unmarked_body=(((long*)((obj)&-(1<<
2)))+1))[-1])&((1<<3)-1))) == 0) || (unmarked_typ ==
5 && unmarked_body[3 - (5+1)] == -1))
\
2565(UNMARKED_MOVABLE(obj)((unmarked_typ = (((unmarked_body=(((long*)((obj)&-(1<<
2)))+1))[-1])&((1<<3)-1))) == 0)
|| UNMARKED_STILL(obj)(unmarked_typ == 5 && unmarked_body[3 - (5+1)] == -1))
2566
2567
2568___HIDDENstatic ___SIZE_TSlong scan
2569 ___P((___WORD *body),(long *body)
2570 (body)(long *body)
2571___WORD *body;)(long *body)
2572{
2573 ___WORDlong head = body[-1];
2574 ___SIZE_TSlong words = ___HD_WORDS(head)(((((unsigned long)(head))+((8 -1)<<(3 +5))))>>((
3 +5)+3))
;
2575 int subtype = ___HD_SUBTYPE(head)((head)>>3&((1<<5)-1));
2576
2577#ifdef ENABLE_CONSISTENCY_CHECKS
2578 reference_location = IN_OBJECT;
2579 container_body = body;
2580#endif
2581
2582 switch (subtype)
2583 {
2584 case ___sFOREIGN18:
2585 case ___sSTRING19:
2586 case ___sS8VECTOR20:
2587 case ___sU8VECTOR21:
2588 case ___sS16VECTOR22:
2589 case ___sU16VECTOR23:
2590 case ___sS32VECTOR24:
2591 case ___sU32VECTOR25:
2592 case ___sS64VECTOR27:
2593 case ___sU64VECTOR28:
2594 case ___sF32VECTOR26:
2595 case ___sF64VECTOR29:
2596 case ___sFLONUM30:
2597 case ___sBIGNUM31:
2598 break;
2599
2600 case ___sWEAK13:
2601 if (words == ___WILL_SIZE3)
2602 {
2603 /* Object is a will */
2604
2605 /*
2606 * The will contains a weak reference to its testator object
2607 * and a strong reference to the action procedure.
2608 * Consequently, the action procedure must be marked and,
2609 * only if traverse_weak_refs is true, the testator object
2610 * is also marked. The link field is never scanned.
2611 */
2612
2613 if (traverse_weak_refs)
2614 mark_array (body+1, 2); /* scan action and testator */
2615 else
2616 {
2617 mark_array (body+2, 1); /* scan action only */
2618
2619 /*
2620 * Remember that this will's testator object remains to
2621 * be marked by the process_wills function.
2622 */
2623
2624 body[0] = body[0] | ___UNMARKED_TESTATOR_WILL2;
2625 }
2626 }
2627 else
2628 {
2629 /* Object is a GC hash table */
2630
2631 int flags = ___INT(body[___GCHASHTABLE_FLAGS])((body[1])>>2);
2632 int i;
2633
2634 if ((flags & ___GCHASHTABLE_FLAG_WEAK_KEYS1) == 0 &&
2635 (flags & ___GCHASHTABLE_FLAG_MEM_ALLOC_KEYS16))
2636 {
2637 for (i=words-2; i>=___GCHASHTABLE_KEY05; i-=2)
2638 mark_array (body+i, 1); /* mark objects in key fields */
2639 }
2640
2641 if ((flags & ___GCHASHTABLE_FLAG_WEAK_VALS2) == 0)
2642 {
2643 for (i=words-1; i>=___GCHASHTABLE_VAL06; i-=2)
2644 mark_array (body+i, 1); /* mark objects in value fields */
2645 }
2646
2647 body[0] = reached_gc_hash_tables;
2648 reached_gc_hash_tables = ___TAG((body-1),0)(((long)((body-1)))+(0));
2649 }
2650 break;
2651
2652 case ___sSYMBOL8:
2653 case ___sKEYWORD9:
2654 mark_array (body, 1); /* only scan name of symbols & keywords */
2655 break;
2656
2657 case ___sCONTINUATION11:
2658 mark_captured_continuation (&body[___CONTINUATION_FRAME0]);
2659 mark_array (body+1, words-1); /* skip the frame pointer */
2660 break;
2661
2662 case ___sFRAME10:
2663 {
2664 int fs, link;
2665 ___WORDlong *fp = body + ___FRAME_EXTRA_SLOTS1;
2666 ___WORDlong ra = body[0];
2667 ___WORDlong gcmap;
2668 ___WORDlong *nextgcmap = 0;
2669 ___WORDlong frame;
2670
2671#ifdef SHOW_FRAMES
2672 ___printf ("___sFRAME object, ");
2673#endif
2674
2675 if (ra == ___GSTATE(&___gstate)->internal_return)
2676 {
2677 ___WORDlong actual_ra = body[___FRAME_RETI_RA(1-3 -(-((((((5 +1)+3)+(4)-1)/(4))*(4))-(5 +1))))];
2678 ___RETI_GET_FS_LINK_GCMAP(actual_ra,fs,link,gcmap,nextgcmap){ long descr = (*((long*)((actual_ra)+((1<<3)-1)))); if
(((descr)&3)) { fs = (((((((descr)>>2)&((1<<
5)-1)))+(4)-1)/(4))*(4))+(((((5 +1)+3)+(4)-1)/(4))*(4))-3; link
= (((descr)>>7)&((1<<5)-1)); gcmap = (((descr
)>>12)&((1<<20)-1)); } else { nextgcmap = (long
*)descr; descr = *nextgcmap++; gcmap = *nextgcmap++; fs = (((
((((descr)>>2)&((1<<14)-1)))+(4)-1)/(4))*(4))
+(((((5 +1)+3)+(4)-1)/(4))*(4))-3; link = (((descr)>>16
)&((1<<14)-1)); } }
2679 ___COVER_SCAN_FRAME_RETI;
2680 }
2681 else
2682 {
2683 ___RETN_GET_FS_LINK_GCMAP(ra,fs,link,gcmap,nextgcmap){ long descr = (*((long*)((ra)+((1<<3)-1)))); if (((descr
)&3)) { gcmap = (((descr)>>12)&((1<<20)-1
)); fs = (((descr)>>2)&((1<<5)-1)); link = ((
(descr)>>7)&((1<<5)-1)); } else { nextgcmap =
(long*)descr; descr = *nextgcmap++; gcmap = *nextgcmap++; fs
= (((descr)>>2)&((1<<14)-1)); link = (((descr
)>>16)&((1<<14)-1)); } }
2684 ___COVER_SCAN_FRAME_RETN;
2685 }
2686
2687#ifdef SHOW_FRAMES
2688 ___printf ("fs=%d link=%d fp=0x%08x ra=", fs, link, ___CAST(___WORD,fp)((long)(fp)));
2689 print_value (ra);
2690 ___printf ("\n");
2691#endif
2692
2693 fp += fs;
2694
2695 frame = ___FP_STK(fp,link+1)fp[-(link+1)];
2696
2697 if (___TYP(frame)((frame)&((1<<2)-1)) == ___tFIXNUM0 && frame != ___FIX(0)(((long)(0))<<2))
2698 ___FP_SET_STK(fp,link+1,___FAL)fp[-(link+1)]=(((((long)(-1))<<2)+2));
2699
2700 mark_frame (fp, fs, gcmap, nextgcmap);
2701
2702 if (___TYP(frame)((frame)&((1<<2)-1)) == ___tFIXNUM0 && frame != ___FIX(0)(((long)(0))<<2))
2703 ___FP_SET_STK(fp,link+1,___TAG(___UNTAG_AS(frame, ___tFIXNUM), ___tSUBTYPED))fp[-(link+1)]=((((long)(((long*)((frame)-(0)))))+(1)));
2704
2705 mark_array (&body[0], 1);
2706 }
2707 break;
2708
2709 case ___sPROCEDURE14:
2710 if (___HD_TYP(head)((head)&((1<<3)-1)) != ___PERM6) /* only scan closures */
2711 mark_array (body+1, words-1); /* only scan free variables */
2712 break;
2713
2714 default:
2715 mark_array (body, words);
2716 break;
2717 }
2718
2719 return words;
2720}
2721
2722
2723___HIDDENstatic void init_still_objs_to_scan ___PVOID(void)
2724{
2725 ___WORDlong *base = ___CAST(___WORD*,still_objs)((long*)(still_objs));
2726 ___WORDlong *to_scan = 0;
2727
2728 while (base != 0)
2729 {
2730 if (base[___STILL_REFCOUNT_OFS1] == 0)
2731 base[___STILL_MARK_OFS3] = -1;
2732 else
2733 {
2734 base[___STILL_MARK_OFS3] = ___CAST(___WORD,to_scan)((long)(to_scan));
2735 to_scan = base;
2736 }
2737 base = ___CAST(___WORD*,base[___STILL_LINK_OFS])((long*)(base[0]));
2738 }
2739
2740 still_objs_to_scan = ___CAST(___WORD,to_scan)((long)(to_scan));
2741}
2742
2743
2744___HIDDENstatic void scan_still_objs_to_scan ___PVOID(void)
2745{
2746 ___WORDlong *base;
2747
2748 while ((base = ___CAST(___WORD*,still_objs_to_scan)((long*)(still_objs_to_scan))) != 0)
2749 {
2750 still_objs_to_scan = base[___STILL_MARK_OFS3];
2751 scan (base + ___STILL_BODY_OFS(5+1));
2752 };
2753}
2754
2755
2756___HIDDENstatic void scan_movable_objs_to_scan ___PVOID(void)
2757{
2758 ___WORDlong *body;
2759 ___SIZE_TSlong words;
2760
2761 for (;;)
2762 {
2763 if (scan_msection == heap_msection)
2764 {
2765 if (scan_ptr >= alloc_heap_ptr)
2766 break;
2767 }
2768 else if (scan_ptr >= scan_msection->alloc)
2769 {
2770 scan_msection = scan_msection->next;
2771 scan_ptr = start_of_tospace (scan_msection);
2772 continue;
2773 }
2774 body = scan_ptr + 1;
2775 words = scan (body);
2776 scan_ptr = body + words;
2777 };
2778}
2779
2780
2781___HIDDENstatic void free_unmarked_still_objs ___PVOID(void)
2782{
2783 ___WORDlong *last = &still_objs;
2784 ___WORDlong *base = ___CAST(___WORD*,*last)((long*)(*last));
2785
2786 while (base != 0)
2787 {
2788 ___WORDlong link = base[___STILL_LINK_OFS0];
2789 if (base[___STILL_MARK_OFS3] == -1)
2790 {
2791 ___WORDlong head = base[___STILL_BODY_OFS(5+1)-1];
2792 if (___HD_SUBTYPE(head)((head)>>3&((1<<5)-1)) == ___sFOREIGN18)
2793 ___release_foreign
2794 (___TAG((base + ___STILL_BODY_OFS - ___BODY_OFS), ___tSUBTYPED)(((long)((base + (5+1) - 1)))+(1)));
2795 words_nonmovable -= base[___STILL_LENGTH_OFS2];
2796 free_mem_aligned (base);
2797 }
2798 else
2799 {
2800 *last = ___CAST(___WORD,base)((long)(base));
2801 last = base + ___STILL_LINK_OFS0;
2802 }
2803 base = ___CAST(___WORD*,link)((long*)(link));
2804 }
2805
2806 *last = 0;
2807}
2808
2809
2810___HIDDENstatic void free_still_objs ___PVOID(void)
2811{
2812 ___WORDlong *base = ___CAST(___WORD*,still_objs)((long*)(still_objs));
2813
2814 still_objs = 0;
2815
2816 while (base != 0)
2817 {
2818 ___WORDlong link = base[___STILL_LINK_OFS0];
2819 ___WORDlong head = base[___STILL_BODY_OFS(5+1)-1];
2820 if (___HD_SUBTYPE(head)((head)>>3&((1<<5)-1)) == ___sFOREIGN18)
2821 ___release_foreign
2822 (___TAG((base + ___STILL_BODY_OFS - ___BODY_OFS), ___tSUBTYPED)(((long)((base + (5+1) - 1)))+(1)));
2823 free_mem_aligned (base);
2824 base = ___CAST(___WORD*,link)((long*)(link));
2825 }
2826}
2827
2828
2829___HIDDENstatic ___SIZE_TSlong adjust_heap
2830 ___P((___SIZE_TS avail,(long avail, long live)
2831 ___SIZE_TS live),(long avail, long live)
2832 (avail,(long avail, long live)
2833 live)(long avail, long live)
2834___SIZE_TS avail;(long avail, long live)
2835___SIZE_TS live;)(long avail, long live)
2836{
2837 ___SIZE_TSlong target;
2838
2839 if (___setup_params.gc_hook != 0)
2840 return ___setup_params.gc_hook (avail, live);
2841
2842 if (___setup_params.live_percent < 100)
2843 target = live / ___setup_params.live_percent * 100;
2844 else
2845 target = live + ___MSECTION_BIGGEST255;
2846
2847 if (target < ___CAST(___SIZE_TS,(___setup_params.min_heap >> ___LWS))((long)((___setup_params.min_heap >> 3))))
2848 target = ___CAST(___SIZE_TS,(___setup_params.min_heap >> ___LWS))((long)((___setup_params.min_heap >> 3)));
2849
2850 if (___setup_params.max_heap > 0 &&
2851 target > ___CAST(___SIZE_TS,(___setup_params.max_heap >> ___LWS))((long)((___setup_params.max_heap >> 3))))
2852 target = ___CAST(___SIZE_TS,(___setup_params.max_heap >> ___LWS))((long)((___setup_params.max_heap >> 3)));
2853
2854 return target;
2855}
2856
2857
2858___HIDDENstatic void setup_pstate ___PVOID(void)
2859{
2860 ___processor_state ___ps = ___PSTATE(&(&___gstate)->pstate);
2861 ___SIZE_TSlong avail;
2862 ___SIZE_TSlong stack_avail;
2863 ___SIZE_TSlong stack_left_before_fudge;
2864 ___SIZE_TSlong heap_avail;
2865 ___SIZE_TSlong heap_left_before_fudge;
2866
2867#ifdef CALL_GC_FREQUENTLY
2868 avail = 0;
2869#else
2870 if (heap_size < WORDS_OCCUPIED(words_nonmovable + (2*(words_prev_msections + (alloc_stack_start
- alloc_stack_ptr) + (alloc_heap_ptr - alloc_heap_start))))
)
2871 avail = 0;
2872 else
2873 avail = (heap_size - WORDS_OCCUPIED(words_nonmovable + (2*(words_prev_msections + (alloc_stack_start
- alloc_stack_ptr) + (alloc_heap_ptr - alloc_heap_start))))
) / 2;
2874#endif
2875
2876 stack_avail = avail/2;
2877 stack_left_before_fudge = (alloc_stack_ptr - alloc_stack_limit)
2878 - ___MSECTION_FUDGE(8192 +1+1);
2879
2880 ___ps->fp = alloc_stack_ptr;
2881 ___ps->stack_limit = alloc_stack_ptr
2882 - ((stack_avail < stack_left_before_fudge)
2883 ? stack_avail
2884 : stack_left_before_fudge);
2885
2886 heap_avail = avail - stack_avail;
2887 heap_left_before_fudge = (alloc_heap_limit - alloc_heap_ptr)
2888 - ___MSECTION_FUDGE(8192 +1+1);
2889
2890 ___ps->hp = alloc_heap_ptr;
2891 ___ps->heap_limit = alloc_heap_ptr
2892 + ((heap_avail < heap_left_before_fudge)
2893 ? heap_avail
2894 : heap_left_before_fudge);
2895
2896 ___begin_interrupt_service ();
2897 ___end_interrupt_service (0);
2898
2899#ifdef ENABLE_CONSISTENCY_CHECKS
2900 if (___DEBUG_SETTINGS_LEVEL(___setup_params.debug_settings)(((___setup_params.debug_settings) & 15) >> 0) >= 1)
2901 {
2902 ___WORDlong *end = ___ps->stack_limit;
2903 ___WORDlong *start = end - ___MSECTION_FUDGE(8192 +1+1);
2904 if (end > alloc_stack_ptr)
2905 end = alloc_stack_ptr;
2906 zap_section (start, end - start);
2907 if (___DEBUG_SETTINGS_LEVEL(___setup_params.debug_settings)(((___setup_params.debug_settings) & 15) >> 0) == 3)
2908 {
2909 ___printf ("heap_size = %d\n", heap_size);
2910 ___printf ("WORDS_OCCUPIED = %d\n", WORDS_OCCUPIED(words_nonmovable + (2*(words_prev_msections + (alloc_stack_start
- alloc_stack_ptr) + (alloc_heap_ptr - alloc_heap_start))))
);
2911 ___printf ("avail = %d\n", avail);
2912 ___printf ("stack_avail = %d\n", stack_avail);
2913 ___printf ("heap_avail = %d\n", heap_avail);
2914 ___printf ("stack_msection = 0x%08x\n", stack_msection);
2915 ___printf ("heap_msection = 0x%08x\n", heap_msection);
2916 ___printf ("___ps->stack_start = 0x%08x\n", ___ps->stack_start);
2917 ___printf ("___ps->stack_break = 0x%08x\n", ___ps->stack_break);
2918 ___printf ("___ps->fp = 0x%08x\n", ___ps->fp);
2919 ___printf ("alloc_stack_ptr = 0x%08x\n", alloc_stack_ptr);
2920 ___printf ("___ps->stack_limit = 0x%08x\n", ___ps->stack_limit);
2921 ___printf ("alloc_stack_limit = 0x%08x\n", alloc_stack_limit);
2922 ___printf ("alloc_heap_limit = 0x%08x\n", alloc_heap_limit);
2923 ___printf ("___ps->heap_limit = 0x%08x\n", ___ps->heap_limit);
2924 ___printf ("___ps->hp = 0x%08x\n", ___ps->hp);
2925 ___printf ("alloc_heap_ptr = 0x%08x\n", alloc_heap_ptr);
2926 ___printf ("alloc_heap_start = 0x%08x\n", alloc_heap_start);
2927 }
2928 }
2929#endif
2930}
2931
2932
2933___SCMOBJlong ___setup_mem ___PVOID(void)
2934{
2935 ___processor_state ___ps = ___PSTATE(&(&___gstate)->pstate);
2936 int init_nb_sections;
2937
2938 /*
2939 * It is important to initialize the following pointers first so
2940 * that if the program terminates early the procedure ___cleanup_mem
2941 * will not access dangling pointers.
2942 */
2943
2944 the_msections = 0;
2945 psections = 0;
2946 still_objs = 0;
2947
2948 setup_rc ();
2949
2950 /*
2951 * Set the overflow reserve so that the rest parameter handler can
2952 * construct the rest parameter list without having to call the
2953 * garbage collector.
2954 */
2955
2956 normal_overflow_reserve = 2*((___MAX_NB_PARMS1024+___SUBTYPED_OVERHEAD1) +
2957 ___MAX_NB_ARGS8192*(___PAIR_SIZE2+___PAIR_OVERHEAD1));
2958 overflow_reserve = normal_overflow_reserve;
2959
2960 /* Allocate heap */
2961
2962 if (___setup_params.min_heap == 0) {
2963
2964 /*
2965 * Choose a reasonable minimum heap size.
2966 */
2967
2968 ___setup_params.min_heap = ___processor_cache_size (0, 0) / 2;
2969
2970 if (___setup_params.min_heap < ___DEFAULT_MIN_HEAP(1*(1<<20))) {
2971 ___setup_params.min_heap = ___DEFAULT_MIN_HEAP(1*(1<<20));
2972 }
2973 }
2974
2975 if (___setup_params.live_percent <= 0 ||
2976 ___setup_params.live_percent > 100) {
2977
2978 /*
2979 * Choose a reasonable minimum live percent.
2980 */
2981
2982 ___setup_params.live_percent = ___DEFAULT_LIVE_PERCENT50;
2983 }
2984
2985 init_nb_sections = ((___setup_params.min_heap >> ___LWS3) +
2986 overflow_reserve + 2*___MSECTION_FUDGE(8192 +1+1) +
2987 2*((___MSECTION_SIZE131072>>1)-___MSECTION_FUDGE(8192 +1+1)+1) - 1) /
2988 (2*((___MSECTION_SIZE131072>>1)-___MSECTION_FUDGE(8192 +1+1)+1));
2989
2990 if (init_nb_sections < ___MIN_NB_MSECTIONS1)
2991 init_nb_sections = ___MIN_NB_MSECTIONS1;
2992
2993 adjust_msections (&the_msections, init_nb_sections);
2994
2995 if (the_msections == 0 ||
2996 the_msections->nb_sections != init_nb_sections)
2997 return ___FIX(___HEAP_OVERFLOW_ERR)(((long)((((((int)(-1))<<29)+(((int)(448))<<16)+(
0))+5)))<<2)
;
2998
2999#ifdef ENABLE_CONSISTENCY_CHECKS
3000 if (___DEBUG_SETTINGS_LEVEL(___setup_params.debug_settings)(((___setup_params.debug_settings) & 15) >> 0) >= 1)
3001 {
3002 zap_fromspace ();
3003 stack_fudge_used = 0;
3004 heap_fudge_used = 0;
3005 }
3006#endif
3007
3008 words_nonmovable = 0;
3009 words_prev_msections = 0;
3010
3011 tospace_at_top = 0;
3012 stack_msection = 0;
3013 heap_msection = 0;
3014 nb_msections_used = 0;
3015
3016 next_stack_msection ();
3017 next_heap_msection ();
3018
3019 palloc_ptr = 0;
3020
3021 /*
3022 * Create "break frame" of initial top section.
3023 */
3024
3025 ___ps->stack_start = alloc_stack_start;
3026 alloc_stack_ptr = alloc_stack_start;
3027
3028 ___FP_ADJFP(alloc_stack_ptr,___BREAK_FRAME_SPACE)alloc_stack_ptr-=(((((1)+(4)-1)/(4))*(4)));
3029 ___FP_SET_STK(alloc_stack_ptr,-___BREAK_FRAME_NEXT,0)alloc_stack_ptr[-(-1)]=(0);
3030
3031 ___ps->stack_break = alloc_stack_ptr;
3032
3033 /*
3034 * Setup will lists.
3035 */
3036
3037 ___ps->executable_wills = ___TAG(0,___EXECUTABLE_WILL)(((long)(0))+(1)); /* tagged empty list */
3038 ___ps->nonexecutable_wills = ___TAG(0,0)(((long)(0))+(0)); /* tagged empty list */
3039
3040 heap_size = WORDS_AVAILABLE(words_nonmovable + (2*the_msections->nb_sections*((long)(
((131072>>1)-(8192 +1+1)+1)))) - overflow_reserve - 2*(
8192 +1+1))
;
3041
3042#ifdef ___DEBUG_STACK_LIMIT
3043 ___ps->poll_line = 0;
3044 ___ps->stack_limit_line = 0;
3045#endif
3046
3047#ifdef ___DEBUG_HEAP_LIMIT
3048 ___ps->check_heap_line = 0;
3049 ___ps->heap_limit_line = 0;
3050#endif
3051
3052#ifdef ___HEARTBEAT_USING_POLL_COUNTDOWN
3053 ___ps->heartbeat_interval = ___HEARTBEAT_USING_POLL_COUNTDOWN;
3054 ___ps->heartbeat_countdown = ___ps->heartbeat_interval;
3055#endif
3056
3057 setup_pstate ();
3058
3059 /* Setup global state */
3060
3061 ___GSTATE(&___gstate)->nb_gcs = 0.0;
3062 ___GSTATE(&___gstate)->gc_user_time = 0.0;
3063 ___GSTATE(&___gstate)->gc_sys_time = 0.0;
3064 ___GSTATE(&___gstate)->gc_real_time = 0.0;
3065 ___GSTATE(&___gstate)->bytes_allocated_minus_occupied = 0.0;
3066
3067 ___GSTATE(&___gstate)->last_gc_real_time = 0.0;
3068 ___GSTATE(&___gstate)->last_gc_heap_size = ___CAST(___F64,heap_size)((double)(heap_size)) * ___WS8;
3069 ___GSTATE(&___gstate)->last_gc_live = 0.0;
3070 ___GSTATE(&___gstate)->last_gc_movable = 0.0;
3071 ___GSTATE(&___gstate)->last_gc_nonmovable = 0.0;
3072
3073 return ___FIX(___NO_ERR)(((long)(0))<<2);
3074}
3075
3076
3077void ___cleanup_mem ___PVOID(void)
3078{
3079 free_msections (&the_msections);
3080 free_psections ();
3081 free_still_objs ();
3082 cleanup_rc ();
3083}
3084
3085
3086___HIDDENstatic void determine_will_executability
3087 ___P((___WORD list),(long list)
3088 (list)(long list)
3089___WORD list;)(long list)
3090{
3091 while (___UNTAG(list)((long*)((list)&-(1<<2))) != 0)
3092 {
3093 ___WORDlong* will_body = ___BODY(list)(((long*)((list)&-(1<<2)))+1);
3094 ___WORDlong will_head = will_body[-1];
3095 ___WORDlong testator;
3096
3097 ___WORDlong *unmarked_body; /* used by the UNMARKED macro */
3098 int unmarked_typ;
3099
3100 if (___TYP(will_head)((will_head)&((1<<2)-1)) == ___FORW3) /* was will forwarded? */
3101 will_body = ___BODY_AS(will_head,___FORW)(((long*)((will_head)-(3)))+1);
3102
3103 list = will_body[0];
3104
3105 testator = will_body[1];
3106
3107 if (___MEM_ALLOCATED(testator)((testator)&1) &&
3108 UNMARKED(testator)(((unmarked_typ = (((unmarked_body=(((long*)((testator)&-
(1<<2)))+1))[-1])&((1<<3)-1))) == 0) || (unmarked_typ
== 5 && unmarked_body[3 - (5+1)] == -1))
) /* testator was not marked? */
3109 {
3110 /*
3111 * All paths to testator object from roots pass through
3112 * weak references, so mark will as executable.
3113 */
3114
3115 will_body[0] = list | ___EXECUTABLE_WILL1;
3116 }
3117 }
3118}
3119
3120
3121___HIDDENstatic void process_wills ___PVOID(void)
3122{
3123 ___processor_state ___ps = ___PSTATE(&(&___gstate)->pstate);
3124 ___WORDlong* tail_exec;
3125 ___WORDlong* tail_nonexec;
3126 ___WORDlong curr;
3127
3128#ifdef ENABLE_CONSISTENCY_CHECKS
3129 reference_location = IN_WILL_LIST;
3130#endif
3131
3132 determine_will_executability (___ps->nonexecutable_wills);
3133
3134 /*
3135 * Finish scanning the wills whose testator object remains to be
3136 * marked.
3137 *
3138 * The wills that have become executable are also transferred from
3139 * the nonexecutable wills list to the executable wills list.
3140 */
3141
3142 tail_exec = &___ps->executable_wills;
3143 curr = *tail_exec;
3144
3145 while (___UNTAG(curr)((long*)((curr)&-(1<<2))) != 0)
3146 {
3147 ___WORDlong will = ___TAG(___UNTAG(curr),___tSUBTYPED)(((long)(((long*)((curr)&-(1<<2)))))+(1));
3148
3149 mark_array (&will, 1);
3150
3151 *tail_exec = ___TAG(___UNTAG(will),___EXECUTABLE_WILL)(((long)(((long*)((will)&-(1<<2)))))+(1));
3152 tail_exec = &___BODY_AS(will,___tSUBTYPED)(((long*)((will)-(1)))+1)[0];
3153 curr = *tail_exec;
3154 if (curr & ___UNMARKED_TESTATOR_WILL2)
3155 mark_array (tail_exec+1, 1); /* mark testator object */
3156 }
3157
3158 tail_nonexec = &___ps->nonexecutable_wills;
3159 curr = *tail_nonexec;
3160
3161 while (___UNTAG(curr)((long*)((curr)&-(1<<2))) != 0)
3162 {
3163 ___WORDlong will = ___TAG(___UNTAG(curr),___tSUBTYPED)(((long)(((long*)((curr)&-(1<<2)))))+(1));
3164
3165 mark_array (&will, 1);
3166
3167 if (___BODY_AS(will,___tSUBTYPED)(((long*)((will)-(1)))+1)[0] & ___EXECUTABLE_WILL1)
3168 {
3169 /* move will to executable will list */
3170
3171 *tail_exec = ___TAG(___UNTAG(will),___EXECUTABLE_WILL)(((long)(((long*)((will)&-(1<<2)))))+(1));
3172 tail_exec = &___BODY_AS(will,___tSUBTYPED)(((long*)((will)-(1)))+1)[0];
3173 curr = *tail_exec;
3174 if (curr & ___UNMARKED_TESTATOR_WILL2)
3175 mark_array (tail_exec+1, 1); /* mark testator object */
3176 }
3177 else
3178 {
3179 /* leave will in nonexecutable will list */
3180
3181 *tail_nonexec = ___TAG(___UNTAG(will),0)(((long)(((long*)((will)&-(1<<2)))))+(0));
3182 tail_nonexec = &___BODY_AS(will,___tSUBTYPED)(((long*)((will)-(1)))+1)[0];
3183 curr = *tail_nonexec;
3184 if (curr & ___UNMARKED_TESTATOR_WILL2)
3185 mark_array (tail_nonexec+1, 1); /* mark testator object */
3186 }
3187 }
3188
3189 *tail_exec = ___TAG(0,___EXECUTABLE_WILL)(((long)(0))+(1));
3190 *tail_nonexec = ___TAG(0,0)(((long)(0))+(0));
3191}
3192
3193
3194___HIDDENstatic void process_gc_hash_tables ___PVOID(void)
3195{
3196 ___WORDlong curr = reached_gc_hash_tables;
3197
3198 while (curr != ___TAG(0,0)(((long)(0))+(0)))
3199 {
3200 ___WORDlong* body = ___BODY(curr)(((long*)((curr)&-(1<<2)))+1);
3201 ___SIZE_TSlong words = ___HD_WORDS(body[-1])(((((unsigned long)(body[-1]))+((8 -1)<<(3 +5))))>>
((3 +5)+3))
;
3202 int flags = ___INT(body[___GCHASHTABLE_FLAGS])((body[1])>>2);
3203 int i;
3204
3205 curr = body[0];
3206
3207 body[0] = ___FIX(0)(((long)(0))<<2);
3208
3209 if (((___GCHASHTABLE_FLAG_WEAK_KEYS1 | ___GCHASHTABLE_FLAG_MEM_ALLOC_KEYS16)
3210 & flags) ==
3211 (___GCHASHTABLE_FLAG_WEAK_KEYS1 | ___GCHASHTABLE_FLAG_MEM_ALLOC_KEYS16))
3212 {
3213 if (flags & ___GCHASHTABLE_FLAG_WEAK_VALS2)
3214 {
3215 /*
3216 * GC hash table is weak on keys and on values.
3217 */
3218
3219 /*
3220 * Eliminate GC hash table entries with an unmarked key
3221 * or an unmarked value.
3222 */
3223
3224 for (i=words-2; i>=___GCHASHTABLE_KEY05; i-=2)
3225 {
3226 ___WORDlong *unmarked_body; /* used by the UNMARKED macro */
3227 int unmarked_typ;
3228
3229 ___WORDlong key = body[i];
3230 ___WORDlong val = body[i+1];
3231
3232 if (___MEM_ALLOCATED(key)((key)&1))
3233 {
3234 ___WORDlong key_head = ___BODY(key)(((long*)((key)&-(1<<2)))+1)[-1];
3235
3236 if (___TYP(key_head)((key_head)&((1<<2)-1)) == ___FORW3)
3237 {
3238 /*
3239 * The key is movable and has been
3240 * forwarded.
3241 */
3242
3243 if (___MEM_ALLOCATED(val)((val)&1))
3244 {
3245 ___WORDlong val_head = ___BODY(val)(((long*)((val)&-(1<<2)))+1)[-1];
3246
3247 if (___TYP(val_head)((val_head)&((1<<2)-1)) == ___FORW3)
3248 {
3249 /*
3250 * The key is movable and has been
3251 * forwarded and the value is
3252 * movable and has been forwarded,
3253 * so update key field and value
3254 * field and remember to rehash next
3255 * time the GC hash table is
3256 * accessed.
3257 */
3258
3259 body[i] =
3260 ___TAG(___UNTAG_AS(key_head, ___FORW),(((long)(((long*)((key_head)-(3)))))+(((key)&((1<<2
)-1))))
3261 ___TYP(key))(((long)(((long*)((key_head)-(3)))))+(((key)&((1<<2
)-1))))
;
3262 body[i+1] =
3263 ___TAG(___UNTAG_AS(val_head, ___FORW),(((long)(((long*)((val_head)-(3)))))+(((val)&((1<<2
)-1))))
3264 ___TYP(val))(((long)(((long*)((val_head)-(3)))))+(((val)&((1<<2
)-1))))
;
3265 flags |= ___GCHASHTABLE_FLAG_KEY_MOVED4;
3266 }
3267 else if (UNMARKED(val)(((unmarked_typ = (((unmarked_body=(((long*)((val)&-(1<<
2)))+1))[-1])&((1<<3)-1))) == 0) || (unmarked_typ ==
5 && unmarked_body[3 - (5+1)] == -1))
)
3268 {
3269 /*
3270 * Change the entry to indicate it
3271 * has been deleted.
3272 */
3273
3274 body[i] = ___DELETED((((long)(-15))<<2)+2);
3275 body[i+1] = ___UNUSED((((long)(-14))<<2)+2);
3276 body[___GCHASHTABLE_COUNT2] =
3277 ___FIXSUB(body[___GCHASHTABLE_COUNT],((long)((body[2])-((((long)(1))<<2))))
3278 ___FIX(1))((long)((body[2])-((((long)(1))<<2))));
3279 flags |= ___GCHASHTABLE_FLAG_ENTRY_DELETED8;
3280 }
3281 else
3282 {
3283 /*
3284 * The key is movable and has been
3285 * forwarded and the value is not
3286 * movable and is reachable, so
3287 * update key field and remember to
3288 * rehash next time the GC hash
3289 * table is accessed.
3290 */
3291
3292 body[i] =
3293 ___TAG(___UNTAG_AS(key_head, ___FORW),(((long)(((long*)((key_head)-(3)))))+(((key)&((1<<2
)-1))))
3294 ___TYP(key))(((long)(((long*)((key_head)-(3)))))+(((key)&((1<<2
)-1))))
;
3295 flags |= ___GCHASHTABLE_FLAG_KEY_MOVED4;
3296 }
3297 }
3298 else
3299 {
3300 /*
3301 * The key is movable and has been
3302 * forwarded, and the value is not
3303 * memory allocated, so update key field
3304 * and remember to rehash next time the
3305 * GC hash table is accessed.
3306 */
3307
3308 body[i] =
3309 ___TAG(___UNTAG_AS(key_head, ___FORW),(((long)(((long*)((key_head)-(3)))))+(((key)&((1<<2
)-1))))
3310 ___TYP(key))(((long)(((long*)((key_head)-(3)))))+(((key)&((1<<2
)-1))))
;
3311 flags |= ___GCHASHTABLE_FLAG_KEY_MOVED4;
3312 }
3313 }
3314 else if (UNMARKED(key)(((unmarked_typ = (((unmarked_body=(((long*)((key)&-(1<<
2)))+1))[-1])&((1<<3)-1))) == 0) || (unmarked_typ ==
5 && unmarked_body[3 - (5+1)] == -1))
)
3315 {
3316 /*
3317 * Change the entry to indicate it has been
3318 * deleted.
3319 */
3320
3321 body[i] = ___DELETED((((long)(-15))<<2)+2);
3322 body[i+1] = ___UNUSED((((long)(-14))<<2)+2);
3323 body[___GCHASHTABLE_COUNT2] =
3324 ___FIXSUB(body[___GCHASHTABLE_COUNT],___FIX(1))((long)((body[2])-((((long)(1))<<2))));
3325 flags |= ___GCHASHTABLE_FLAG_ENTRY_DELETED8;
3326 }
3327 else
3328 {
3329 /*
3330 * The key is not movable and is reachable.
3331 */
3332
3333 if (___MEM_ALLOCATED(val)((val)&1))
3334 {
3335 ___WORDlong val_head = ___BODY(val)(((long*)((val)&-(1<<2)))+1)[-1];
3336
3337 if (___TYP(val_head)((val_head)&((1<<2)-1)) == ___FORW3)
3338 {
3339 /*
3340 * The key is not movable and is
3341 * reachable and the value is
3342 * movable and has been forwarded,
3343 * so update value field.
3344 */
3345
3346 body[i+1] =
3347 ___TAG(___UNTAG_AS(val_head, ___FORW),(((long)(((long*)((val_head)-(3)))))+(((val)&((1<<2
)-1))))
3348 ___TYP(val))(((long)(((long*)((val_head)-(3)))))+(((val)&((1<<2
)-1))))
;
3349 }
3350 else if (UNMARKED(val)(((unmarked_typ = (((unmarked_body=(((long*)((val)&-(1<<
2)))+1))[-1])&((1<<3)-1))) == 0) || (unmarked_typ ==
5 && unmarked_body[3 - (5+1)] == -1))
)
3351 {
3352 /*
3353 * Change the entry to indicate it
3354 * has been deleted.
3355 */
3356
3357 body[i] = ___DELETED((((long)(-15))<<2)+2);
3358 body[i+1] = ___UNUSED((((long)(-14))<<2)+2);
3359 body[___GCHASHTABLE_COUNT2] =
3360 ___FIXSUB(body[___GCHASHTABLE_COUNT],((long)((body[2])-((((long)(1))<<2))))
3361 ___FIX(1))((long)((body[2])-((((long)(1))<<2))));
3362 flags |= ___GCHASHTABLE_FLAG_ENTRY_DELETED8;
3363 }
3364 else
3365 {
3366 /*
3367 * The key is not movable and is
3368 * reachable and the value is not
3369 * movable and is reachable, so
3370 * leave fields untouched.
3371 */
3372 }
3373 }
3374 else
3375 {
3376 /*
3377 * The key is not movable and is
3378 * reachable and the value is not memory
3379 * allocated, so leave fields untouched.
3380 */
3381 }
3382 }
3383 }
3384 else
3385 {
3386 /*
3387 * The key is not memory allocated.
3388 */
3389
3390 if (___MEM_ALLOCATED(val)((val)&1))
3391 {
3392 ___WORDlong val_head = ___BODY(val)(((long*)((val)&-(1<<2)))+1)[-1];
3393
3394 if (___TYP(val_head)((val_head)&((1<<2)-1)) == ___FORW3)
3395 {
3396 /*
3397 * The key is not memory allocated and
3398 * the value is movable and has been
3399 * forwarded, so update value field.
3400 */
3401
3402 body[i+1] =
3403 ___TAG(___UNTAG_AS(val_head, ___FORW),(((long)(((long*)((val_head)-(3)))))+(((val)&((1<<2
)-1))))
3404 ___TYP(val))(((long)(((long*)((val_head)-(3)))))+(((val)&((1<<2
)-1))))
;
3405 }
3406 else if (UNMARKED(val)(((unmarked_typ = (((unmarked_body=(((long*)((val)&-(1<<
2)))+1))[-1])&((1<<3)-1))) == 0) || (unmarked_typ ==
5 && unmarked_body[3 - (5+1)] == -1))
)
3407 {
3408 /*
3409 * Change the entry to indicate it
3410 * has been deleted.
3411 */
3412
3413 body[i] = ___DELETED((((long)(-15))<<2)+2);
3414 body[i+1] = ___UNUSED((((long)(-14))<<2)+2);
3415 body[___GCHASHTABLE_COUNT2] =
3416 ___FIXSUB(body[___GCHASHTABLE_COUNT],((long)((body[2])-((((long)(1))<<2))))
3417 ___FIX(1))((long)((body[2])-((((long)(1))<<2))));
3418 flags |= ___GCHASHTABLE_FLAG_ENTRY_DELETED8;
3419 }
3420 else
3421 {
3422 /*
3423 * The key is not memory allocated and
3424 * the value is not movable and is
3425 * reachable, so leave fields untouched.
3426 */
3427 }
3428 }
3429 else
3430 {
3431 /*
3432 * The key is not memory allocated and the
3433 * value is not memory allocated, so leave
3434 * fields untouched.
3435 */
3436 }
3437 }
3438 }
3439 }
3440 else
3441 {
3442 /*
3443 * GC hash table is weak on keys only.
3444 */
3445
3446 /*
3447 * Eliminate GC hash table entries with an unmarked key.
3448 */
3449
3450 for (i=words-2; i>=___GCHASHTABLE_KEY05; i-=2)
3451 {
3452 ___WORDlong *unmarked_body; /* used by the UNMARKED macro */
3453 int unmarked_typ;
3454
3455 ___WORDlong key = body[i];
3456
3457 if (___MEM_ALLOCATED(key)((key)&1))
3458 {
3459 ___WORDlong head = ___BODY(key)(((long*)((key)&-(1<<2)))+1)[-1];
3460
3461 if (___TYP(head)((head)&((1<<2)-1)) == ___FORW3)
3462 {
3463 /*
3464 * The key is movable and has been
3465 * forwarded, so update key field and
3466 * remember to rehash next time the
3467 * GC hash table is accessed.
3468 */
3469
3470 body[i] = ___TAG(___UNTAG_AS(head, ___FORW),(((long)(((long*)((head)-(3)))))+(((key)&((1<<2)-1)
)))
3471 ___TYP(key))(((long)(((long*)((head)-(3)))))+(((key)&((1<<2)-1)
)))
;
3472 flags |= ___GCHASHTABLE_FLAG_KEY_MOVED4;
3473 }
3474 else if (UNMARKED(key)(((unmarked_typ = (((unmarked_body=(((long*)((key)&-(1<<
2)))+1))[-1])&((1<<3)-1))) == 0) || (unmarked_typ ==
5 && unmarked_body[3 - (5+1)] == -1))
)
3475 {
3476 /*
3477 * Change the entry to indicate it has been
3478 * deleted.
3479 */
3480
3481 body[i] = ___DELETED((((long)(-15))<<2)+2);
3482 body[i+1] = ___UNUSED((((long)(-14))<<2)+2);
3483 body[___GCHASHTABLE_COUNT2] =
3484 ___FIXSUB(body[___GCHASHTABLE_COUNT],___FIX(1))((long)((body[2])-((((long)(1))<<2))));
3485 flags |= ___GCHASHTABLE_FLAG_ENTRY_DELETED8;
3486 }
3487 }
3488 }
3489 }
3490 }
3491 else
3492 {
3493 if (flags & ___GCHASHTABLE_FLAG_WEAK_VALS2)
3494 {
3495 /*
3496 * GC hash table is weak on values only.
3497 */
3498
3499 /*
3500 * Eliminate GC hash table entries with an unmarked value.
3501 */
3502
3503 for (i=words-2; i>=___GCHASHTABLE_KEY05; i-=2)
3504 {
3505 ___WORDlong *unmarked_body; /* used by the UNMARKED macro */
3506 int unmarked_typ;
3507
3508 ___WORDlong val = body[i+1];
3509
3510 if (___MEM_ALLOCATED(val)((val)&1))
3511 {
3512 ___WORDlong head = ___BODY(val)(((long*)((val)&-(1<<2)))+1)[-1];
3513
3514 if (___TYP(head)((head)&((1<<2)-1)) == ___FORW3)
3515 {
3516 /*
3517 * The value is movable and has been
3518 * forwarded, so update value field.
3519 */
3520
3521 body[i+1] = ___TAG(___UNTAG_AS(head, ___FORW),(((long)(((long*)((head)-(3)))))+(((val)&((1<<2)-1)
)))
3522 ___TYP(val))(((long)(((long*)((head)-(3)))))+(((val)&((1<<2)-1)
)))
;
3523 }
3524 else if (UNMARKED(val)(((unmarked_typ = (((unmarked_body=(((long*)((val)&-(1<<
2)))+1))[-1])&((1<<3)-1))) == 0) || (unmarked_typ ==
5 && unmarked_body[3 - (5+1)] == -1))
)
3525 {
3526 /*
3527 * Change the entry to indicate it has been
3528 * deleted.
3529 */
3530
3531 body[i] = ___DELETED((((long)(-15))<<2)+2);
3532 body[i+1] = ___UNUSED((((long)(-14))<<2)+2);
3533 body[___GCHASHTABLE_COUNT2] =
3534 ___FIXSUB(body[___GCHASHTABLE_COUNT],___FIX(1))((long)((body[2])-((((long)(1))<<2))));
3535 flags |= ___GCHASHTABLE_FLAG_ENTRY_DELETED8;
3536 }
3537 }
3538 }
3539 }
3540
3541 if (flags & ___GCHASHTABLE_FLAG_MEM_ALLOC_KEYS16)
3542 flags |= ___GCHASHTABLE_FLAG_KEY_MOVED4; /* assume worst case */
3543 }
3544
3545 body[___GCHASHTABLE_FLAGS1] = ___FIX(flags)(((long)(flags))<<2);
3546 }
3547}
3548
3549
3550void ___gc_hash_table_rehash_in_situ
3551 ___P((___SCMOBJ ht),(long ht)
3552 (ht)(long ht)
3553___SCMOBJ ht;)(long ht)
3554{
3555 ___WORDlong* body = ___BODY_AS(ht,___tSUBTYPED)(((long*)((ht)-(1)))+1);
3556 ___SIZE_TSlong words = ___HD_WORDS(body[-1])(((((unsigned long)(body[-1]))+((8 -1)<<(3 +5))))>>
((3 +5)+3))
;
3557 int size2 = ___INT(___VECTORLENGTH(ht))(((((long)((((unsigned long)((*((long*)((ht)-(1))))))>>
((3 +5)+3))))<<2))>>2)
- ___GCHASHTABLE_KEY05;
3558 int i;
3559
3560 ___FIELD(ht, ___GCHASHTABLE_FLAGS)(*((((long*)((ht)-(1)))+1)+1)) =
3561 ___FIXAND(___FIELD(ht, ___GCHASHTABLE_FLAGS),((long)(((*((((long*)((ht)-(1)))+1)+1)))&(((long)(((((long
)(4))<<2))^~((1<<2)-1))))))
3562 ___FIXNOT(___FIX(___GCHASHTABLE_FLAG_KEY_MOVED)))((long)(((*((((long*)((ht)-(1)))+1)+1)))&(((long)(((((long
)(4))<<2))^~((1<<2)-1))))))
;
3563
3564 if (___FIXZEROP(___FIXAND(body[___GCHASHTABLE_FLAGS],((((long)((body[1])&((((long)(16))<<2)))))==0)
3565 ___FIX(___GCHASHTABLE_FLAG_MEM_ALLOC_KEYS)))((((long)((body[1])&((((long)(16))<<2)))))==0))
3566 {
3567 /*
3568 * Free deleted entries and mark key field of all active
3569 * entries.
3570 */
3571
3572 for (i=___GCHASHTABLE_KEY05; i<words; i+=2)
3573 {
3574 ___WORDlong key = body[i];
3575 if (key == ___DELETED((((long)(-15))<<2)+2))
3576 {
3577 body[i] = ___UNUSED((((long)(-14))<<2)+2);
3578 body[___GCHASHTABLE_FREE4] =
3579 ___FIXADD(body[___GCHASHTABLE_FREE], ___FIX(1))((long)((body[4])+((((long)(1))<<2))));
3580 }
3581 else if (key != ___UNUSED((((long)(-14))<<2)+2))
3582 body[i] = ___MEM_ALLOCATED_SET(key)((key)|1);
3583 }
3584
3585 /*
3586 * Move the active entries.
3587 */
3588
3589 for (i=___GCHASHTABLE_KEY05; i<words; i+=2)
3590 {
3591 ___WORDlong key = body[i];
3592
3593 if (___MEM_ALLOCATED(key)((key)&1))
3594 {
3595 /* this is an active entry that has not been moved yet */
3596
3597 ___SCMOBJlong val = body[i+1];
3598 ___SCMOBJlong obj;
3599 int probe2;
3600 int step2;
3601
3602 body[i] = ___UNUSED((((long)(-14))<<2)+2);
3603 body[i+1] = ___UNUSED((((long)(-14))<<2)+2);
3604
3605 chain_non_mem_alloc:
3606 key = ___MEM_ALLOCATED_CLEAR(key)((key)&~((long)(1))); /* recover true encoding */
3607 probe2 = ___GCHASHTABLE_HASH1(key,size2>>1)((((key)>>2)&((((long)(1))<<((64 -2)-1))-1))%
(size2>>1))
<< 1;
3608 step2 = ___GCHASHTABLE_HASH2(key,size2>>1)(((((key)>>2)&((((long)(1))<<((64 -2)-1))-1))
%((size2>>1)-1))+1)
<< 1;
3609
3610 next_non_mem_alloc:
3611 obj = body[probe2+___GCHASHTABLE_KEY05];
3612
3613 if (obj == ___UNUSED((((long)(-14))<<2)+2))
3614 {
3615 /* storing into an unused entry */
3616
3617 body[probe2+___GCHASHTABLE_KEY05] = key;
3618 body[probe2+___GCHASHTABLE_VAL06] = val;
3619 }
3620 else if (___MEM_ALLOCATED(obj)((obj)&1))
3621 {
3622 /* storing into an active entry */
3623
3624 body[probe2+___GCHASHTABLE_KEY05] = key;
3625 key = obj;
3626 obj = body[probe2+___GCHASHTABLE_VAL06];
3627 body[probe2+___GCHASHTABLE_VAL06] = val;
3628 val = obj;
3629 goto chain_non_mem_alloc; /* now move overwritten entry */
3630 }
3631 else
3632 {
3633 /* an entry has been moved here, so keep looking */
3634
3635 probe2 -= step2;
3636 if (probe2 < 0)
3637 probe2 += size2;
3638 goto next_non_mem_alloc;
3639 }
3640 }
3641 }
3642 }
3643 else
3644 {
3645 /*
3646 * Free deleted entries and mark key field of all active
3647 * entries.
3648 */
3649
3650 for (i=___GCHASHTABLE_KEY05; i<words; i+=2)
3651 {
3652 ___WORDlong key = body[i];
3653 if (key == ___DELETED((((long)(-15))<<2)+2))
3654 {
3655 body[i] = ___UNUSED((((long)(-14))<<2)+2);
3656 body[___GCHASHTABLE_FREE4] =
3657 ___FIXADD(body[___GCHASHTABLE_FREE], ___FIX(1))((long)((body[4])+((((long)(1))<<2))));
3658 }
3659 else
3660 body[i] = ___MEM_ALLOCATED_CLEAR(key)((key)&~((long)(1)));
3661 }
3662
3663 /*
3664 * Move the active entries.
3665 */
3666
3667 for (i=___GCHASHTABLE_KEY05; i<words; i+=2)
3668 {
3669 ___WORDlong key = body[i];
3670
3671 if (key != ___UNUSED((((long)(-14))<<2)+2) && !___MEM_ALLOCATED(key)((key)&1))
3672 {
3673 /* this is an active entry that has not been moved yet */
3674
3675 ___SCMOBJlong val = body[i+1];
3676 ___SCMOBJlong obj;
3677 int probe2;
3678 int step2;
3679
3680 body[i] = ___UNUSED((((long)(-14))<<2)+2);
3681 body[i+1] = ___UNUSED((((long)(-14))<<2)+2);
3682
3683 chain_mem_alloc:
3684 key = ___MEM_ALLOCATED_SET(key)((key)|1); /* recover true encoding */
3685 probe2 = ___GCHASHTABLE_HASH1(key,size2>>1)((((key)>>2)&((((long)(1))<<((64 -2)-1))-1))%
(size2>>1))
<< 1;
3686 step2 = ___GCHASHTABLE_HASH2(key,size2>>1)(((((key)>>2)&((((long)(1))<<((64 -2)-1))-1))
%((size2>>1)-1))+1)
<< 1;
3687
3688 next_mem_alloc:
3689 obj = body[probe2+___GCHASHTABLE_KEY05];
3690
3691 if (obj == ___UNUSED((((long)(-14))<<2)+2))
3692 {
3693 /* storing into an unused entry */
3694
3695 body[probe2+___GCHASHTABLE_KEY05] = key;
3696 body[probe2+___GCHASHTABLE_VAL06] = val;
3697 }
3698 else if (!___MEM_ALLOCATED(obj)((obj)&1))
3699 {
3700 /* storing into an active entry */
3701
3702 body[probe2+___GCHASHTABLE_KEY05] = key;
3703 key = obj;
3704 obj = body[probe2+___GCHASHTABLE_VAL06];
3705 body[probe2+___GCHASHTABLE_VAL06] = val;
3706 val = obj;
3707 goto chain_mem_alloc; /* now move overwritten entry */
3708 }
3709 else
3710 {
3711 /* an entry has been moved here, so keep looking */
3712
3713 probe2 -= step2;
3714 if (probe2 < 0)
3715 probe2 += size2;
3716 goto next_mem_alloc;
3717 }
3718 }
3719 }
3720 }
3721}
3722
3723___SCMOBJlong ___gc_hash_table_ref
3724 ___P((___SCMOBJ ht,(long ht, long key)
3725 ___SCMOBJ key),(long ht, long key)
3726 (ht,(long ht, long key)
3727 key)(long ht, long key)
3728___SCMOBJ ht;(long ht, long key)
3729___SCMOBJ key;)(long ht, long key)
3730{
3731 int size2;
3732 int probe2;
3733 ___SCMOBJlong obj;
3734
3735 if (!___FIXZEROP(___FIXAND(___FIELD(ht, ___GCHASHTABLE_FLAGS),((((long)(((*((((long*)((ht)-(1)))+1)+1)))&((((long)(4))<<
2)))))==0)
3736 ___FIX(___GCHASHTABLE_FLAG_KEY_MOVED)))((((long)(((*((((long*)((ht)-(1)))+1)+1)))&((((long)(4))<<
2)))))==0)
)
3737 ___gc_hash_table_rehash_in_situ (ht);
3738
3739 size2 = ___INT(___VECTORLENGTH(ht))(((((long)((((unsigned long)((*((long*)((ht)-(1))))))>>
((3 +5)+3))))<<2))>>2)
- ___GCHASHTABLE_KEY05;
3740 probe2 = ___GCHASHTABLE_HASH1(key,size2>>1)((((key)>>2)&((((long)(1))<<((64 -2)-1))-1))%
(size2>>1))
<< 1;
3741 obj = ___FIELD(ht, probe2+___GCHASHTABLE_KEY0)(*((((long*)((ht)-(1)))+1)+probe2+5));
3742
3743 if (___EQP(obj,key)((obj)==(key)))
3744 return ___FIELD(ht, probe2+___GCHASHTABLE_VAL0)(*((((long*)((ht)-(1)))+1)+probe2+6));
3745 else if (!___EQP(obj,___UNUSED)((obj)==(((((long)(-14))<<2)+2))))
3746 {
3747 int step2 = ___GCHASHTABLE_HASH2(key,size2>>1)(((((key)>>2)&((((long)(1))<<((64 -2)-1))-1))
%((size2>>1)-1))+1)
<< 1;
3748
3749 for (;;)
3750 {
3751 probe2 -= step2;
3752 if (probe2 < 0)
3753 probe2 += size2;
3754 obj = ___FIELD(ht, probe2+___GCHASHTABLE_KEY0)(*((((long*)((ht)-(1)))+1)+probe2+5));
3755
3756 if (___EQP(obj,key)((obj)==(key)))
3757 return ___FIELD(ht, probe2+___GCHASHTABLE_VAL0)(*((((long*)((ht)-(1)))+1)+probe2+6));
3758 else if (___EQP(obj,___UNUSED)((obj)==(((((long)(-14))<<2)+2))))
3759 break;
3760 }
3761 }
3762
3763 return ___UNUSED((((long)(-14))<<2)+2); /* key was not found */
3764}
3765
3766___SCMOBJlong ___gc_hash_table_set
3767 ___P((___SCMOBJ ht,(long ht, long key, long val)
3768 ___SCMOBJ key,(long ht, long key, long val)
3769 ___SCMOBJ val),(long ht, long key, long val)
3770 (ht,(long ht, long key, long val)
3771 key,(long ht, long key, long val)
3772 val)(long ht, long key, long val)
3773___SCMOBJ ht;(long ht, long key, long val)
3774___SCMOBJ key;(long ht, long key, long val)
3775___SCMOBJ val;)(long ht, long key, long val)
3776{
3777 int size2;
3778 int probe2;
3779 ___SCMOBJlong obj;
3780
3781 if (!___FIXZEROP(___FIXAND(___FIELD(ht, ___GCHASHTABLE_FLAGS),((((long)(((*((((long*)((ht)-(1)))+1)+1)))&((((long)(4))<<
2)))))==0)
3782 ___FIX(___GCHASHTABLE_FLAG_KEY_MOVED)))((((long)(((*((((long*)((ht)-(1)))+1)+1)))&((((long)(4))<<
2)))))==0)
)
3783 ___gc_hash_table_rehash_in_situ (ht);
3784
3785 size2 = ___INT(___VECTORLENGTH(ht))(((((long)((((unsigned long)((*((long*)((ht)-(1))))))>>
((3 +5)+3))))<<2))>>2)
- ___GCHASHTABLE_KEY05;
3786 probe2 = ___GCHASHTABLE_HASH1(key,size2>>1)((((key)>>2)&((((long)(1))<<((64 -2)-1))-1))%
(size2>>1))
<< 1;
3787 obj = ___FIELD(ht, probe2+___GCHASHTABLE_KEY0)(*((((long*)((ht)-(1)))+1)+probe2+5));
3788
3789 if (!___EQP(val,___ABSENT)((val)==(((((long)(-6))<<2)+2))))
3790 {
3791 /* trying to add or replace an entry */
3792
3793 if (___EQP(obj,key)((obj)==(key)))
3794 {
3795 replace_entry:
3796 ___FIELD(ht, probe2+___GCHASHTABLE_VAL0)(*((((long*)((ht)-(1)))+1)+probe2+6)) = val;
3797 }
3798 else if (___EQP(obj,___UNUSED)((obj)==(((((long)(-14))<<2)+2))))
3799 {
3800 add_entry:
3801 ___FIELD(ht, probe2+___GCHASHTABLE_KEY0)(*((((long*)((ht)-(1)))+1)+probe2+5)) = key;
3802 ___FIELD(ht, probe2+___GCHASHTABLE_VAL0)(*((((long*)((ht)-(1)))+1)+probe2+6)) = val;
3803 ___FIELD(ht, ___GCHASHTABLE_COUNT)(*((((long*)((ht)-(1)))+1)+2)) =
3804 ___FIXADD(___FIELD(ht, ___GCHASHTABLE_COUNT), ___FIX(1))((long)(((*((((long*)((ht)-(1)))+1)+2)))+((((long)(1))<<
2))))
;
3805 if (___FIXNEGATIVEP(___FIELD(ht, ___GCHASHTABLE_FREE) =(((*((((long*)((ht)-(1)))+1)+4)) = ((long)(((*((((long*)((ht)
-(1)))+1)+4)))-((((long)(1))<<2)))))<0)
3806 ___FIXSUB(___FIELD(ht, ___GCHASHTABLE_FREE),(((*((((long*)((ht)-(1)))+1)+4)) = ((long)(((*((((long*)((ht)
-(1)))+1)+4)))-((((long)(1))<<2)))))<0)
3807 ___FIX(1)))(((*((((long*)((ht)-(1)))+1)+4)) = ((long)(((*((((long*)((ht)
-(1)))+1)+4)))-((((long)(1))<<2)))))<0)
)
3808 return ___TRU((((long)(-2))<<2)+2);
3809 }
3810 else
3811 {
3812 int step2 = ___GCHASHTABLE_HASH2(key,size2>>1)(((((key)>>2)&((((long)(1))<<((64 -2)-1))-1))
%((size2>>1)-1))+1)
<< 1;
3813 int deleted2 = -1;
3814
3815 for (;;)
3816 {
3817 if (deleted2 < 0 && ___EQP(obj,___DELETED)((obj)==(((((long)(-15))<<2)+2))))
3818 deleted2 = probe2;
3819
3820 probe2 -= step2;
3821 if (probe2 < 0)
3822 probe2 += size2;
3823 obj = ___FIELD(ht, probe2+___GCHASHTABLE_KEY0)(*((((long*)((ht)-(1)))+1)+probe2+5));
3824
3825 if (___EQP(obj,key)((obj)==(key)))
3826 goto replace_entry;
3827
3828 if (___EQP(obj,___UNUSED)((obj)==(((((long)(-14))<<2)+2))))
3829 {
3830 if (deleted2 < 0)
3831 goto add_entry;
3832
3833 ___FIELD(ht, deleted2+___GCHASHTABLE_KEY0)(*((((long*)((ht)-(1)))+1)+deleted2+5)) = key;
3834 ___FIELD(ht, deleted2+___GCHASHTABLE_VAL0)(*((((long*)((ht)-(1)))+1)+deleted2+6)) = val;
3835 ___FIELD(ht, ___GCHASHTABLE_COUNT)(*((((long*)((ht)-(1)))+1)+2)) =
3836 ___FIXADD(___FIELD(ht, ___GCHASHTABLE_COUNT), ___FIX(1))((long)(((*((((long*)((ht)-(1)))+1)+2)))+((((long)(1))<<
2))))
;
3837
3838 break;
3839 }
3840 }
3841 }
3842 }
3843 else
3844 {
3845 /* trying to delete an entry */
3846
3847 if (___EQP(obj,key)((obj)==(key)))
3848 {
3849 delete_entry:
3850 ___FIELD(ht, probe2+___GCHASHTABLE_KEY0)(*((((long*)((ht)-(1)))+1)+probe2+5)) = ___DELETED((((long)(-15))<<2)+2);
3851 ___FIELD(ht, probe2+___GCHASHTABLE_VAL0)(*((((long*)((ht)-(1)))+1)+probe2+6)) = ___UNUSED((((long)(-14))<<2)+2);
3852 ___FIELD(ht, ___GCHASHTABLE_COUNT)(*((((long*)((ht)-(1)))+1)+2)) =
3853 ___FIXSUB(___FIELD(ht, ___GCHASHTABLE_COUNT),((long)(((*((((long*)((ht)-(1)))+1)+2)))-((((long)(1))<<
2))))
3854 ___FIX(1))((long)(((*((((long*)((ht)-(1)))+1)+2)))-((((long)(1))<<
2))))
;
3855 if (___FIXLT(___FIELD(ht, ___GCHASHTABLE_COUNT),(((*((((long*)((ht)-(1)))+1)+2)))<((*((((long*)((ht)-(1)))
+1)+3))))
3856 ___FIELD(ht, ___GCHASHTABLE_MIN_COUNT))(((*((((long*)((ht)-(1)))+1)+2)))<((*((((long*)((ht)-(1)))
+1)+3))))
)
3857 return ___TRU((((long)(-2))<<2)+2);
3858 }
3859 else if (!___EQP(obj,___UNUSED)((obj)==(((((long)(-14))<<2)+2))))
3860 {
3861 int step2 = ___GCHASHTABLE_HASH2(key,size2>>1)(((((key)>>2)&((((long)(1))<<((64 -2)-1))-1))
%((size2>>1)-1))+1)
<< 1;
3862
3863 for (;;)
3864 {
3865 probe2 -= step2;
3866 if (probe2 < 0)
3867 probe2 += size2;
3868 obj = ___FIELD(ht, probe2+___GCHASHTABLE_KEY0)(*((((long*)((ht)-(1)))+1)+probe2+5));
3869
3870 if (___EQP(obj,key)((obj)==(key)))
3871 goto delete_entry;
3872
3873 if (___EQP(obj,___UNUSED)((obj)==(((((long)(-14))<<2)+2))))
3874 break;
3875 }
3876 }
3877 }
3878
3879 /*
3880 * Hash table does not need to be resized.
3881 */
3882
3883 return ___FAL((((long)(-1))<<2)+2);
3884}
3885
3886___SCMOBJlong ___gc_hash_table_rehash
3887 ___P((___SCMOBJ ht_src,(long ht_src, long ht_dst)
3888 ___SCMOBJ ht_dst),(long ht_src, long ht_dst)
3889 (ht_src,(long ht_src, long ht_dst)
3890 ht_dst)(long ht_src, long ht_dst)
3891___SCMOBJ ht_src;(long ht_src, long ht_dst)
3892___SCMOBJ ht_dst;)(long ht_src, long ht_dst)
3893{
3894 ___WORDlong* body_src = ___BODY_AS(ht_src,___tSUBTYPED)(((long*)((ht_src)-(1)))+1);
3895 ___SIZE_TSlong words = ___HD_WORDS(body_src[-1])(((((unsigned long)(body_src[-1]))+((8 -1)<<(3 +5))))>>
((3 +5)+3))
;
3896 int i;
3897
3898 for (i=___GCHASHTABLE_KEY05; i<words; i+=2)
3899 {
3900 ___WORDlong key = body_src[i];
3901
3902 if (key != ___UNUSED((((long)(-14))<<2)+2) &&
3903 key != ___DELETED((((long)(-15))<<2)+2))
3904 ___gc_hash_table_set (ht_dst, key, body_src[i+1]);
3905 }
3906
3907 return ht_dst;
3908}
3909
3910#ifdef ___DEBUG_GARBAGE_COLLECT
3911
3912___BOOLint ___garbage_collect_debug
3913 ___P((___SIZE_TS nonmovable_words_needed,(long nonmovable_words_needed, int line, char *file)
3914 int line,(long nonmovable_words_needed, int line, char *file)
3915 char *file),(long nonmovable_words_needed, int line, char *file)
3916 (nonmovable_words_needed,(long nonmovable_words_needed, int line, char *file)
3917 line,(long nonmovable_words_needed, int line, char *file)
3918 file)(long nonmovable_words_needed, int line, char *file)
3919___SIZE_TS nonmovable_words_needed;(long nonmovable_words_needed, int line, char *file)
3920int line;(long nonmovable_words_needed, int line, char *file)
3921char *file;)(long nonmovable_words_needed, int line, char *file)
3922
3923#else
3924
3925___BOOLint ___garbage_collect
3926 ___P((___SIZE_TS nonmovable_words_needed),(long nonmovable_words_needed)
3927 (nonmovable_words_needed)(long nonmovable_words_needed)
3928___SIZE_TS nonmovable_words_needed;)(long nonmovable_words_needed)
3929
3930#endif
3931{
3932 ___SIZE_TSlong avail;
3933 int target_nb_sections;
3934 int stack_msection_index;
3935 ___BOOLint overflow = 0;
3936 ___processor_state ___ps = ___PSTATE(&(&___gstate)->pstate);
3937 ___F64double user_time_start, sys_time_start, real_time_start;
3938 ___F64double user_time_end, sys_time_end, real_time_end;
3939 ___F64double gc_user_time, gc_sys_time, gc_real_time;
3940
3941 ___process_times (&user_time_start, &sys_time_start, &real_time_start);
3942
3943 alloc_stack_ptr = ___ps->fp; /* needed by 'WORDS_OCCUPIED' */
3944 alloc_heap_ptr = ___ps->hp; /* needed by 'WORDS_OCCUPIED' */
3945
3946#ifdef ___DEBUG_GARBAGE_COLLECT
3947 ___printf ("----------------------------------------- GC\n");
3948 ___printf ("heap_size = %d\n", heap_size);
3949 ___printf ("WORDS_OCCUPIED = %d\n", WORDS_OCCUPIED(words_nonmovable + (2*(words_prev_msections + (alloc_stack_start
- alloc_stack_ptr) + (alloc_heap_ptr - alloc_heap_start))))
);
3950 ___printf ("___ps->stack_start = 0x%08x\n", ___ps->stack_start);
3951 ___printf ("___ps->stack_break = 0x%08x\n", ___ps->stack_break);
3952 ___printf ("___ps->fp = 0x%08x\n", ___ps->fp);
3953 ___printf ("___ps->stack_limit = 0x%08x\n", ___ps->stack_limit);
3954 ___printf ("___ps->heap_limit = 0x%08x\n", ___ps->heap_limit);
3955 ___printf ("___ps->hp = 0x%08x\n", ___ps->hp);
3956#endif
3957
3958 words_nonmovable += nonmovable_words_needed;
3959
3960 ___GSTATE(&___gstate)->bytes_allocated_minus_occupied =
3961 ___GSTATE(&___gstate)->bytes_allocated_minus_occupied +
3962 ___CAST(___F64,WORDS_OCCUPIED)((double)((words_nonmovable + (2*(words_prev_msections + (alloc_stack_start
- alloc_stack_ptr) + (alloc_heap_ptr - alloc_heap_start)))))
)
* ___WS8;
3963
3964#ifdef GATHER_STATS
3965 movable_pair_objs = 0;
3966 {
3967 int i;
3968 for (i=0; i<=MAX_STAT_SIZE+1; i++)
3969 movable_subtyped_objs[i] = 0;
3970 }
3971#endif
3972
3973 stack_msection_index = stack_msection->index;
3974
3975 words_prev_msections = 0;
3976
3977 tospace_at_top = !tospace_at_top;
3978 stack_msection = 0;
3979 heap_msection = 0;
3980 nb_msections_used = 0;
3981
3982 next_heap_msection ();
3983
3984 scan_msection = heap_msection;
3985 scan_ptr = alloc_heap_ptr;
3986
3987 /* maintain list of GC hash tables reached by GC */
3988
3989 reached_gc_hash_tables = ___TAG(0,0)(((long)(0))+(0));
3990
3991 /* trace externally referenced still objects */
3992
3993 init_still_objs_to_scan ();
3994
3995 /* trace registers */
3996
3997#ifdef ENABLE_CONSISTENCY_CHECKS
3998 reference_location = IN_REGISTER;
3999#endif
4000
4001 mark_array (&___ps->current_thread, 1);
4002 mark_array (&___ps->run_queue, 1);
4003
4004 mark_array (___ps->r, ___NB_GVM_REGS5);
4005
4006 mark_array (&___GSTATE(&___gstate)->symbol_table, 1);
4007 mark_array (&___GSTATE(&___gstate)->keyword_table, 1);
4008
4009 /* trace global variables */
4010
4011#ifdef ENABLE_CONSISTENCY_CHECKS
4012 reference_location = IN_GLOBAL_VAR;
4013#endif
4014
4015#ifdef ___MULTIPLE_GLO
4016
4017 mark_array (___ps->glos, ___GSTATE(&___gstate)->nb_glo_vars);
4018
4019#else
4020
4021 {
4022 ___WORDlong p = ___ps->glo_list_head;
4023
4024 while (p != 0)
4025 {
4026#ifdef ___DEBUG_GARBAGE_COLLECT
4027 print_global_var_name (p);
4028#endif
4029 mark_array (&___GLOCELL(___CAST(___glo_struct*,p)->val)((___glo_struct*)(p))->val, 1);
4030 p = ___CAST(___glo_struct*,p)((___glo_struct*)(p))->next;
4031 }
4032 }
4033
4034#endif
4035
4036 /* trace continuation */
4037
4038#ifdef ENABLE_CONSISTENCY_CHECKS
4039 reference_location = IN_CONTINUATION;
4040#endif
4041
4042 mark_continuation ();
4043
4044 /* trace reference counted objects */
4045
4046#ifdef ENABLE_CONSISTENCY_CHECKS
4047 reference_location = IN_RC;
4048#endif
4049
4050 mark_rc ();
4051
4052 /* mark objects reachable from marked objects */
4053
4054 traverse_weak_refs = 0; /* don't traverse weak references in first pass */
4055
4056 again:
4057
4058 if (___CAST(___WORD*,still_objs_to_scan)((long*)(still_objs_to_scan)) != 0)
4059 scan_still_objs_to_scan ();
4060
4061 if (scan_msection != heap_msection ||
4062 scan_ptr < alloc_heap_ptr)
4063 {
4064 scan_movable_objs_to_scan ();
4065 goto again;
4066 }
4067
4068 if (!traverse_weak_refs)
4069 {
4070 /*
4071 * At this point all of the objects accessible from the roots
4072 * without having to traverse a weak reference have been scanned
4073 * by the GC.
4074 */
4075
4076 traverse_weak_refs = 1;
4077
4078 process_wills ();
4079
4080 goto again;
4081 }
4082
4083 process_gc_hash_tables ();
4084
4085 free_unmarked_still_objs ();
4086
4087 target_nb_sections = (adjust_heap (WORDS_AVAILABLE(words_nonmovable + (2*the_msections->nb_sections*((long)(
((131072>>1)-(8192 +1+1)+1)))) - overflow_reserve - 2*(
8192 +1+1))
, WORDS_OCCUPIED(words_nonmovable + (2*(words_prev_msections + (alloc_stack_start
- alloc_stack_ptr) + (alloc_heap_ptr - alloc_heap_start))))
)
4088 - words_nonmovable
4089 + normal_overflow_reserve
4090 + 2*___MSECTION_FUDGE(8192 +1+1)
4091 + 2*((___MSECTION_SIZE131072>>1)-___MSECTION_FUDGE(8192 +1+1)+1) - 1)
4092 / (2*((___MSECTION_SIZE131072>>1)-___MSECTION_FUDGE(8192 +1+1)+1));
4093
4094 if (target_nb_sections < nb_msections_used)
4095 {
4096 target_nb_sections = the_msections->nb_sections;
4097 overflow = 1;
4098 }
4099
4100 if (target_nb_sections < ___MIN_NB_MSECTIONS1)
4101 target_nb_sections = ___MIN_NB_MSECTIONS1;
4102
4103 /* Move the stack */
4104
4105 {
4106 ___WORDlong *start;
4107 ___SIZE_TSlong length;
4108 ___WORDlong *p1;
4109 ___WORDlong *p2;
4110
4111 start = alloc_stack_ptr;
4112 length = (___ps->stack_break + ___BREAK_FRAME_SPACE((((1)+(4)-1)/(4))*(4))) - start;
4113
4114 if (stack_msection_index >= target_nb_sections)
4115 {
4116 /*
4117 * The msection currently containing the stack is about to be
4118 * reclaimed by the call to 'adjust_msections'. So we need to
4119 * save the stack before moving it to its final destination.
4120 */
4121
4122 p1 = start + length;
4123 p2 = start_of_fromspace (the_msections->head) + length;
4124
4125 while (p1 != start)
4126 *--p2 = *--p1;
4127
4128 start = p2;
4129 }
4130
4131 adjust_msections (&the_msections, target_nb_sections);
4132
4133 next_stack_msection ();
4134
4135 p1 = start + length;
4136 p2 = alloc_stack_ptr;
4137
4138 ___ps->stack_start = alloc_stack_start;
4139 ___ps->stack_break = p2 - ___BREAK_FRAME_SPACE((((1)+(4)-1)/(4))*(4));
4140
4141 while (p1 != start)
4142 *--p2 = *--p1;
4143
4144 alloc_stack_ptr = p2;
4145 }
4146
4147#ifdef ENABLE_CONSISTENCY_CHECKS
4148 if (___DEBUG_SETTINGS_LEVEL(___setup_params.debug_settings)(((___setup_params.debug_settings) & 15) >> 0) >= 1)
4149 zap_fromspace ();
4150#endif
4151
4152 if (alloc_heap_ptr > alloc_heap_limit - ___MSECTION_FUDGE(8192 +1+1))
4153 next_heap_msection ();
4154
4155 avail = WORDS_AVAILABLE(words_nonmovable + (2*the_msections->nb_sections*((long)(
((131072>>1)-(8192 +1+1)+1)))) - overflow_reserve - 2*(
8192 +1+1))
+ overflow_reserve - WORDS_OCCUPIED(words_nonmovable + (2*(words_prev_msections + (alloc_stack_start
- alloc_stack_ptr) + (alloc_heap_ptr - alloc_heap_start))))
;
4156
4157 if (avail <= overflow_reserve + (WORDS_MOVABLE_USABLE(2*the_msections->nb_sections*((long)(((131072>>1)-(
8192 +1+1)+1))))
>> 10))
4158 {
4159 overflow = 1;
4160 overflow_reserve >>= 5; /* make 96.875% of reserve usable */
4161 if (overflow_reserve == 0)
4162 fatal_heap_overflow ();
4163 }
4164 else if (avail >= normal_overflow_reserve)
4165 overflow_reserve = normal_overflow_reserve; /* restore overflow reserve */
4166
4167 ___GSTATE(&___gstate)->bytes_allocated_minus_occupied =
4168 ___GSTATE(&___gstate)->bytes_allocated_minus_occupied -
4169 ___CAST(___F64,WORDS_OCCUPIED)((double)((words_nonmovable + (2*(words_prev_msections + (alloc_stack_start
- alloc_stack_ptr) + (alloc_heap_ptr - alloc_heap_start)))))
)
* ___WS8;
4170
4171 words_nonmovable -= nonmovable_words_needed;
4172
4173 heap_size = WORDS_AVAILABLE(words_nonmovable + (2*the_msections->nb_sections*((long)(
((131072>>1)-(8192 +1+1)+1)))) - overflow_reserve - 2*(
8192 +1+1))
;
4174
4175 setup_pstate ();
4176
4177 ___process_times (&user_time_end, &sys_time_end, &real_time_end);
4178
4179 gc_user_time = user_time_end - user_time_start;
4180 gc_sys_time = sys_time_end - sys_time_start;
4181 gc_real_time = real_time_end - real_time_start;
4182
4183 ___GSTATE(&___gstate)->nb_gcs = ___GSTATE(&___gstate)->nb_gcs + 1.0;
4184 ___GSTATE(&___gstate)->gc_user_time += gc_user_time;
4185 ___GSTATE(&___gstate)->gc_sys_time += gc_sys_time;
4186 ___GSTATE(&___gstate)->gc_real_time += gc_real_time;
4187
4188 ___GSTATE(&___gstate)->last_gc_user_time = gc_user_time;
4189 ___GSTATE(&___gstate)->last_gc_sys_time = gc_sys_time;
4190 ___GSTATE(&___gstate)->last_gc_real_time = gc_real_time;
4191 ___GSTATE(&___gstate)->last_gc_heap_size = ___CAST(___F64,heap_size)((double)(heap_size)) * ___WS8;
4192 ___GSTATE(&___gstate)->last_gc_alloc =
4193 ___GSTATE(&___gstate)->bytes_allocated_minus_occupied +
4194 ___CAST(___F64,WORDS_OCCUPIED)((double)((words_nonmovable + (2*(words_prev_msections + (alloc_stack_start
- alloc_stack_ptr) + (alloc_heap_ptr - alloc_heap_start)))))
)
* ___WS8;
4195 ___GSTATE(&___gstate)->last_gc_live = ___CAST(___F64,WORDS_OCCUPIED)((double)((words_nonmovable + (2*(words_prev_msections + (alloc_stack_start
- alloc_stack_ptr) + (alloc_heap_ptr - alloc_heap_start)))))
)
* ___WS8;
4196 ___GSTATE(&___gstate)->last_gc_movable = ___CAST(___F64,WORDS_MOVABLE)((double)((2*(words_prev_msections + (alloc_stack_start - alloc_stack_ptr
) + (alloc_heap_ptr - alloc_heap_start)))))
* ___WS8;
4197 ___GSTATE(&___gstate)->last_gc_nonmovable = ___CAST(___F64,words_nonmovable)((double)(words_nonmovable)) * ___WS8;
4198
4199 ___raise_interrupt (___INTR_GC2); /* raise gc interrupt */
4200
4201 return overflow;
4202}
4203
4204
4205#ifdef ___DEBUG_STACK_LIMIT
4206
4207___BOOLint ___stack_limit_debug
4208 ___P((int line,(int line, char *file)
4209 char *file),(int line, char *file)
4210 (line,(int line, char *file)
4211 file)(int line, char *file)
4212int line;(int line, char *file)
4213char *file;)(int line, char *file)
4214
4215#else
4216
4217___BOOLint ___stack_limit ___PVOID(void)
4218
4219#endif
4220{
4221 ___processor_state ___ps = ___PSTATE(&(&___gstate)->pstate);
4222 ___SIZE_TSlong avail;
4223
4224#ifdef ___DEBUG_STACK_LIMIT
4225 ___ps->stack_limit_line = line;
4226 ___ps->stack_limit_file = file;
4227 ___printf ("___POLL caused ___stack_limit call at %s:%d\n",
4228 ___ps->poll_file,
4229 ___ps->poll_line);
4230#endif
4231
4232#ifdef ENABLE_CONSISTENCY_CHECKS
4233 if (___DEBUG_SETTINGS_LEVEL(___setup_params.debug_settings)(((___setup_params.debug_settings) & 15) >> 0) >= 1)
4234 check_fudge_used ();
4235#endif
4236
4237 alloc_stack_ptr = ___ps->fp; /* needed by 'WORDS_OCCUPIED' */
4238 alloc_heap_ptr = ___ps->hp; /* needed by 'WORDS_OCCUPIED' */
4239
4240 avail = (heap_size - WORDS_OCCUPIED(words_nonmovable + (2*(words_prev_msections + (alloc_stack_start
- alloc_stack_ptr) + (alloc_heap_ptr - alloc_heap_start))))
) / 2;
4241
4242 if (avail > ___MSECTION_WASTE((8192 +1+1)/16)
4243#ifdef CALL_GC_FREQUENTLY
4244 && --___gc_calls_to_punt >= 0
4245#endif
4246 )
4247 {
4248 if (alloc_stack_ptr < alloc_stack_limit + ___MSECTION_FUDGE(8192 +1+1))
4249 {
4250 ___WORDlong frame;
4251
4252 if (alloc_stack_ptr != ___ps->stack_break)
4253 frame = ___CAST(___WORD,alloc_stack_ptr)((long)(alloc_stack_ptr));
4254 else
4255 frame = ___FP_STK(alloc_stack_ptr,-___BREAK_FRAME_NEXT)alloc_stack_ptr[-(-1)];
4256
4257 next_stack_msection ();
4258
4259 /*
4260 * Create a "break frame" in the new stack msection.
4261 */
4262
4263 ___ps->stack_start = alloc_stack_start;
4264 alloc_stack_ptr = alloc_stack_start;
4265
4266 ___FP_ADJFP(alloc_stack_ptr,___BREAK_FRAME_SPACE)alloc_stack_ptr-=(((((1)+(4)-1)/(4))*(4)));
4267 ___FP_SET_STK(alloc_stack_ptr,-___BREAK_FRAME_NEXT,frame)alloc_stack_ptr[-(-1)]=(frame);
4268
4269 ___ps->stack_break = alloc_stack_ptr;
4270 }
4271
4272 setup_pstate ();
4273
4274 return 0;
4275 }
4276
4277 return 1;
4278}
4279
4280
4281#ifdef ___DEBUG_HEAP_LIMIT
4282
4283___BOOLint ___heap_limit_debug
4284 ___P((int line,(int line, char *file)
4285 char *file),(int line, char *file)
4286 (line,(int line, char *file)
4287 file)(int line, char *file)
4288int line;(int line, char *file)
4289char *file;)(int line, char *file)
4290
4291#else
4292
4293___BOOLint ___heap_limit ___PVOID(void)
4294
4295#endif
4296{
4297 ___processor_state ___ps = ___PSTATE(&(&___gstate)->pstate);
4298 ___SIZE_TSlong avail;
4299
4300#ifdef ___DEBUG_HEAP_LIMIT
4301 ___ps->heap_limit_line = line;
4302 ___ps->heap_limit_file = file;
4303#endif
4304
4305#ifdef ENABLE_CONSISTENCY_CHECKS
4306 if (___DEBUG_SETTINGS_LEVEL(___setup_params.debug_settings)(((___setup_params.debug_settings) & 15) >> 0) >= 1)
4307 check_fudge_used ();
4308#endif
4309
4310 alloc_stack_ptr = ___ps->fp; /* needed by 'WORDS_OCCUPIED' */
4311 alloc_heap_ptr = ___ps->hp; /* needed by 'WORDS_OCCUPIED' */
4312
4313 avail = (heap_size - WORDS_OCCUPIED(words_nonmovable + (2*(words_prev_msections + (alloc_stack_start
- alloc_stack_ptr) + (alloc_heap_ptr - alloc_heap_start))))
) / 2;
4314
4315 if (avail > ___MSECTION_WASTE((8192 +1+1)/16)
4316#ifdef CALL_GC_FREQUENTLY
4317 && --___gc_calls_to_punt >= 0
4318#endif
4319 )
4320 {
4321 if (alloc_heap_ptr > alloc_heap_limit - ___MSECTION_FUDGE(8192 +1+1))
4322 next_heap_msection ();
4323
4324 setup_pstate ();
4325
4326 return 0;
4327 }
4328
4329 return 1;
4330}
4331
4332
4333/*---------------------------------------------------------------------------*/
4334
4335
4336___F64double ___bytes_allocated ___PVOID(void)
4337{
4338 ___processor_state ___ps = ___PSTATE(&(&___gstate)->pstate);
4339
4340 alloc_stack_ptr = ___ps->fp; /* needed by 'WORDS_OCCUPIED' */
4341 alloc_heap_ptr = ___ps->hp; /* needed by 'WORDS_OCCUPIED' */
4342
4343 return ___GSTATE(&___gstate)->bytes_allocated_minus_occupied +
4344 ___CAST(___F64,WORDS_OCCUPIED)((double)((words_nonmovable + (2*(words_prev_msections + (alloc_stack_start
- alloc_stack_ptr) + (alloc_heap_ptr - alloc_heap_start)))))
)
* ___WS8;
4345}
4346
4347
4348/*---------------------------------------------------------------------------*/