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 /* I/O for fasdump and fasload */
28
29 #include "config.h"
30 #include "fasl.h"
31
32 static void encode_fasl_header (SCHEME_OBJECT *, fasl_header_t *);
33 static bool decode_fasl_header (SCHEME_OBJECT *, fasl_header_t *);
34
35 bool
open_fasl_output_file(const char * filename,fasl_file_handle_t * handle_r)36 open_fasl_output_file (const char * filename, fasl_file_handle_t * handle_r)
37 {
38 FILE * s = (fopen (filename, "wb"));
39 if (s == 0)
40 return (false);
41 (*handle_r) = s;
42 return (true);
43 }
44
45 bool
close_fasl_output_file(fasl_file_handle_t handle)46 close_fasl_output_file (fasl_file_handle_t handle)
47 {
48 return ((fclose (handle)) == 0);
49 }
50
51 bool
write_fasl_header(fasl_header_t * h,fasl_file_handle_t handle)52 write_fasl_header (fasl_header_t * h, fasl_file_handle_t handle)
53 {
54 SCHEME_OBJECT raw [FASL_HEADER_LENGTH];
55
56 encode_fasl_header (raw, h);
57 return (write_to_fasl_file (raw, FASL_HEADER_LENGTH, handle));
58 }
59
60 bool
write_to_fasl_file(const void * start,size_t n_words,fasl_file_handle_t handle)61 write_to_fasl_file (const void * start, size_t n_words,
62 fasl_file_handle_t handle)
63 {
64 return ((fwrite (start, SIZEOF_SCHEME_OBJECT, n_words, handle)) == n_words);
65 }
66
67 bool
open_fasl_input_file(const char * filename,fasl_file_handle_t * handle_r)68 open_fasl_input_file (const char * filename, fasl_file_handle_t * handle_r)
69 {
70 FILE * s = (fopen (filename, "rb"));
71 if (s == 0)
72 return (false);
73 (*handle_r) = s;
74 return (true);
75 }
76
77 bool
close_fasl_input_file(fasl_file_handle_t handle)78 close_fasl_input_file (fasl_file_handle_t handle)
79 {
80 return ((fclose (handle)) == 0);
81 }
82
83 bool
read_fasl_header(fasl_header_t * h,fasl_file_handle_t handle)84 read_fasl_header (fasl_header_t * h, fasl_file_handle_t handle)
85 {
86 SCHEME_OBJECT raw [FASL_HEADER_LENGTH];
87 return
88 ((read_from_fasl_file (raw, FASL_HEADER_LENGTH, handle))
89 && (decode_fasl_header (raw, h)));
90 }
91
92 bool
read_from_fasl_file(void * start,size_t n_words,fasl_file_handle_t handle)93 read_from_fasl_file (void * start, size_t n_words, fasl_file_handle_t handle)
94 {
95 return ((fread (start, SIZEOF_SCHEME_OBJECT, n_words, handle)) == n_words);
96 }
97
98 fasl_read_status_t
check_fasl_version(fasl_header_t * fh)99 check_fasl_version (fasl_header_t * fh)
100 {
101 return
102 ((((FASLHDR_VERSION (fh)) >= OLDEST_INPUT_FASL_VERSION)
103 && ((FASLHDR_VERSION (fh)) <= NEWEST_INPUT_FASL_VERSION))
104 ? (((FASLHDR_ARCH (fh)) == CURRENT_FASL_ARCH)
105 ? FASL_FILE_FINE
106 : FASL_FILE_BAD_MACHINE)
107 : FASL_FILE_BAD_VERSION);
108 }
109
110 fasl_read_status_t
check_fasl_cc_version(fasl_header_t * fh,unsigned long version,unsigned long type)111 check_fasl_cc_version (fasl_header_t * fh,
112 unsigned long version, unsigned long type)
113 {
114 return
115 ((((FASLHDR_CC_VERSION (fh)) == 0)
116 && ((FASLHDR_CC_ARCH (fh)) == COMPILER_NONE_TYPE))
117 ? FASL_FILE_FINE
118 : ((FASLHDR_CC_VERSION (fh)) == version)
119 ? (((FASLHDR_CC_ARCH (fh)) == type)
120 ? FASL_FILE_FINE
121 : FASL_FILE_BAD_PROCESSOR)
122 : FASL_FILE_BAD_INTERFACE);
123 }
124
125 static void
encode_fasl_header(SCHEME_OBJECT * raw,fasl_header_t * h)126 encode_fasl_header (SCHEME_OBJECT * raw, fasl_header_t * h)
127 {
128 {
129 SCHEME_OBJECT * p = raw;
130 SCHEME_OBJECT * e = (raw + FASL_HEADER_LENGTH);
131 while (p < e)
132 (*p++) = SHARP_F;
133 }
134 #ifdef DEBUG
135 #ifdef HEAP_IN_LOW_MEMORY
136 fprintf (stderr, "\nmemory_base = %#lx\n",
137 ((unsigned long) (FASLHDR_MEMORY_BASE (h))));
138 #endif
139 fprintf (stderr, "\nheap start %#lx\n",
140 ((unsigned long) (FASLHDR_HEAP_START (h))));
141 fprintf (stderr, "\nroot object %#lx\n",
142 ((unsigned long) (FASLHDR_ROOT_POINTER (h))));
143 #endif
144
145 (raw[FASL_OFFSET_MARKER]) = FASL_FILE_MARKER;
146
147 (raw[FASL_OFFSET_VERSION])
148 = (MAKE_FASL_VERSION ((FASLHDR_VERSION (h)), (FASLHDR_ARCH (h))));
149 (raw[FASL_OFFSET_CI_VERSION])
150 = (MAKE_CI_VERSION ((FASLHDR_BAND_P (h)),
151 (FASLHDR_CC_VERSION (h)),
152 (FASLHDR_CC_ARCH (h))));
153
154 (raw[FASL_OFFSET_MEM_BASE])
155 = ((SCHEME_OBJECT) (FASLHDR_MEMORY_BASE (h)));
156
157 (raw[FASL_OFFSET_DUMPED_OBJ])
158 = (MAKE_BROKEN_HEART (FASLHDR_ROOT_POINTER (h)));
159
160 (raw[FASL_OFFSET_HEAP_BASE])
161 = (MAKE_BROKEN_HEART (FASLHDR_HEAP_START (h)));
162 (raw[FASL_OFFSET_HEAP_SIZE])
163 = (MAKE_OBJECT (TC_BROKEN_HEART, (FASLHDR_HEAP_SIZE (h))));
164
165 if ((FASLHDR_VERSION (h)) >= FASL_VERSION_STACK_END)
166 (raw[FASL_OFFSET_HEAP_RSVD])
167 = (MAKE_OBJECT (TC_BROKEN_HEART, (FASLHDR_HEAP_RESERVED (h))));
168
169 (raw[FASL_OFFSET_CONST_BASE])
170 = (MAKE_BROKEN_HEART (FASLHDR_CONSTANT_START (h)));
171 (raw[FASL_OFFSET_CONST_SIZE])
172 = (MAKE_OBJECT (TC_BROKEN_HEART, (FASLHDR_CONSTANT_SIZE (h))));
173
174 if ((FASLHDR_VERSION (h)) >= FASL_VERSION_STACK_END)
175 {
176 (raw[FASL_OFFSET_STACK_START])
177 = (MAKE_BROKEN_HEART (FASLHDR_STACK_START (h)));
178 (raw[FASL_OFFSET_STACK_SIZE])
179 = (MAKE_OBJECT (TC_BROKEN_HEART, (FASLHDR_STACK_SIZE (h))));
180 }
181 else
182 (raw[FASL_OFFSET_STACK_START])
183 = (MAKE_BROKEN_HEART (FASLHDR_STACK_END (h)));
184
185 (raw[FASL_OFFSET_PRIM_LENGTH])
186 = (MAKE_OBJECT (TC_BROKEN_HEART, (FASLHDR_N_PRIMITIVES (h))));
187 (raw[FASL_OFFSET_PRIM_SIZE])
188 = (MAKE_OBJECT (TC_BROKEN_HEART, (FASLHDR_PRIMITIVE_TABLE_SIZE (h))));
189
190 (raw[FASL_OFFSET_C_LENGTH])
191 = (MAKE_OBJECT (TC_BROKEN_HEART, (FASLHDR_N_C_CODE_BLOCKS (h))));
192 (raw[FASL_OFFSET_C_SIZE])
193 = (MAKE_OBJECT (TC_BROKEN_HEART, (FASLHDR_C_CODE_TABLE_SIZE (h))));
194
195 (raw[FASL_OFFSET_UT_BASE]) = (FASLHDR_UTILITIES_VECTOR (h));
196
197 if ((FASLHDR_VERSION (h)) >= FASL_VERSION_EPHEMERONS)
198 (raw[FASL_OFFSET_EPHEMERONS])
199 = (MAKE_OBJECT (TC_BROKEN_HEART, (FASLHDR_EPHEMERON_COUNT (h))));
200 }
201
202 static bool
decode_fasl_header(SCHEME_OBJECT * raw,fasl_header_t * h)203 decode_fasl_header (SCHEME_OBJECT * raw, fasl_header_t * h)
204 {
205 if ((raw[FASL_OFFSET_MARKER]) != FASL_FILE_MARKER)
206 return (false);
207 {
208 SCHEME_OBJECT object = (raw[FASL_OFFSET_VERSION]);
209 (FASLHDR_VERSION (h)) = (FASL_VERSION (object));
210 (FASLHDR_ARCH (h)) = (FASL_ARCH (object));
211 }
212 {
213 SCHEME_OBJECT object = (raw[FASL_OFFSET_CI_VERSION]);
214 (FASLHDR_CC_VERSION (h)) = (CI_VERSION (object));
215 (FASLHDR_CC_ARCH (h)) = (CI_PROCESSOR (object));
216 (FASLHDR_BAND_P (h)) = (CI_BAND_P (object));
217 }
218 {
219 SCHEME_OBJECT * fasl_memory_base
220 = ((SCHEME_OBJECT *) (raw[FASL_OFFSET_MEM_BASE]));
221 (FASLHDR_MEMORY_BASE (h)) = fasl_memory_base;
222
223 (FASLHDR_ROOT_POINTER (h))
224 = (fasl_object_address ((raw[FASL_OFFSET_DUMPED_OBJ]), h));
225
226 (FASLHDR_HEAP_START (h))
227 = (fasl_object_address ((raw[FASL_OFFSET_HEAP_BASE]), h));
228 (FASLHDR_HEAP_END (h))
229 = ((FASLHDR_HEAP_START (h))
230 + (OBJECT_DATUM (raw[FASL_OFFSET_HEAP_SIZE])));
231 (FASLHDR_HEAP_RESERVED (h))
232 = (((FASLHDR_VERSION (h)) >= FASL_VERSION_STACK_END)
233 ? (OBJECT_DATUM (raw[FASL_OFFSET_HEAP_RSVD]))
234 : 0);
235
236 (FASLHDR_CONSTANT_START (h))
237 = (fasl_object_address ((raw[FASL_OFFSET_CONST_BASE]), h));
238 (FASLHDR_CONSTANT_END (h))
239 = ((FASLHDR_CONSTANT_START (h))
240 + (OBJECT_DATUM (raw[FASL_OFFSET_CONST_SIZE])));
241
242 if ((FASLHDR_VERSION (h)) >= FASL_VERSION_STACK_END)
243 {
244 (FASLHDR_STACK_START (h))
245 = (fasl_object_address ((raw[FASL_OFFSET_STACK_START]), h));
246 (FASLHDR_STACK_END (h))
247 = ((FASLHDR_STACK_START (h))
248 + (OBJECT_DATUM (raw[FASL_OFFSET_STACK_SIZE])));
249 }
250 else
251 /* In older versions, the "stack start" field held "stack
252 bottom" instead. Since the stack grows downwards, this was
253 the maximum address. */
254 {
255 (FASLHDR_STACK_END (h))
256 = (fasl_object_address ((raw[FASL_OFFSET_STACK_START]), h));
257 /* If !HEAP_IN_LOW_MEMORY then fasl_memory_base is the right
258 value. Otherwise, fasl_memory_base is zero and that is at
259 least guaranteed to encompass the whole stack. */
260 (FASLHDR_STACK_START (h)) = fasl_memory_base;
261 }
262
263 (FASLHDR_N_PRIMITIVES (h))
264 = (OBJECT_DATUM (raw[FASL_OFFSET_PRIM_LENGTH]));
265 (FASLHDR_PRIMITIVE_TABLE_SIZE (h))
266 = (OBJECT_DATUM (raw[FASL_OFFSET_PRIM_SIZE]));
267
268 (FASLHDR_N_C_CODE_BLOCKS (h))
269 = (OBJECT_DATUM (raw[FASL_OFFSET_C_LENGTH]));
270 (FASLHDR_C_CODE_TABLE_SIZE (h))
271 = (OBJECT_DATUM (raw[FASL_OFFSET_C_SIZE]));
272
273 {
274 SCHEME_OBJECT ruv = (raw[FASL_OFFSET_UT_BASE]);
275 if (ruv == SHARP_F)
276 {
277 (FASLHDR_UTILITIES_VECTOR (h)) = SHARP_F;
278 (FASLHDR_UTILITIES_START (h)) = 0;
279 }
280 else
281 {
282 SCHEME_OBJECT fuv
283 = (OBJECT_NEW_ADDRESS (ruv, (fasl_object_address (ruv, h))));
284 (FASLHDR_UTILITIES_VECTOR (h)) = fuv;
285 (FASLHDR_UTILITIES_START (h)) = (OBJECT_ADDRESS (fuv));
286 }
287 }
288 (__FASLHDR_UTILITIES_END (h)) = 0;
289 }
290 if ((FASLHDR_VERSION (h)) >= FASL_VERSION_EPHEMERONS)
291 (FASLHDR_EPHEMERON_COUNT (h))
292 = (OBJECT_DATUM (raw[FASL_OFFSET_EPHEMERONS]));
293 return (true);
294 }
295
296 SCHEME_OBJECT *
fasl_object_address(SCHEME_OBJECT o,fasl_header_t * h)297 fasl_object_address (SCHEME_OBJECT o, fasl_header_t * h)
298 {
299 if ((FASLHDR_MEMORY_BASE (h)) != 0)
300 return ((FASLHDR_MEMORY_BASE (h)) + (OBJECT_DATUM (o)));
301 if ((FASLHDR_ARCH (h)) == CURRENT_FASL_ARCH)
302 return (OBJECT_ADDRESS (o));
303 abort ();
304 return (0);
305 }
306
307 insn_t *
fasl_cc_address(SCHEME_OBJECT o,fasl_header_t * h)308 fasl_cc_address (SCHEME_OBJECT o, fasl_header_t * h)
309 {
310 if ((FASLHDR_MEMORY_BASE (h)) != 0)
311 return (((insn_t *) (FASLHDR_MEMORY_BASE (h))) + (OBJECT_DATUM (o)));
312 if ((FASLHDR_ARCH (h)) == CURRENT_FASL_ARCH)
313 return (CC_ENTRY_ADDRESS (o));
314 abort ();
315 return (0);
316 }
317
318 SCHEME_OBJECT
fasl_raw_address_to_object(unsigned int type,SCHEME_OBJECT * address,fasl_header_t * h)319 fasl_raw_address_to_object (unsigned int type,
320 SCHEME_OBJECT * address,
321 fasl_header_t * h)
322 {
323 if ((FASLHDR_MEMORY_BASE (h)) != 0)
324 return (MAKE_OBJECT (type, (address - (FASLHDR_MEMORY_BASE (h)))));
325 if ((FASLHDR_ARCH (h)) == CURRENT_FASL_ARCH)
326 return (MAKE_POINTER_OBJECT (type, address));
327 abort ();
328 return (UNSPECIFIC);
329 }
330
331 SCHEME_OBJECT
fasl_raw_address_to_cc_entry(insn_t * address,fasl_header_t * h)332 fasl_raw_address_to_cc_entry (insn_t * address, fasl_header_t * h)
333 {
334 if ((FASLHDR_MEMORY_BASE (h)) != 0)
335 return (MAKE_OBJECT (TC_COMPILED_ENTRY,
336 (address - ((insn_t *) (FASLHDR_MEMORY_BASE (h))))));
337 if ((FASLHDR_ARCH (h)) == CURRENT_FASL_ARCH)
338 return (MAKE_CC_ENTRY (address));
339 abort ();
340 return (UNSPECIFIC);
341 }
342
343 SCHEME_OBJECT *
faslhdr_utilities_end(fasl_header_t * h)344 faslhdr_utilities_end (fasl_header_t * h)
345 {
346 if (((__FASLHDR_UTILITIES_END (h)) == 0)
347 && (VECTOR_P (FASLHDR_UTILITIES_VECTOR (h))))
348 (__FASLHDR_UTILITIES_END (h))
349 = (VECTOR_LOC ((FASLHDR_UTILITIES_VECTOR (h)),
350 (VECTOR_LENGTH (FASLHDR_UTILITIES_VECTOR (h)))));
351 return (__FASLHDR_UTILITIES_END (h));
352 }
353