1 /* -*-C-*-
2
3 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
4 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
5 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014 Massachusetts
6 Institute of Technology
7
8 This file is part of MIT/GNU Scheme.
9
10 MIT/GNU Scheme is free software; you can redistribute it and/or modify
11 it under the terms of the GNU General Public License as published by
12 the Free Software Foundation; either version 2 of the License, or (at
13 your option) any later version.
14
15 MIT/GNU Scheme is distributed in the hope that it will be useful, but
16 WITHOUT ANY WARRANTY; without even the implied warranty of
17 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
18 General Public License for more details.
19
20 You should have received a copy of the GNU General Public License
21 along with MIT/GNU Scheme; if not, write to the Free Software
22 Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
23 USA.
24
25 */
26
27 /* Memory management top level */
28
29 #include "scheme.h"
30 #include "prims.h"
31 #include "history.h"
32 #include "gccode.h"
33 #include "osscheme.h"
34 #include "ostop.h"
35
36 #ifdef __WIN32__
37 extern void win32_allocate_registers (void);
38 extern void win32_deallocate_registers (void);
39 # define ALLOCATE_REGISTERS win32_allocate_registers
40 # define DEALLOCATE_REGISTERS win32_deallocate_registers
41
42 # include "ntscmlib.h"
43
44 extern BOOL win32_under_win32s_p (void);
45
46 extern char * NT_allocate_heap (unsigned long, unsigned long *);
47 extern void NT_release_heap (char *, unsigned long);
48 # define WIN32_ALLOCATE_HEAP NT_allocate_heap
49 # define WIN32_RELEASE_HEAP NT_release_heap
50
51 static unsigned long scheme_heap_handle;
52 #endif
53
54 #ifndef HEAP_FREE
55 # define HEAP_FREE free
56 #endif
57
58 #ifndef ALLOCATE_REGISTERS
59 # define ALLOCATE_REGISTERS() do { } while (0)
60 #endif
61
62 #ifndef DEALLOCATE_REGISTERS
63 # define DEALLOCATE_REGISTERS() do { } while (0)
64 #endif
65
66 #ifndef DEFAULT_HEAP_RESERVED
67 # define DEFAULT_HEAP_RESERVED 4500
68 #endif
69
70 static unsigned long saved_heap_size;
71 static unsigned long saved_constant_size;
72 static unsigned long saved_stack_size;
73
74 static gc_tospace_allocator_t allocate_tospace;
75 static gc_abort_handler_t abort_gc NORETURN;
76 static gc_walk_proc_t save_tospace_copy;
77
78 static unsigned long compute_ephemeron_array_length (unsigned long);
79
80 /* Memory Allocation, sequential processor:
81
82 oo
83 ------------------------------------------
84 | Temporary heap (tospace) |
85 | |
86 __________________________________________ <- chosen by malloc/realloc
87 . .
88 . .
89 . .
90 ------------------------------------------ <- fixed boundary (currently)
91 | Heap |
92 | |
93 ------------------------------------------ <- boundary moved by purify
94 | Constant + Pure Space /\ |
95 | || |
96 ------------------------------------------ <- fixed boundary (currently)
97 | Control Stack || |
98 | \/ |
99 ------------------------------------------ <- fixed boundary (currently)
100 0
101
102 Each area has a pointer to its starting address and a pointer to
103 the next free cell (for the stack, it is a pointer to the last cell
104 in use). In addition, there is a pointer to the top of the
105 useable area of the heap (the heap is subdivided into two areas for
106 the purposes of GC, and this pointer indicates the top of the half
107 currently in use). */
108
109 void
setup_memory(unsigned long heap_size,unsigned long stack_size,unsigned long constant_size)110 setup_memory (unsigned long heap_size,
111 unsigned long stack_size,
112 unsigned long constant_size)
113 {
114 ALLOCATE_REGISTERS ();
115
116 /* Consistency check 1 */
117 if ((heap_size == 0) || (stack_size == 0))
118 {
119 outf_fatal ("Configuration won't hold initial data.\n");
120 outf_flush_fatal ();
121 exit (1);
122 }
123
124 /* Consistency check 2 */
125 if ((stack_size + heap_size + constant_size) >= DATUM_MASK)
126 goto allocation_too_large;
127
128 /* Allocate */
129 ALLOCATE_HEAP_SPACE ((stack_size + heap_size + constant_size),
130 memory_block_start,
131 memory_block_end);
132
133 /* Consistency check 3 */
134 if (memory_block_start == 0)
135 {
136 outf_fatal ("Not enough memory for this configuration.\n");
137 outf_flush_fatal ();
138 exit (1);
139 }
140
141 /* Consistency check 4 */
142 if ((ADDRESS_TO_DATUM (memory_block_end)) > DATUM_MASK)
143 {
144 allocation_too_large:
145 outf_fatal ("Requested allocation is too large.\n");
146 outf_fatal ("Try again with a smaller argument to '--heap'.\n");
147 outf_flush_fatal ();
148 reset_memory ();
149 exit (1);
150 }
151
152 saved_stack_size = stack_size;
153 saved_constant_size = constant_size;
154 saved_heap_size = heap_size;
155 reset_allocator_parameters (0, 0);
156 initialize_gc (heap_size, (&heap_start), (&Free), allocate_tospace, abort_gc);
157 }
158
159 void
reset_memory(void)160 reset_memory (void)
161 {
162 HEAP_FREE (memory_block_start);
163 DEALLOCATE_REGISTERS ();
164 }
165
166 bool
allocations_ok_p(unsigned long n_constant,unsigned long n_heap,unsigned long n_reserved)167 allocations_ok_p (unsigned long n_constant,
168 unsigned long n_heap,
169 unsigned long n_reserved)
170 {
171 return
172 ((memory_block_start
173 + saved_stack_size
174 + n_constant + CONSTANT_SPACE_FUDGE
175 + n_heap + ((n_reserved == 0) ? DEFAULT_HEAP_RESERVED : n_reserved))
176 < memory_block_end);
177 }
178
179 void
reset_allocator_parameters(unsigned long n_constant,unsigned long reserved)180 reset_allocator_parameters (unsigned long n_constant, unsigned long reserved)
181 {
182 heap_reserved = ((reserved == 0) ? DEFAULT_HEAP_RESERVED : reserved);
183 gc_space_needed = 0;
184 SET_STACK_LIMITS (memory_block_start, saved_stack_size);
185 constant_start = (memory_block_start + saved_stack_size);
186 constant_alloc_next = constant_start;
187 constant_end = (constant_alloc_next + n_constant + CONSTANT_SPACE_FUDGE);
188 heap_start = constant_end;
189 Free = heap_start;
190 heap_end = memory_block_end;
191
192 RESET_HEAP_ALLOC_LIMIT ();
193 INITIALIZE_STACK ();
194 STACK_RESET ();
195 }
196
197 static void
allocate_tospace(unsigned long n_words,SCHEME_OBJECT ** start_r,SCHEME_OBJECT ** end_r)198 allocate_tospace (unsigned long n_words,
199 SCHEME_OBJECT ** start_r, SCHEME_OBJECT ** end_r)
200 {
201 if (n_words > 0)
202 {
203 SCHEME_OBJECT * p
204 = (((*start_r) == 0)
205 ? (malloc (n_words * SIZEOF_SCHEME_OBJECT))
206 : (realloc ((*start_r), (n_words * SIZEOF_SCHEME_OBJECT))));
207 if (p == 0)
208 {
209 outf_fatal ("Unable to allocate temporary heap for GC.\n");
210 outf_flush_fatal ();
211 exit (1);
212 }
213 (*start_r) = p;
214 (*end_r) = (p + n_words);
215 }
216 else if ((*start_r) != 0)
217 {
218 free (*start_r);
219 (*start_r) = 0;
220 (*end_r) = 0;
221 }
222 }
223
224 static void
abort_gc(void)225 abort_gc (void)
226 {
227 Microcode_Termination (TERM_EXIT);
228 }
229
230 bool
object_in_heap_p(SCHEME_OBJECT object)231 object_in_heap_p (SCHEME_OBJECT object)
232 {
233 SCHEME_OBJECT * address = (get_object_address (object));
234 return ((address != 0) && (ADDRESS_IN_HEAP_P (address)));
235 }
236
237 DEFINE_PRIMITIVE ("GARBAGE-COLLECT", Prim_garbage_collect, 1, 1,
238 "(SAFETY-MARGIN)\n\
239 Performs a garbage collection and returns the number of words\n\
240 available for further allocation. Also sets the \"safety margin\",\n\
241 which is the number of reserved words at the top of the heap, to\n\
242 SAFETY-MARGIN, which must be a non-negative integer. Finally, runs\n\
243 the primitive GC daemons before returning.")
244 {
245 PRIMITIVE_HEADER (1);
246 canonicalize_primitive_context ();
247
248 STACK_CHECK_FATAL ("GC");
249 if (Free > heap_end)
250 {
251 outf_fatal ("\nGC has been delayed too long!\n");
252 outf_fatal
253 ("Free = %#lx; heap_alloc_limit = %#lx; heap_end = %#lx\n",
254 ((unsigned long) Free),
255 ((unsigned long) heap_alloc_limit),
256 ((unsigned long) heap_end));
257 Microcode_Termination (TERM_NO_SPACE);
258 }
259
260 if ((ARG_HEAP_RESERVED (1)) < (heap_end - heap_start))
261 {
262 heap_reserved = (ARG_HEAP_RESERVED (1));
263 heap_alloc_limit = (heap_end - heap_reserved);
264 }
265 POP_PRIMITIVE_FRAME (1);
266
267 ENTER_CRITICAL_SECTION ("garbage collector");
268
269 #ifdef ENABLE_DEBUGGING_TOOLS
270 if (GC_Debug == true) verify_heap ();
271 #endif
272
273 open_tospace (heap_start);
274 initialize_weak_chain ();
275 ephemeron_count = 0;
276
277 std_gc_pt1 ();
278 std_gc_pt2 ();
279
280 Will_Push (CONTINUATION_SIZE);
281 SET_RC (RC_NORMAL_GC_DONE);
282 SET_EXP (ULONG_TO_FIXNUM ((HEAP_AVAILABLE > gc_space_needed)
283 ? (HEAP_AVAILABLE - gc_space_needed)
284 : 0));
285 SAVE_CONT ();
286 Pushed ();
287
288 RENAME_CRITICAL_SECTION ("garbage collector daemon");
289 {
290 SCHEME_OBJECT daemon = (VECTOR_REF (fixed_objects, GC_DAEMON));
291 if (daemon == SHARP_F)
292 PRIMITIVE_ABORT (PRIM_POP_RETURN);
293
294 Will_Push (2);
295 STACK_PUSH (daemon);
296 PUSH_APPLY_FRAME_HEADER (0);
297 Pushed ();
298 PRIMITIVE_ABORT (PRIM_APPLY);
299 /*NOTREACHED*/
300 }
301 PRIMITIVE_RETURN (UNSPECIFIC);
302 }
303
304 static SCHEME_OBJECT * saved_to;
305
306 void
std_gc_pt1(void)307 std_gc_pt1 (void)
308 {
309 #ifdef ENABLE_GC_DEBUGGING_TOOLS
310 initialize_gc_object_references ();
311 #endif
312
313 saved_to = (get_newspace_ptr ());
314 add_to_tospace (fixed_objects);
315 add_to_tospace
316 (MAKE_POINTER_OBJECT (UNMARKED_HISTORY_TYPE, history_register));
317
318 current_gc_table = (std_gc_table ());
319 gc_scan_oldspace (stack_pointer, stack_end);
320 gc_scan_oldspace (constant_start, constant_alloc_next);
321 gc_scan_tospace (saved_to, 0);
322
323 #ifdef ENABLE_GC_DEBUGGING_TOOLS
324 finalize_gc_object_references ();
325 #endif
326 update_weak_pointers ();
327 }
328
329 void
std_gc_pt2(void)330 std_gc_pt2 (void)
331 {
332 SCHEME_OBJECT * p = (get_newspace_ptr ());
333 (void) save_tospace (save_tospace_copy, 0);
334 Free = p;
335
336 fixed_objects = (*saved_to++);
337 history_register = (OBJECT_ADDRESS (*saved_to++));
338 saved_to = 0;
339
340 {
341 unsigned long length
342 = (compute_ephemeron_array_length
343 (ephemeron_count + n_ephemerons_requested));
344 if (!HEAP_AVAILABLE_P
345 ((VECTOR_DATA + length) + (n_ephemerons_requested * EPHEMERON_SIZE)))
346 {
347 if (ephemeron_request_hard_p)
348 gc_space_needed += (VECTOR_DATA + length);
349 length = (compute_ephemeron_array_length (ephemeron_count));
350 #ifdef ENABLE_GC_DEBUGGING_TOOLS
351 /* This should never trigger, because we discard the previous
352 ephemeron array, which always has room for at least as many
353 ephemerons as are now live. */
354 if (!HEAP_AVAILABLE_P (VECTOR_DATA + length))
355 std_gc_death ("No room for ephemeron array");
356 #endif
357 }
358 ephemeron_array = (make_vector (length, SHARP_F, false));
359 n_ephemerons_requested = 0;
360 ephemeron_request_hard_p = false;
361 }
362
363 CC_TRANSPORT_END ();
364 CLEAR_INTERRUPT (INT_GC);
365 }
366
367 static bool
save_tospace_copy(SCHEME_OBJECT * start,SCHEME_OBJECT * end,void * p)368 save_tospace_copy (SCHEME_OBJECT * start, SCHEME_OBJECT * end, void * p)
369 {
370 (void) memmove ((tospace_to_newspace (start)),
371 start,
372 ((end - start) * SIZEOF_SCHEME_OBJECT));
373 return (true);
374 }
375
376 void
stack_death(const char * name)377 stack_death (const char * name)
378 {
379 outf_fatal
380 ("\n%s: The stack has overflowed and overwritten adjacent memory.\n",
381 name);
382 outf_fatal ("This was probably caused by a runaway recursion.\n");
383 Microcode_Termination (TERM_STACK_OVERFLOW);
384 /*NOTREACHED*/
385 }
386
387 DEFINE_PRIMITIVE ("GC-TRACE-REFERENCES", Prim_gc_trace_references, 2, 2, 0)
388 {
389 PRIMITIVE_HEADER (2);
390 {
391 SCHEME_OBJECT collector = (ARG_REF (2));
392 if (! ((collector == SHARP_F)
393 || ((VECTOR_P (collector))
394 && ((VECTOR_LENGTH (collector)) >= 1))))
395 error_wrong_type_arg (2);
396 #ifdef ENABLE_GC_DEBUGGING_TOOLS
397 collect_gc_object_references ((ARG_REF (1)), collector);
398 #else
399 error_external_return ();
400 #endif
401 }
402 PRIMITIVE_RETURN (UNSPECIFIC);
403 }
404
405 static unsigned long primes [] =
406 {
407 /* A list of primes that approximately doubles, up to near 2^32.
408 If you have that many ephemerons, collisions in the ephemeron
409 hash table are the least of your worries. */
410 11, 23, 53, 97, 193, 389, 769, 1543, 3079, 6151, 12289, 24593, 49157,
411 98317, 196613, 393241, 786433, 1572869, 3145739, 6291469, 12582917,
412 25165843, 50331653, 100663319, 201326611, 402653189, 805306457,
413 1610612741,
414 };
415
416 static unsigned long
compute_ephemeron_array_length(unsigned long n)417 compute_ephemeron_array_length (unsigned long n)
418 {
419 unsigned int start = 0, end = ((sizeof primes) / (sizeof (*primes)));
420 unsigned int index;
421
422 if ((primes [end - 1]) < n)
423 return (primes [end - 1]);
424
425 do {
426 index = (start + ((end - start) / 2));
427 if ((primes [index]) < n)
428 start = (index + 1);
429 else if (n < (primes [index]))
430 end = index;
431 else
432 return (primes [index]);
433 } while (start < end);
434
435 return (primes [start]);
436 }
437
438 static bool
ephemeron_array_big_enough_p(unsigned long n)439 ephemeron_array_big_enough_p (unsigned long n)
440 {
441 return
442 ((n == 0)
443 || ((VECTOR_P (ephemeron_array))
444 && (n <= (VECTOR_LENGTH (ephemeron_array)))));
445 }
446
447 unsigned long
compute_extra_ephemeron_space(unsigned long n)448 compute_extra_ephemeron_space (unsigned long n)
449 {
450 if (ephemeron_array_big_enough_p (n))
451 return (0);
452 else
453 return (VECTOR_DATA + (compute_ephemeron_array_length (n)));
454 }
455
456 void
guarantee_extra_ephemeron_space(unsigned long n)457 guarantee_extra_ephemeron_space (unsigned long n)
458 {
459 ephemeron_count = n;
460 if (!ephemeron_array_big_enough_p (n))
461 {
462 unsigned long length = (compute_ephemeron_array_length (n));
463 assert (HEAP_AVAILABLE_P (VECTOR_DATA + length));
464 ephemeron_array = (make_vector (length, SHARP_F, false));
465 }
466 }
467
468 static void
gc_if_needed_for_ephemeron(unsigned long extra_space)469 gc_if_needed_for_ephemeron (unsigned long extra_space)
470 {
471 if (GC_NEEDED_P (EPHEMERON_SIZE + extra_space))
472 {
473 n_ephemerons_requested = 1;
474 ephemeron_request_hard_p = true;
475 Primitive_GC (EPHEMERON_SIZE);
476 }
477 }
478
479 DEFINE_PRIMITIVE ("MAKE-EPHEMERON", Prim_make_ephemeron, 2, 2, 0)
480 {
481 PRIMITIVE_HEADER (2);
482 ephemeron_count += 1;
483 if (ephemeron_array_big_enough_p (ephemeron_count))
484 gc_if_needed_for_ephemeron (0);
485 else
486 {
487 unsigned long length
488 = (compute_ephemeron_array_length (ephemeron_count));
489 gc_if_needed_for_ephemeron (VECTOR_DATA + length);
490 ephemeron_array = (make_vector (length, SHARP_F, false));
491 }
492 {
493 SCHEME_OBJECT * addr = Free;
494 (*Free++) = MARKED_EPHEMERON_MANIFEST;
495 (*Free++) = (ARG_REF (1)); /* key */
496 (*Free++) = (ARG_REF (2)); /* datum */
497 (*Free++) = SHARP_F; /* list */
498 (*Free++) = SHARP_F; /* queue */
499 assert ((Free - addr) == EPHEMERON_SIZE);
500 PRIMITIVE_RETURN (MAKE_POINTER_OBJECT (TC_EPHEMERON, addr));
501 }
502 }
503