File: | mem.c |
Location: | line 2161, column 11 |
Description: | Value stored to 'subtype' is never read |
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 | |
289 | typedef 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 | |
301 | typedef 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)))) - \ |
357 | overflow_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 |
414 | int ___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) |
508 | unsigned int multiplier;(long words, unsigned int multiplier, unsigned int modulus) |
509 | unsigned 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) |
553 | void *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 | |
566 | typedef 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) |
633 | void *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) |
656 | void *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) |
669 | void *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) |
681 | void *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) |
712 | msections *ms;(msections *ms, void *ptr) |
713 | void *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) |
768 | msections **msp;(msections **msp, int n) |
769 | int 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) |
928 | msections **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) |
980 | unsigned int multiplier;(long words, unsigned int multiplier, unsigned int modulus) |
981 | unsigned 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) |
1029 | int multiplier;(long words, int multiplier, int modulus) |
1030 | int 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) |
1169 | int subtype;(int subtype, long bytes, int kind) |
1170 | ___SIZE_TS bytes;(int subtype, long bytes, int kind) |
1171 | int 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) |
1297 | int 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) |
1330 | int 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) |
1355 | msection *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) |
1367 | msection *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) |
1388 | msection *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 | |
1448 | char *subtype_to_string |
1449 | ___P((int subtype),(int subtype) |
1450 | (subtype)(int subtype) |
1451 | int 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 | |
1489 | void 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) |
1606 | char *prefix;(char *prefix, int indent) |
1607 | int 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) |
1628 | int max_depth;(long obj, int max_depth, char *prefix, int indent) |
1629 | char *prefix;(long obj, int max_depth, char *prefix, int indent) |
1630 | int 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) |
1864 | char *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) |
1958 | char *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) |
2027 | int 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) |
2043 | int 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) |
2122 | int 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 |
2296 | bash-3.2$ gsi/gsi |
2297 | ------------- |
2298 | Gambit v4.5.2 |
2299 | |
2300 | > ------------- |
2301 | fp=0x1006fff68 ra1=0x1001f9bc1 fs=3 link=0 |
2302 | fp=0x1006fff88 ra1=0x1002efc21 fs=7 link=0 |
2303 | fp=0x1006fffc8 ra1=0x1002efda1 fs=3 link=0 |
2304 | fp=0x1006fffe8 ra1=0x1001f4e01 fs=3 link=0 |
2305 | ------------- |
2306 | ------------- |
2307 | fp=0x1006fff68 ra1=0x1001f9bc1 fs=3 link=0 |
2308 | ------------- |
2309 | fp=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) |
2399 | int 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 | |
3077 | void ___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 | |
3550 | void ___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) |
3920 | int line;(long nonmovable_words_needed, int line, char *file) |
3921 | char *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) |
4212 | int line;(int line, char *file) |
4213 | char *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) |
4288 | int line;(int line, char *file) |
4289 | char *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 | /*---------------------------------------------------------------------------*/ |