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 /* This file contains code for fasdump and dump-band. */
28
29 #include "scheme.h"
30 #include "prims.h"
31 #include "osscheme.h"
32 #include "osio.h"
33 #include "osfile.h"
34 #include "osfs.h"
35 #define In_Fasdump
36 #include "gccode.h"
37 #include "trap.h"
38 #include "lookup.h"
39 #include "fasl.h"
40 #include <setjmp.h>
41
42 #ifdef ENABLE_GC_DEBUGGING_TOOLS
43 # define SAVE_GC_VARS save_gc_vars
44 static void save_gc_vars (void);
45 # define COMPARE_GC_VARS compare_gc_vars
46 static void compare_gc_vars (void);
47 # ifdef HAVE_MHASH_H
48 # include <mhash.h>
49 # define SAVE_MEMORY_CHECKSUM save_memory_checksum
50 static void save_memory_checksum (void);
51 # define COMPARE_MEMORY_CHECKSUM compare_memory_checksum
52 static void compare_memory_checksum (void);
53 static void * compute_memory_checksum (void);
54 # endif
55 #else
56 # define SAVE_GC_VARS() do {} while (false)
57 # define COMPARE_GC_VARS() do {} while (false)
58 #endif
59
60 #ifndef SAVE_MEMORY_CHECKSUM
61 # define SAVE_MEMORY_CHECKSUM() do {} while (false)
62 # define COMPARE_MEMORY_CHECKSUM() do {} while (false)
63 #endif
64
65 typedef enum { FE_ERROR, FE_DUMP, FE_DROP_CC } env_mode_t;
66
67 typedef struct
68 {
69 const char * filename;
70 fasl_file_handle_t handle;
71 } fasl_file_info_t;
72
73 static void close_fasl_file (void *);
74 static void abort_fasdump (void *);
75 static gc_walk_proc_t save_tospace_write;
76
77 static fasl_header_t fasl_header;
78 static fasl_header_t * fh;
79 static env_mode_t current_env_mode;
80 static prim_renumber_t * current_pr;
81 static bool cc_seen_p;
82 static unsigned long dumped_ephemeron_count;
83
84 static gc_table_t * fasdump_table (void);
85 static gc_handler_t handle_primitive;
86 static gc_handler_t handle_manifest_closure;
87 static gc_handler_t handle_linkage_section;
88 static gc_handler_t handle_symbol;
89 static gc_handler_t handle_broken_heart;
90 static gc_handler_t handle_variable;
91 static gc_handler_t handle_environment;
92 static gc_handler_t handle_ephemeron;
93
94 static gc_object_handler_t fasdump_cc_entry;
95 static gc_precheck_from_t fasdump_precheck_from;
96 static gc_transport_words_t fasdump_transport_words;
97
98 static void initialize_fixups (void);
99 static void add_fixup (SCHEME_OBJECT *);
100 static void run_fixups (void *);
101
102 static void initialize_fasl_header (bool, bool);
103 static void finalize_fasl_header (unsigned long);
104 static bool write_fasl_file
105 (SCHEME_OBJECT *, SCHEME_OBJECT *, fasl_file_handle_t);
106
107 /* FASDUMP:
108
109 In order to dump an object it must be traced (as in a garbage
110 collection), but with some significant differences. First, the
111 copy must have the global value cell of symbols set to UNBOUND.
112 Second, and worse, all the broken hearts created during the process
113 must be restored to their original values. This last is done by
114 growing the copy of the object in the bottom of spare heap, keeping
115 track of the locations of broken hearts and original contents at
116 the top of the spare heap. */
117
118 DEFINE_PRIMITIVE ("PRIMITIVE-FASDUMP", Prim_prim_fasdump, 3, 3,
119 "(OBJECT NAMESTRING FLAG)\n\
120 Writes a binary representation of OBJECT to the file NAMESTRING.\n\
121 Returns #T if the operation is successful, or #F otherwise.\n\
122 \n\
123 FLAG specifies how to handle environment objects that OBJECT points\n\
124 to: #F means generate an error; #T means write them as ordinary\n\
125 objects; any other value is like #F except that environments pointed\n\
126 at by compiled code are ignored (and discarded).")
127 {
128 fasl_file_info_t ff_info;
129 SCHEME_OBJECT * new_heap_start;
130 SCHEME_OBJECT * prim_table_start;
131 unsigned long prim_table_length;
132 bool ok;
133 PRIMITIVE_HEADER (3);
134
135 SAVE_GC_VARS ();
136 SAVE_MEMORY_CHECKSUM ();
137
138 transaction_begin (); /* 1 */
139 (ff_info . filename) = (STRING_ARG (2));
140 if (!open_fasl_output_file ((ff_info . filename), (& (ff_info . handle))))
141 error_bad_range_arg (2);
142 transaction_record_action (tat_always, close_fasl_file, (&ff_info));
143
144 open_tospace (heap_start);
145 /* This must be _before_ the call to initialize_fixups(): */
146 transaction_record_action (tat_abort, abort_fasdump, 0);
147 initialize_fixups ();
148
149 new_heap_start = (get_newspace_ptr ());
150 add_to_tospace (ARG_REF (1));
151 dumped_ephemeron_count = 0;
152
153 transaction_begin (); /* 2 */
154
155 current_gc_table = (fasdump_table ());
156 current_env_mode
157 = (((ARG_REF (3)) == SHARP_F)
158 ? FE_ERROR
159 : ((ARG_REF (3)) == SHARP_T)
160 ? FE_DUMP
161 : FE_DROP_CC);
162 current_pr = (make_prim_renumber ());
163 cc_seen_p = false;
164 gc_scan_tospace (new_heap_start, 0);
165
166 prim_table_start = (get_newspace_ptr ());
167 prim_table_length = (renumbered_primitives_export_length (current_pr));
168 increment_tospace_ptr (prim_table_length);
169 export_renumbered_primitives
170 ((newspace_to_tospace (prim_table_start)), current_pr);
171
172 transaction_commit (); /* 2 */
173
174 initialize_fasl_header (cc_seen_p, false);
175 (FASLHDR_CONSTANT_START (fh)) = new_heap_start;
176 (FASLHDR_CONSTANT_END (fh)) = new_heap_start;
177 (FASLHDR_HEAP_START (fh)) = new_heap_start;
178 (FASLHDR_HEAP_END (fh)) = prim_table_start;
179 (FASLHDR_ROOT_POINTER (fh)) = new_heap_start;
180 (FASLHDR_N_PRIMITIVES (fh)) = (current_pr->next_code);
181 (FASLHDR_PRIMITIVE_TABLE_SIZE (fh)) = prim_table_length;
182 finalize_fasl_header (dumped_ephemeron_count);
183
184 ok = ((write_fasl_header (fh, (ff_info . handle)))
185 && (save_tospace (save_tospace_write, (&ff_info))));
186 transaction_commit (); /* 1 */
187
188 COMPARE_GC_VARS ();
189 COMPARE_MEMORY_CHECKSUM ();
190
191 PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (ok));
192 }
193
194 static void
close_fasl_file(void * p)195 close_fasl_file (void * p)
196 {
197 fasl_file_info_t * ff_info = p;
198 if (!close_fasl_output_file (ff_info->handle))
199 OS_file_remove (ff_info->filename);
200 }
201
202 static void
abort_fasdump(void * p)203 abort_fasdump (void * p)
204 {
205 discard_tospace ();
206 }
207
208 static bool
save_tospace_write(SCHEME_OBJECT * start,SCHEME_OBJECT * end,void * p)209 save_tospace_write (SCHEME_OBJECT * start, SCHEME_OBJECT * end, void * p)
210 {
211 fasl_file_info_t * ff_info = p;
212 return (write_to_fasl_file (start, (end - start), (ff_info->handle)));
213 }
214
215 #ifdef ENABLE_GC_DEBUGGING_TOOLS
216
217 static SCHEME_OBJECT * fasdump_saved_Free;
218 static SCHEME_OBJECT * fasdump_saved_heap_alloc_limit;
219 static SCHEME_OBJECT * fasdump_saved_heap_start;
220 static SCHEME_OBJECT * fasdump_saved_heap_end;
221 static SCHEME_OBJECT * fasdump_saved_stack_pointer;
222 static SCHEME_OBJECT * fasdump_saved_stack_guard;
223 static SCHEME_OBJECT * fasdump_saved_stack_start;
224 static SCHEME_OBJECT * fasdump_saved_stack_end;
225 static SCHEME_OBJECT * fasdump_saved_constant_alloc_next;
226 static SCHEME_OBJECT * fasdump_saved_constant_start;
227 static SCHEME_OBJECT * fasdump_saved_constant_end;
228
229 #define SAVE_GC_VAR(name) fasdump_saved_##name = name
230
231 static void
save_gc_vars(void)232 save_gc_vars (void)
233 {
234 SAVE_GC_VAR (Free);
235 SAVE_GC_VAR (heap_alloc_limit);
236 SAVE_GC_VAR (heap_start);
237 SAVE_GC_VAR (heap_end);
238 SAVE_GC_VAR (stack_pointer);
239 SAVE_GC_VAR (stack_guard);
240 SAVE_GC_VAR (stack_start);
241 SAVE_GC_VAR (stack_end);
242 SAVE_GC_VAR (constant_alloc_next);
243 SAVE_GC_VAR (constant_start);
244 SAVE_GC_VAR (constant_end);
245 }
246
247 #define COMPARE_GC_VAR(name) do \
248 { \
249 if (fasdump_saved_##name != name) \
250 outf_error ("GC variable changed: " #name ": %p -> %p\n", \
251 fasdump_saved_##name, name); \
252 } while (false)
253
254 static void
compare_gc_vars(void)255 compare_gc_vars (void)
256 {
257 COMPARE_GC_VAR (Free);
258 COMPARE_GC_VAR (heap_alloc_limit);
259 COMPARE_GC_VAR (heap_start);
260 COMPARE_GC_VAR (heap_end);
261 COMPARE_GC_VAR (stack_pointer);
262 COMPARE_GC_VAR (stack_guard);
263 COMPARE_GC_VAR (stack_start);
264 COMPARE_GC_VAR (stack_end);
265 COMPARE_GC_VAR (constant_alloc_next);
266 COMPARE_GC_VAR (constant_start);
267 COMPARE_GC_VAR (constant_end);
268 }
269
270 #ifdef HAVE_MHASH_H
271
272 static void * fasdump_original_digest;
273
274 static void
save_memory_checksum(void)275 save_memory_checksum (void)
276 {
277 fasdump_original_digest = (compute_memory_checksum ());
278 if (fasdump_original_digest == 0)
279 outf_error ("Unable to compute fasdump memory checksum.");
280 }
281
282 static void
compare_memory_checksum(void)283 compare_memory_checksum (void)
284 {
285 if (fasdump_original_digest != 0)
286 {
287 void * digest = (compute_memory_checksum ());
288 if (digest == 0)
289 outf_error ("Unable to recompute fasdump memory checksum.");
290 else
291 {
292 if ((memcmp (digest,
293 fasdump_original_digest,
294 (mhash_get_block_size (MHASH_MD5))))
295 != 0)
296 outf_error ("Memory mismatch after fasdump.");
297 free (digest);
298 }
299 free (fasdump_original_digest);
300 }
301 }
302
303 static void *
compute_memory_checksum(void)304 compute_memory_checksum (void)
305 {
306 MHASH ctx = (mhash_init (MHASH_MD5));
307 if (ctx == MHASH_FAILED)
308 return (0);
309 (void) mhash (ctx,
310 fasdump_saved_constant_start,
311 ((fasdump_saved_constant_alloc_next
312 - fasdump_saved_constant_start)
313 * SIZEOF_SCHEME_OBJECT));
314 (void) mhash (ctx,
315 fasdump_saved_heap_start,
316 ((fasdump_saved_Free - fasdump_saved_heap_start)
317 * SIZEOF_SCHEME_OBJECT));
318 return (mhash_end (ctx));
319 }
320
321 #endif /* HAVE_MHASH_H */
322 #endif /* ENABLE_GC_DEBUGGING_TOOLS */
323
324 static gc_table_t *
fasdump_table(void)325 fasdump_table (void)
326 {
327 static bool initialized_p = false;
328 static gc_table_t table;
329
330 if (!initialized_p)
331 {
332 initialize_gc_table ((&table), true);
333
334 (GCT_CC_ENTRY ((&table))) = fasdump_cc_entry;
335 (GCT_PRECHECK_FROM ((&table))) = fasdump_precheck_from;
336 (GCT_TRANSPORT_WORDS ((&table))) = fasdump_transport_words;
337
338 (GCT_ENTRY ((&table), TC_PRIMITIVE)) = handle_primitive;
339 (GCT_ENTRY ((&table), TC_MANIFEST_CLOSURE)) = handle_manifest_closure;
340 (GCT_ENTRY ((&table), TC_LINKAGE_SECTION)) = handle_linkage_section;
341 (GCT_ENTRY ((&table), TC_INTERNED_SYMBOL)) = handle_symbol;
342 (GCT_ENTRY ((&table), TC_BROKEN_HEART)) = handle_broken_heart;
343 (GCT_ENTRY ((&table), TC_UNINTERNED_SYMBOL)) = handle_symbol;
344 (GCT_ENTRY ((&table), TC_VARIABLE)) = handle_variable;
345 (GCT_ENTRY ((&table), TC_ENVIRONMENT)) = handle_environment;
346 (GCT_ENTRY ((&table), TC_WEAK_CONS)) = gc_handle_pair;
347 (GCT_ENTRY ((&table), TC_EPHEMERON)) = handle_ephemeron;
348
349 initialized_p = true;
350 }
351 return (&table);
352 }
353
354 static
DEFINE_GC_OBJECT_HANDLER(fasdump_cc_entry)355 DEFINE_GC_OBJECT_HANDLER (fasdump_cc_entry)
356 {
357 #ifdef CC_SUPPORT_P
358 SCHEME_OBJECT * old_addr;
359 SCHEME_OBJECT * new_addr;
360 unsigned long length;
361 SCHEME_OBJECT * eptr;
362
363 cc_seen_p = true;
364 old_addr = (cc_entry_to_block_address (object));
365 if (old_addr == (OBJECT_ADDRESS (compiler_utilities)))
366 return (object);
367 new_addr = (GC_PRECHECK_FROM (old_addr));
368 if (new_addr == 0)
369 {
370 length = (OBJECT_DATUM (*old_addr));
371 new_addr = (GC_TRANSPORT_WORDS (old_addr, (1 + length), true));
372 eptr = (new_addr + length);
373 if ((current_env_mode == FE_DROP_CC)
374 && ((OBJECT_TYPE (read_tospace (eptr))) == TC_ENVIRONMENT))
375 write_tospace (eptr, SHARP_F);
376 }
377 return (CC_ENTRY_NEW_BLOCK (object, new_addr, old_addr));
378 #else
379 gc_no_cc_support ();
380 return (object);
381 #endif
382 }
383
384 static
DEFINE_GC_PRECHECK_FROM(fasdump_precheck_from)385 DEFINE_GC_PRECHECK_FROM (fasdump_precheck_from)
386 {
387 return ((BROKEN_HEART_P (*from)) ? (OBJECT_ADDRESS (*from)) : 0);
388 }
389
390 static
DEFINE_GC_TRANSPORT_WORDS(fasdump_transport_words)391 DEFINE_GC_TRANSPORT_WORDS (fasdump_transport_words)
392 {
393 /* Signal error here if insufficient space -- otherwise
394 gc_transport_words() might terminate the microcode. */
395 if (!tospace_available_p (n_words))
396 signal_error_from_primitive (ERR_FASDUMP_OBJECT_TOO_LARGE);
397 add_fixup (from);
398 return (gc_transport_words (from, n_words, align_p));
399 }
400
401 static
DEFINE_GC_HANDLER(handle_primitive)402 DEFINE_GC_HANDLER (handle_primitive)
403 {
404 (*scan) = (renumber_primitive (object, current_pr));
405 return (scan + 1);
406 }
407
408 static
DEFINE_GC_HANDLER(handle_manifest_closure)409 DEFINE_GC_HANDLER (handle_manifest_closure)
410 {
411 cc_seen_p = true;
412 return (gc_handle_manifest_closure (scan, object));
413 }
414
415 static
DEFINE_GC_HANDLER(handle_linkage_section)416 DEFINE_GC_HANDLER (handle_linkage_section)
417 {
418 cc_seen_p = true;
419 return (gc_handle_linkage_section (scan, object));
420 }
421
422 static
DEFINE_GC_HANDLER(handle_symbol)423 DEFINE_GC_HANDLER (handle_symbol)
424 {
425 SCHEME_OBJECT * from = (OBJECT_ADDRESS (object));
426 SCHEME_OBJECT * new_address = (GC_PRECHECK_FROM (from));
427 if (new_address == 0)
428 {
429 new_address = (GC_TRANSPORT_WORDS (from, 2, false));
430 write_tospace ((new_address + SYMBOL_GLOBAL_VALUE),
431 (((OBJECT_TYPE (object)) == TC_INTERNED_SYMBOL)
432 ? BROKEN_HEART_ZERO
433 : UNBOUND_OBJECT));
434 }
435 (*scan) = (OBJECT_NEW_ADDRESS (object, new_address));
436 return (scan + 1);
437 }
438
439 static
DEFINE_GC_HANDLER(handle_broken_heart)440 DEFINE_GC_HANDLER (handle_broken_heart)
441 {
442 return
443 (((OBJECT_DATUM (object)) == 0)
444 ? (scan + 1)
445 : (gc_handle_broken_heart (scan, object)));
446 }
447
448 static
DEFINE_GC_HANDLER(handle_variable)449 DEFINE_GC_HANDLER (handle_variable)
450 {
451 SCHEME_OBJECT * from = (OBJECT_ADDRESS (object));
452 SCHEME_OBJECT * new_address = (GC_PRECHECK_FROM (from));
453 if (new_address == 0)
454 {
455 new_address = (GC_TRANSPORT_WORDS (from, 3, false));
456 write_tospace ((new_address + 1), UNCOMPILED_VARIABLE);
457 write_tospace ((new_address + 2), SHARP_F);
458 }
459 (*scan) = (OBJECT_NEW_ADDRESS (object, new_address));
460 return (scan + 1);
461 }
462
463 static
DEFINE_GC_HANDLER(handle_environment)464 DEFINE_GC_HANDLER (handle_environment)
465 {
466 if (current_env_mode != FE_DUMP)
467 signal_error_from_primitive (ERR_FASDUMP_ENVIRONMENT);
468 (*scan) = (GC_HANDLE_VECTOR (object, false));
469 return (scan + 1);
470 }
471
472 static
DEFINE_GC_HANDLER(handle_ephemeron)473 DEFINE_GC_HANDLER (handle_ephemeron)
474 {
475 /* Count each one once by counting only if there is no borken heart. */
476 if (0 == (GC_PRECHECK_FROM (OBJECT_ADDRESS (object))))
477 dumped_ephemeron_count += 1;
478 return (gc_handle_unaligned_vector (scan, object));
479 }
480
481 typedef struct
482 {
483 SCHEME_OBJECT * addr;
484 SCHEME_OBJECT object;
485 } fixup_t;
486
487 static fixup_t * fixups_start;
488 static fixup_t * fixups_next;
489 static fixup_t * fixups_end;
490
491 static void
initialize_fixups(void)492 initialize_fixups (void)
493 {
494 fixup_t * data = (OS_malloc (64 * (sizeof (fixup_t))));
495 fixups_start = data;
496 fixups_next = data;
497 fixups_end = (data + 64);
498 transaction_record_action (tat_always, run_fixups, 0);
499 }
500
501 static void
add_fixup(SCHEME_OBJECT * addr)502 add_fixup (SCHEME_OBJECT * addr)
503 {
504 if (fixups_next >= fixups_end)
505 {
506 unsigned long n = ((fixups_end - fixups_start) * 2);
507 unsigned long m = (fixups_next - fixups_start);
508 fixup_t * data = (OS_realloc (fixups_start, (n * (sizeof (fixup_t)))));
509 fixups_start = data;
510 fixups_next = (data + m);
511 fixups_end = (data + n);
512 }
513 (fixups_next -> addr) = addr;
514 (fixups_next -> object) = (*addr);
515 fixups_next += 1;
516 }
517
518 static void
run_fixups(void * p)519 run_fixups (void * p)
520 {
521 fixup_t * scan = fixups_start;
522 while (scan < fixups_next)
523 {
524 (* (scan->addr)) = (scan->object);
525 scan += 1;
526 }
527 OS_free (fixups_start);
528 }
529
530 DEFINE_PRIMITIVE ("DUMP-BAND", Prim_band_dump, 2, 2,
531 "(PROCEDURE NAMESTRING)\n\
532 Saves an image of the current world to the file NAMESTRING.\n\
533 When the file is reloaded, PROCEDURE is called with an argument of #F.")
534 {
535 SCHEME_OBJECT * to = Free;
536 SCHEME_OBJECT * prim_table_start;
537 SCHEME_OBJECT * c_code_table_start;
538 bool result;
539 PRIMITIVE_HEADER (2);
540
541 CHECK_ARG (1, INTERPRETER_APPLICABLE_P);
542 CHECK_ARG (2, STRING_P);
543
544 Primitive_GC_If_Needed (5);
545 initialize_fasl_header (true, true);
546 {
547 SCHEME_OBJECT comb;
548 SCHEME_OBJECT root;
549
550 comb = (MAKE_POINTER_OBJECT (TC_COMBINATION, to));
551 (to[COMB_VECTOR_HEADER]) = MAKE_OBJECT(TC_MANIFEST_VECTOR, 2);
552 (to[COMB_FN_SLOT]) = (ARG_REF (1));
553 (to[COMB_ARG_1_SLOT]) = SHARP_F;
554 to += 3;
555
556 root = (MAKE_POINTER_OBJECT (TC_LIST, to));
557 (*to++) = comb;
558 (*to++) = compiler_utilities;
559
560 (FASLHDR_ROOT_POINTER (fh)) = to;
561 (*to++) = root;
562 }
563
564 prim_table_start = to;
565 (FASLHDR_N_PRIMITIVES (fh)) = MAX_PRIMITIVE;
566 (FASLHDR_PRIMITIVE_TABLE_SIZE (fh)) = (primitive_table_export_length ());
567 to += (FASLHDR_PRIMITIVE_TABLE_SIZE (fh));
568
569 c_code_table_start = to;
570 #ifdef CC_IS_C
571 (FASLHDR_C_CODE_TABLE_SIZE (fh))
572 = (c_code_table_export_length (& (FASLHDR_N_C_CODE_BLOCKS (fh))));
573 to += (FASLHDR_C_CODE_TABLE_SIZE (fh));
574 #endif
575
576 if (to > heap_end)
577 result = false;
578 else
579 {
580 const char * filename = (STRING_POINTER (ARG_REF (2)));
581 fasl_file_handle_t handle;
582
583 export_primitive_table (prim_table_start);
584 #ifdef CC_IS_C
585 export_c_code_table (c_code_table_start);
586 #endif
587
588 (FASLHDR_HEAP_START (fh)) = heap_start;
589 (FASLHDR_HEAP_END (fh)) = prim_table_start;
590 (FASLHDR_CONSTANT_START (fh)) = constant_start;
591 (FASLHDR_CONSTANT_END (fh)) = constant_alloc_next;
592 finalize_fasl_header (ephemeron_count);
593
594 OS_file_remove_link (filename);
595 if (!open_fasl_output_file (filename, (&handle)))
596 error_bad_range_arg (2);
597
598 result
599 = (write_fasl_file (prim_table_start, c_code_table_start, handle));
600
601 if (!close_fasl_output_file (handle))
602 OS_file_remove (filename);
603 }
604 PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (result));
605 }
606
607 static void
initialize_fasl_header(bool cc_p,bool band_p)608 initialize_fasl_header (bool cc_p, bool band_p)
609 {
610 fh = (&fasl_header);
611 /* Provisionally set the version -- later, finalize_fasl_header will
612 change it to the EPHEMERON format if there were any ephemerons.
613 The difference between the older C_CODE format and the newer
614 STACK_END format applies only to bands. */
615 (FASLHDR_VERSION (fh))
616 = (band_p ? FASL_VERSION_STACK_END : FASL_VERSION_C_CODE);
617 (FASLHDR_ARCH (fh)) = CURRENT_FASL_ARCH;
618 (FASLHDR_BAND_P (fh)) = band_p;
619
620 #ifdef HEAP_IN_LOW_MEMORY
621 (FASLHDR_MEMORY_BASE (fh)) = 0;
622 #else
623 (FASLHDR_MEMORY_BASE (fh)) = memory_block_start;
624 #endif
625 (FASLHDR_HEAP_RESERVED (fh)) = (band_p ? heap_reserved : 0);
626
627 (FASLHDR_STACK_START (fh)) = stack_start;
628 (FASLHDR_STACK_END (fh)) = stack_end;
629
630 if (cc_p)
631 {
632 (FASLHDR_CC_VERSION (fh)) = compiler_interface_version;
633 (FASLHDR_CC_ARCH (fh)) = compiler_processor_type;
634 (FASLHDR_UTILITIES_VECTOR (fh)) = compiler_utilities;
635 }
636 else
637 {
638 (FASLHDR_CC_VERSION (fh)) = 0;
639 (FASLHDR_CC_ARCH (fh)) = COMPILER_NONE_TYPE;
640 (FASLHDR_UTILITIES_VECTOR (fh)) = SHARP_F;
641 }
642 (FASLHDR_N_C_CODE_BLOCKS (fh)) = 0;
643 (FASLHDR_C_CODE_TABLE_SIZE (fh)) = 0;
644 }
645
646 static void
finalize_fasl_header(unsigned long ephemeron_count)647 finalize_fasl_header (unsigned long ephemeron_count)
648 {
649 if (ephemeron_count != 0)
650 {
651 (FASLHDR_VERSION (fh)) = FASL_VERSION_EPHEMERONS;
652 (FASLHDR_EPHEMERON_COUNT (fh)) = ephemeron_count;
653 }
654 }
655
656 static bool
write_fasl_file(SCHEME_OBJECT * prim_table_start,SCHEME_OBJECT * c_code_table_start,fasl_file_handle_t handle)657 write_fasl_file (SCHEME_OBJECT * prim_table_start,
658 SCHEME_OBJECT * c_code_table_start,
659 fasl_file_handle_t handle)
660 {
661 return
662 ((write_fasl_header (fh, handle))
663 && (write_to_fasl_file ((FASLHDR_HEAP_START (fh)),
664 (FASLHDR_HEAP_SIZE (fh)),
665 handle))
666 && (write_to_fasl_file ((FASLHDR_CONSTANT_START (fh)),
667 (FASLHDR_CONSTANT_SIZE (fh)),
668 handle))
669 && (write_to_fasl_file (prim_table_start,
670 (FASLHDR_PRIMITIVE_TABLE_SIZE (fh)),
671 handle))
672 && (write_to_fasl_file (c_code_table_start,
673 (FASLHDR_C_CODE_TABLE_SIZE (fh)),
674 handle)));
675 }
676