Commit | Line | Data |
---|---|---|
26d14806 MW |
1 | /* Copyright (C) 2001, 2009, 2010, 2011, 2012 |
2 | * 2013 Free Software Foundation, Inc. | |
8f5cfc81 | 3 | * |
560b9c25 | 4 | * This library is free software; you can redistribute it and/or |
53befeb7 NJ |
5 | * modify it under the terms of the GNU Lesser General Public License |
6 | * as published by the Free Software Foundation; either version 3 of | |
7 | * the License, or (at your option) any later version. | |
8f5cfc81 | 8 | * |
53befeb7 NJ |
9 | * This library is distributed in the hope that it will be useful, but |
10 | * WITHOUT ANY WARRANTY; without even the implied warranty of | |
560b9c25 AW |
11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
12 | * Lesser General Public License for more details. | |
8f5cfc81 | 13 | * |
560b9c25 AW |
14 | * You should have received a copy of the GNU Lesser General Public |
15 | * License along with this library; if not, write to the Free Software | |
53befeb7 NJ |
16 | * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA |
17 | * 02110-1301 USA | |
560b9c25 | 18 | */ |
8f5cfc81 | 19 | |
13c47753 AW |
20 | #if HAVE_CONFIG_H |
21 | # include <config.h> | |
22 | #endif | |
23 | ||
8f5cfc81 KN |
24 | #include <string.h> |
25 | #include <fcntl.h> | |
26 | #include <unistd.h> | |
13a78b0f AW |
27 | |
28 | #ifdef HAVE_SYS_MMAN_H | |
8f5cfc81 | 29 | #include <sys/mman.h> |
13a78b0f AW |
30 | #endif |
31 | ||
8f5cfc81 KN |
32 | #include <sys/stat.h> |
33 | #include <sys/types.h> | |
054599f1 | 34 | #include <assert.h> |
1119e493 | 35 | #include <alignof.h> |
de2c0a10 | 36 | #include <byteswap.h> |
8f5cfc81 | 37 | |
13a78b0f AW |
38 | #include <full-read.h> |
39 | ||
560b9c25 | 40 | #include "_scm.h" |
afc74c29 | 41 | #include "elf.h" |
8f5cfc81 KN |
42 | #include "programs.h" |
43 | #include "objcodes.h" | |
44 | ||
b8bc86bc AW |
45 | /* Before, we used __BYTE_ORDER, but that is not defined on all |
46 | systems. So punt and use automake, PDP endianness be damned. */ | |
47 | #define SCM_BYTE_ORDER_BE 4321 | |
48 | #define SCM_BYTE_ORDER_LE 1234 | |
49 | ||
50 | /* Byte order of the build machine. */ | |
51 | #ifdef WORDS_BIGENDIAN | |
52 | #define SCM_BYTE_ORDER SCM_BYTE_ORDER_BE | |
53 | #else | |
54 | #define SCM_BYTE_ORDER SCM_BYTE_ORDER_LE | |
55 | #endif | |
56 | ||
57 | /* This file contains the loader for Guile's on-disk format: ELF with | |
58 | some custom tags in the dynamic segment. */ | |
afc74c29 AW |
59 | |
60 | #if SIZEOF_SCM_T_BITS == 4 | |
61 | #define Elf_Half Elf32_Half | |
62 | #define Elf_Word Elf32_Word | |
63 | #define Elf_Ehdr Elf32_Ehdr | |
64 | #define ELFCLASS ELFCLASS32 | |
65 | #define Elf_Phdr Elf32_Phdr | |
66 | #define Elf_Dyn Elf32_Dyn | |
67 | #elif SIZEOF_SCM_T_BITS == 8 | |
68 | #define Elf_Half Elf64_Half | |
69 | #define Elf_Word Elf64_Word | |
70 | #define Elf_Ehdr Elf64_Ehdr | |
71 | #define ELFCLASS ELFCLASS64 | |
72 | #define Elf_Phdr Elf64_Phdr | |
73 | #define Elf_Dyn Elf64_Dyn | |
74 | #else | |
75 | #error | |
76 | #endif | |
77 | ||
78 | #define DT_LOGUILE 0x37146000 /* Start of Guile-specific */ | |
79 | #define DT_GUILE_GC_ROOT 0x37146000 /* Offset of GC roots */ | |
80 | #define DT_GUILE_GC_ROOT_SZ 0x37146001 /* Size in machine words of GC | |
81 | roots */ | |
82 | #define DT_GUILE_ENTRY 0x37146002 /* Address of entry thunk */ | |
83 | #define DT_GUILE_RTL_VERSION 0x37146003 /* Bytecode version */ | |
84 | #define DT_HIGUILE 0x37146fff /* End of Guile-specific */ | |
85 | ||
86 | #ifdef WORDS_BIGENDIAN | |
87 | #define ELFDATA ELFDATA2MSB | |
88 | #else | |
89 | #define ELFDATA ELFDATA2LSB | |
90 | #endif | |
91 | ||
92 | enum bytecode_kind | |
93 | { | |
94 | BYTECODE_KIND_NONE, | |
95 | BYTECODE_KIND_GUILE_2_0 | |
96 | }; | |
97 | ||
98 | static SCM | |
99 | pointer_to_procedure (enum bytecode_kind bytecode_kind, char *ptr) | |
100 | { | |
101 | switch (bytecode_kind) | |
102 | { | |
103 | case BYTECODE_KIND_GUILE_2_0: | |
104 | { | |
105 | SCM objcode; | |
106 | scm_t_bits tag = SCM_MAKE_OBJCODE_TAG (SCM_OBJCODE_TYPE_MMAP, 0); | |
107 | ||
108 | objcode = scm_double_cell (tag, (scm_t_bits) ptr, SCM_BOOL_F_BITS, 0); | |
109 | return scm_make_program (objcode, SCM_BOOL_F, SCM_UNDEFINED); | |
110 | } | |
111 | case BYTECODE_KIND_NONE: | |
112 | default: | |
113 | abort (); | |
114 | } | |
115 | } | |
116 | ||
117 | static const char* | |
118 | check_elf_header (const Elf_Ehdr *header) | |
119 | { | |
120 | if (!(header->e_ident[EI_MAG0] == ELFMAG0 | |
121 | && header->e_ident[EI_MAG1] == ELFMAG1 | |
122 | && header->e_ident[EI_MAG2] == ELFMAG2 | |
123 | && header->e_ident[EI_MAG3] == ELFMAG3)) | |
124 | return "not an ELF file"; | |
125 | ||
126 | if (header->e_ident[EI_CLASS] != ELFCLASS) | |
127 | return "ELF file does not have native word size"; | |
128 | ||
129 | if (header->e_ident[EI_DATA] != ELFDATA) | |
130 | return "ELF file does not have native byte order"; | |
131 | ||
132 | if (header->e_ident[EI_VERSION] != EV_CURRENT) | |
133 | return "bad ELF version"; | |
134 | ||
135 | if (header->e_ident[EI_OSABI] != ELFOSABI_STANDALONE) | |
136 | return "unexpected OS ABI"; | |
137 | ||
138 | if (header->e_ident[EI_ABIVERSION] != 0) | |
139 | return "unexpected ABI version"; | |
140 | ||
141 | if (header->e_type != ET_DYN) | |
142 | return "unexpected ELF type"; | |
143 | ||
144 | if (header->e_machine != EM_NONE) | |
145 | return "unexpected machine"; | |
146 | ||
147 | if (header->e_version != EV_CURRENT) | |
148 | return "unexpected ELF version"; | |
149 | ||
150 | if (header->e_ehsize != sizeof *header) | |
151 | return "unexpected header size"; | |
152 | ||
153 | if (header->e_phentsize != sizeof (Elf_Phdr)) | |
154 | return "unexpected program header size"; | |
155 | ||
156 | return NULL; | |
157 | } | |
158 | ||
159 | static int | |
160 | segment_flags_to_prot (Elf_Word flags) | |
161 | { | |
162 | int prot = 0; | |
163 | ||
164 | if (flags & PF_X) | |
165 | prot |= PROT_EXEC; | |
166 | if (flags & PF_W) | |
167 | prot |= PROT_WRITE; | |
168 | if (flags & PF_R) | |
169 | prot |= PROT_READ; | |
170 | ||
171 | return prot; | |
172 | } | |
173 | ||
174 | static int | |
175 | map_segments (int fd, char **base, | |
176 | const Elf_Phdr *from, const Elf_Phdr *to) | |
177 | { | |
178 | int prot = segment_flags_to_prot (from->p_flags); | |
179 | char *ret; | |
180 | ||
181 | ret = mmap (*base + from->p_vaddr, | |
182 | to->p_offset + to->p_filesz - from->p_offset, | |
183 | prot, MAP_PRIVATE, fd, from->p_offset); | |
184 | ||
185 | if (ret == (char *) -1) | |
186 | return 1; | |
187 | ||
188 | if (!*base) | |
189 | *base = ret; | |
190 | ||
191 | return 0; | |
192 | } | |
193 | ||
194 | static int | |
195 | mprotect_segments (char *base, const Elf_Phdr *from, const Elf_Phdr *to) | |
196 | { | |
197 | return mprotect (base + from->p_vaddr, | |
198 | to->p_vaddr + to->p_memsz - from->p_vaddr, | |
199 | segment_flags_to_prot (from->p_flags)); | |
200 | } | |
201 | ||
202 | static char* | |
203 | process_dynamic_segment (char *base, Elf_Phdr *dyn_phdr, | |
204 | SCM *init_out, SCM *entry_out) | |
205 | { | |
206 | char *dyn_addr = base + dyn_phdr->p_vaddr; | |
207 | Elf_Dyn *dyn = (Elf_Dyn *) dyn_addr; | |
208 | size_t i, dyn_size = dyn_phdr->p_memsz / sizeof (Elf_Dyn); | |
209 | char *init = 0, *gc_root = 0, *entry = 0; | |
210 | scm_t_ptrdiff gc_root_size = 0; | |
211 | enum bytecode_kind bytecode_kind = BYTECODE_KIND_NONE; | |
212 | ||
213 | for (i = 0; i < dyn_size; i++) | |
214 | { | |
215 | if (dyn[i].d_tag == DT_NULL) | |
216 | break; | |
217 | ||
218 | switch (dyn[i].d_tag) | |
219 | { | |
220 | case DT_INIT: | |
221 | if (init) | |
222 | return "duplicate DT_INIT"; | |
223 | init = base + dyn[i].d_un.d_val; | |
224 | break; | |
225 | case DT_GUILE_GC_ROOT: | |
226 | if (gc_root) | |
227 | return "duplicate DT_GUILE_GC_ROOT"; | |
228 | gc_root = base + dyn[i].d_un.d_val; | |
229 | break; | |
230 | case DT_GUILE_GC_ROOT_SZ: | |
231 | if (gc_root_size) | |
232 | return "duplicate DT_GUILE_GC_ROOT_SZ"; | |
233 | gc_root_size = dyn[i].d_un.d_val; | |
234 | break; | |
235 | case DT_GUILE_ENTRY: | |
236 | if (entry) | |
237 | return "duplicate DT_GUILE_ENTRY"; | |
238 | entry = base + dyn[i].d_un.d_val; | |
239 | break; | |
240 | case DT_GUILE_RTL_VERSION: | |
241 | if (bytecode_kind != BYTECODE_KIND_NONE) | |
242 | return "duplicate DT_GUILE_RTL_VERSION"; | |
243 | { | |
244 | scm_t_uint16 major = dyn[i].d_un.d_val >> 16; | |
245 | scm_t_uint16 minor = dyn[i].d_un.d_val & 0xffff; | |
246 | if (major != 0x0200) | |
247 | return "incompatible bytecode kind"; | |
248 | if (minor > SCM_OBJCODE_MINOR_VERSION) | |
249 | return "incompatible bytecode version"; | |
250 | bytecode_kind = BYTECODE_KIND_GUILE_2_0; | |
251 | break; | |
252 | } | |
253 | } | |
254 | } | |
255 | ||
256 | if (bytecode_kind != BYTECODE_KIND_GUILE_2_0) | |
257 | return "missing DT_GUILE_RTL_VERSION"; | |
258 | if (init) | |
259 | return "unexpected DT_INIT"; | |
260 | if ((scm_t_uintptr) entry % 8) | |
261 | return "unaligned DT_GUILE_ENTRY"; | |
262 | if (!entry) | |
263 | return "missing DT_GUILE_ENTRY"; | |
264 | ||
265 | if (gc_root) | |
266 | GC_add_roots (gc_root, gc_root + gc_root_size); | |
267 | ||
268 | *init_out = SCM_BOOL_F; | |
269 | *entry_out = pointer_to_procedure (bytecode_kind, entry); | |
270 | return NULL; | |
271 | } | |
272 | ||
273 | #define ABORT(msg) do { err_msg = msg; goto cleanup; } while (0) | |
274 | ||
275 | #ifdef HAVE_SYS_MMAN_H | |
276 | static SCM | |
277 | load_thunk_from_fd_using_mmap (int fd) | |
278 | #define FUNC_NAME "load-thunk-from-disk" | |
279 | { | |
280 | Elf_Ehdr header; | |
281 | Elf_Phdr *ph; | |
282 | const char *err_msg = 0; | |
283 | char *base = 0; | |
284 | size_t n; | |
285 | int i; | |
286 | int start_segment = -1; | |
287 | int prev_segment = -1; | |
288 | int dynamic_segment = -1; | |
289 | SCM init = SCM_BOOL_F, entry = SCM_BOOL_F; | |
290 | ||
291 | if (full_read (fd, &header, sizeof header) != sizeof header) | |
292 | ABORT ("object file too small"); | |
293 | ||
294 | if ((err_msg = check_elf_header (&header))) | |
295 | goto cleanup; | |
296 | ||
297 | if (lseek (fd, header.e_phoff, SEEK_SET) == (off_t) -1) | |
298 | goto cleanup; | |
299 | ||
300 | n = header.e_phnum; | |
301 | ph = scm_gc_malloc_pointerless (n * sizeof (Elf_Phdr), "segment headers"); | |
302 | ||
303 | if (full_read (fd, ph, n * sizeof (Elf_Phdr)) != n * sizeof (Elf_Phdr)) | |
304 | ABORT ("failed to read program headers"); | |
305 | ||
306 | for (i = 0; i < n; i++) | |
307 | { | |
308 | if (!ph[i].p_memsz) | |
309 | continue; | |
310 | ||
311 | if (ph[i].p_filesz != ph[i].p_memsz) | |
312 | ABORT ("expected p_filesz == p_memsz"); | |
313 | ||
314 | if (!ph[i].p_flags) | |
315 | ABORT ("expected nonzero segment flags"); | |
316 | ||
317 | if (ph[i].p_type == PT_DYNAMIC) | |
318 | { | |
319 | if (dynamic_segment >= 0) | |
320 | ABORT ("expected only one PT_DYNAMIC segment"); | |
321 | dynamic_segment = i; | |
322 | } | |
323 | ||
324 | if (start_segment < 0) | |
325 | { | |
326 | if (!base && ph[i].p_vaddr) | |
327 | ABORT ("first loadable vaddr is not 0"); | |
328 | ||
329 | start_segment = prev_segment = i; | |
330 | continue; | |
331 | } | |
332 | ||
333 | if (ph[i].p_flags == ph[start_segment].p_flags) | |
334 | { | |
335 | if (ph[i].p_vaddr - ph[prev_segment].p_vaddr | |
336 | != ph[i].p_offset - ph[prev_segment].p_offset) | |
337 | ABORT ("coalesced segments not contiguous"); | |
338 | ||
339 | prev_segment = i; | |
340 | continue; | |
341 | } | |
342 | ||
343 | /* Otherwise we have a new kind of segment. Map previous | |
344 | segments. */ | |
345 | if (map_segments (fd, &base, &ph[start_segment], &ph[prev_segment])) | |
346 | goto cleanup; | |
347 | ||
348 | /* Open a new set of segments. */ | |
349 | start_segment = prev_segment = i; | |
350 | } | |
351 | ||
352 | /* Map last segments. */ | |
353 | if (start_segment < 0) | |
354 | ABORT ("no loadable segments"); | |
355 | ||
356 | if (map_segments (fd, &base, &ph[start_segment], &ph[prev_segment])) | |
357 | goto cleanup; | |
358 | ||
359 | if (dynamic_segment < 0) | |
360 | ABORT ("no PT_DYNAMIC segment"); | |
361 | ||
362 | if ((err_msg = process_dynamic_segment (base, &ph[dynamic_segment], | |
363 | &init, &entry))) | |
364 | goto cleanup; | |
365 | ||
366 | if (scm_is_true (init)) | |
367 | scm_call_0 (init); | |
368 | ||
369 | /* Finally! Return the thunk. */ | |
370 | return entry; | |
371 | ||
372 | /* FIXME: munmap on error? */ | |
373 | cleanup: | |
374 | { | |
375 | int errno_save = errno; | |
376 | (void) close (fd); | |
377 | errno = errno_save; | |
378 | if (errno) | |
379 | SCM_SYSERROR; | |
380 | scm_misc_error (FUNC_NAME, err_msg ? err_msg : "error loading ELF file", | |
381 | SCM_EOL); | |
382 | } | |
383 | } | |
384 | #undef FUNC_NAME | |
385 | #endif /* HAVE_SYS_MMAN_H */ | |
386 | ||
387 | static SCM | |
388 | load_thunk_from_memory (char *data, size_t len) | |
389 | #define FUNC_NAME "load-thunk-from-memory" | |
390 | { | |
391 | Elf_Ehdr header; | |
392 | Elf_Phdr *ph; | |
393 | const char *err_msg = 0; | |
394 | char *base = 0; | |
395 | size_t n, memsz = 0, alignment = 8; | |
396 | int i; | |
397 | int first_loadable = -1; | |
398 | int start_segment = -1; | |
399 | int prev_segment = -1; | |
400 | int dynamic_segment = -1; | |
401 | SCM init = SCM_BOOL_F, entry = SCM_BOOL_F; | |
402 | ||
403 | if (len < sizeof header) | |
404 | ABORT ("object file too small"); | |
405 | ||
406 | memcpy (&header, data, sizeof header); | |
407 | ||
408 | if ((err_msg = check_elf_header (&header))) | |
409 | goto cleanup; | |
410 | ||
411 | n = header.e_phnum; | |
412 | if (len < header.e_phoff + n * sizeof (Elf_Phdr)) | |
413 | goto cleanup; | |
414 | ph = (Elf_Phdr*) (data + header.e_phoff); | |
415 | ||
416 | for (i = 0; i < n; i++) | |
417 | { | |
418 | if (!ph[i].p_memsz) | |
419 | continue; | |
420 | ||
421 | if (ph[i].p_filesz != ph[i].p_memsz) | |
422 | ABORT ("expected p_filesz == p_memsz"); | |
423 | ||
424 | if (!ph[i].p_flags) | |
425 | ABORT ("expected nonzero segment flags"); | |
426 | ||
427 | if (ph[i].p_align < alignment) | |
428 | { | |
429 | if (ph[i].p_align % alignment) | |
430 | ABORT ("expected new alignment to be multiple of old"); | |
431 | alignment = ph[i].p_align; | |
432 | } | |
433 | ||
434 | if (ph[i].p_type == PT_DYNAMIC) | |
435 | { | |
436 | if (dynamic_segment >= 0) | |
437 | ABORT ("expected only one PT_DYNAMIC segment"); | |
438 | dynamic_segment = i; | |
439 | } | |
440 | ||
441 | if (first_loadable < 0) | |
442 | { | |
443 | if (ph[i].p_vaddr) | |
444 | ABORT ("first loadable vaddr is not 0"); | |
445 | ||
446 | first_loadable = i; | |
447 | } | |
448 | ||
449 | if (ph[i].p_vaddr < memsz) | |
450 | ABORT ("overlapping segments"); | |
451 | ||
452 | if (ph[i].p_offset + ph[i].p_filesz > len) | |
453 | ABORT ("segment beyond end of byte array"); | |
454 | ||
455 | memsz = ph[i].p_vaddr + ph[i].p_memsz; | |
456 | } | |
457 | ||
458 | if (first_loadable < 0) | |
459 | ABORT ("no loadable segments"); | |
460 | ||
461 | if (dynamic_segment < 0) | |
462 | ABORT ("no PT_DYNAMIC segment"); | |
463 | ||
464 | /* Now copy segments. */ | |
465 | ||
466 | /* We leak this memory, as we leak the memory mappings in | |
467 | load_thunk_from_fd_using_mmap. | |
468 | ||
469 | If the file is has an alignment of 8, use the standard malloc. | |
470 | (FIXME to ensure alignment on non-GNU malloc.) Otherwise use | |
471 | posix_memalign. We only use mprotect if the aligment is 4096. */ | |
472 | if (alignment == 8) | |
473 | { | |
474 | base = malloc (memsz); | |
475 | if (!base) | |
476 | goto cleanup; | |
477 | } | |
478 | else | |
479 | if ((errno = posix_memalign ((void **) &base, alignment, memsz))) | |
480 | goto cleanup; | |
481 | ||
482 | memset (base, 0, memsz); | |
483 | ||
484 | for (i = 0; i < n; i++) | |
485 | { | |
486 | if (!ph[i].p_memsz) | |
487 | continue; | |
488 | ||
489 | memcpy (base + ph[i].p_vaddr, | |
490 | data + ph[i].p_offset, | |
491 | ph[i].p_memsz); | |
492 | ||
493 | if (start_segment < 0) | |
494 | { | |
495 | start_segment = prev_segment = i; | |
496 | continue; | |
497 | } | |
498 | ||
499 | if (ph[i].p_flags == ph[start_segment].p_flags) | |
500 | { | |
501 | prev_segment = i; | |
502 | continue; | |
503 | } | |
504 | ||
505 | if (alignment == 4096) | |
506 | if (mprotect_segments (base, &ph[start_segment], &ph[prev_segment])) | |
507 | goto cleanup; | |
508 | ||
509 | /* Open a new set of segments. */ | |
510 | start_segment = prev_segment = i; | |
511 | } | |
512 | ||
513 | /* Mprotect the last segments. */ | |
514 | if (alignment == 4096) | |
515 | if (mprotect_segments (base, &ph[start_segment], &ph[prev_segment])) | |
516 | goto cleanup; | |
517 | ||
518 | if ((err_msg = process_dynamic_segment (base, &ph[dynamic_segment], | |
519 | &init, &entry))) | |
520 | goto cleanup; | |
521 | ||
522 | if (scm_is_true (init)) | |
523 | scm_call_0 (init); | |
524 | ||
525 | /* Finally! Return the thunk. */ | |
526 | return entry; | |
527 | ||
528 | cleanup: | |
529 | { | |
530 | if (errno) | |
531 | SCM_SYSERROR; | |
532 | scm_misc_error (FUNC_NAME, err_msg ? err_msg : "error loading ELF file", | |
533 | SCM_EOL); | |
534 | } | |
535 | } | |
536 | #undef FUNC_NAME | |
537 | ||
538 | #ifndef HAVE_SYS_MMAN_H | |
539 | static SCM | |
540 | load_thunk_from_fd_using_read (int fd) | |
541 | #define FUNC_NAME "load-thunk-from-disk" | |
542 | { | |
543 | char *data; | |
544 | size_t len; | |
545 | struct stat st; | |
546 | int ret; | |
547 | ||
548 | ret = fstat (fd, &st); | |
549 | if (ret < 0) | |
550 | SCM_SYSERROR; | |
551 | len = st.st_size; | |
552 | data = scm_gc_malloc_pointerless (len, "objcode"); | |
553 | if (full_read (fd, data, len) != len) | |
554 | { | |
555 | int errno_save = errno; | |
556 | (void) close (fd); | |
557 | errno = errno_save; | |
558 | if (errno) | |
559 | SCM_SYSERROR; | |
560 | scm_misc_error (FUNC_NAME, "short read while loading objcode", | |
561 | SCM_EOL); | |
562 | } | |
563 | (void) close (fd); | |
564 | return load_thunk_from_memory (data, len); | |
565 | } | |
566 | #undef FUNC_NAME | |
567 | #endif /* ! HAVE_SYS_MMAN_H */ | |
568 | ||
569 | SCM_DEFINE (scm_load_thunk_from_file, "load-thunk-from-file", 1, 0, 0, | |
570 | (SCM filename), | |
571 | "") | |
572 | #define FUNC_NAME s_scm_load_thunk_from_file | |
573 | { | |
574 | char *c_filename; | |
575 | int fd; | |
576 | ||
577 | SCM_VALIDATE_STRING (1, filename); | |
578 | ||
579 | c_filename = scm_to_locale_string (filename); | |
26d14806 | 580 | fd = open (c_filename, O_RDONLY | O_BINARY | O_CLOEXEC); |
afc74c29 AW |
581 | free (c_filename); |
582 | if (fd < 0) SCM_SYSERROR; | |
583 | ||
584 | #ifdef HAVE_SYS_MMAN_H | |
585 | return load_thunk_from_fd_using_mmap (fd); | |
586 | #else | |
587 | return load_thunk_from_fd_using_read (fd); | |
588 | #endif | |
589 | } | |
590 | #undef FUNC_NAME | |
591 | ||
592 | SCM_DEFINE (scm_load_thunk_from_memory, "load-thunk-from-memory", 1, 0, 0, | |
593 | (SCM bv), | |
594 | "") | |
595 | #define FUNC_NAME s_scm_load_thunk_from_memory | |
596 | { | |
597 | SCM_VALIDATE_BYTEVECTOR (1, bv); | |
598 | ||
599 | return load_thunk_from_memory ((char *) SCM_BYTEVECTOR_CONTENTS (bv), | |
600 | SCM_BYTEVECTOR_LENGTH (bv)); | |
601 | } | |
602 | #undef FUNC_NAME | |
603 | ||
604 | \f | |
8f5cfc81 KN |
605 | /* |
606 | * Objcode type | |
607 | */ | |
608 | ||
b8bc86bc | 609 | /* Convert X, which is in byte order BYTE_ORDER, to its native |
de2c0a10 LC |
610 | representation. */ |
611 | static inline uint32_t | |
b8bc86bc | 612 | to_native_order (uint32_t x, int byte_order) |
de2c0a10 | 613 | { |
b8bc86bc | 614 | if (byte_order == SCM_BYTE_ORDER) |
de2c0a10 LC |
615 | return x; |
616 | else | |
617 | return bswap_32 (x); | |
618 | } | |
619 | ||
53e28ed9 | 620 | SCM |
b67cb286 | 621 | scm_c_make_objcode_slice (SCM parent, const scm_t_uint8 *ptr) |
53e28ed9 | 622 | #define FUNC_NAME "make-objcode-slice" |
8f5cfc81 | 623 | { |
b67cb286 | 624 | const struct scm_objcode *data, *parent_data; |
3dbbe28d | 625 | const scm_t_uint8 *parent_base; |
53e28ed9 AW |
626 | |
627 | SCM_VALIDATE_OBJCODE (1, parent); | |
628 | parent_data = SCM_OBJCODE_DATA (parent); | |
3dbbe28d LC |
629 | parent_base = SCM_C_OBJCODE_BASE (parent_data); |
630 | ||
631 | if (ptr < parent_base | |
632 | || ptr >= (parent_base + parent_data->len + parent_data->metalen | |
53e28ed9 | 633 | - sizeof (struct scm_objcode))) |
3d27ef4b AW |
634 | scm_misc_error |
635 | (FUNC_NAME, "offset out of bounds (~a vs ~a + ~a + ~a)", | |
636 | scm_list_4 (scm_from_unsigned_integer ((scm_t_bits) ptr), | |
637 | scm_from_unsigned_integer ((scm_t_bits) parent_base), | |
638 | scm_from_uint32 (parent_data->len), | |
639 | scm_from_uint32 (parent_data->metalen))); | |
53e28ed9 | 640 | |
e3c9c676 LC |
641 | /* Make sure bytecode for the objcode-meta is suitable aligned. Failing to |
642 | do so leads to SIGBUS/SIGSEGV on some arches (e.g., SPARC). */ | |
1119e493 LC |
643 | assert ((((scm_t_bits) ptr) & |
644 | (alignof_type (struct scm_objcode) - 1UL)) == 0); | |
53e28ed9 | 645 | |
3dbbe28d LC |
646 | data = (struct scm_objcode*) ptr; |
647 | assert (SCM_C_OBJCODE_BASE (data) + data->len + data->metalen | |
648 | <= parent_base + parent_data->len + parent_data->metalen); | |
53e28ed9 | 649 | |
f9654187 | 650 | return scm_double_cell (SCM_MAKE_OBJCODE_TAG (SCM_OBJCODE_TYPE_SLICE, 0), |
6f3b0cc2 | 651 | (scm_t_bits)data, SCM_UNPACK (parent), 0); |
8f5cfc81 KN |
652 | } |
653 | #undef FUNC_NAME | |
654 | ||
655 | \f | |
656 | /* | |
657 | * Scheme interface | |
658 | */ | |
659 | ||
660 | SCM_DEFINE (scm_objcode_p, "objcode?", 1, 0, 0, | |
661 | (SCM obj), | |
662 | "") | |
663 | #define FUNC_NAME s_scm_objcode_p | |
664 | { | |
5c8cefe5 | 665 | return scm_from_bool (SCM_OBJCODE_P (obj)); |
8f5cfc81 KN |
666 | } |
667 | #undef FUNC_NAME | |
668 | ||
1f1ec13b AW |
669 | SCM_DEFINE (scm_objcode_meta, "objcode-meta", 1, 0, 0, |
670 | (SCM objcode), | |
671 | "") | |
672 | #define FUNC_NAME s_scm_objcode_meta | |
673 | { | |
674 | SCM_VALIDATE_OBJCODE (1, objcode); | |
675 | ||
676 | if (SCM_OBJCODE_META_LEN (objcode) == 0) | |
677 | return SCM_BOOL_F; | |
678 | else | |
679 | return scm_c_make_objcode_slice (objcode, (SCM_OBJCODE_BASE (objcode) | |
680 | + SCM_OBJCODE_LEN (objcode))); | |
681 | } | |
682 | #undef FUNC_NAME | |
683 | ||
b8bc86bc AW |
684 | /* Wrap BYTECODE in objcode, interpreting its lengths according to |
685 | BYTE_ORDER. */ | |
de2c0a10 | 686 | static SCM |
b8bc86bc | 687 | bytecode_to_objcode (SCM bytecode, int byte_order) |
de2c0a10 | 688 | #define FUNC_NAME "bytecode->objcode" |
8f5cfc81 | 689 | { |
de2c0a10 | 690 | size_t size, len, metalen; |
b6368dbb | 691 | const scm_t_uint8 *c_bytecode; |
53e28ed9 | 692 | struct scm_objcode *data; |
8f5cfc81 | 693 | |
a2689737 | 694 | if (!scm_is_bytevector (bytecode)) |
054599f1 | 695 | scm_wrong_type_arg (FUNC_NAME, 1, bytecode); |
8f5cfc81 | 696 | |
a2689737 AW |
697 | size = SCM_BYTEVECTOR_LENGTH (bytecode); |
698 | c_bytecode = (const scm_t_uint8*)SCM_BYTEVECTOR_CONTENTS (bytecode); | |
de2c0a10 | 699 | |
a2689737 | 700 | SCM_ASSERT_RANGE (0, bytecode, size >= sizeof(struct scm_objcode)); |
53e28ed9 | 701 | data = (struct scm_objcode*)c_bytecode; |
ac47d5f6 | 702 | |
b8bc86bc AW |
703 | len = to_native_order (data->len, byte_order); |
704 | metalen = to_native_order (data->metalen, byte_order); | |
de2c0a10 LC |
705 | |
706 | if (len + metalen != (size - sizeof (*data))) | |
a2689737 | 707 | scm_misc_error (FUNC_NAME, "bad bytevector size (~a != ~a)", |
da8b4747 | 708 | scm_list_2 (scm_from_size_t (size), |
de2c0a10 | 709 | scm_from_uint32 (sizeof (*data) + len + metalen))); |
a2689737 | 710 | |
53e28ed9 AW |
711 | /* foolishly, we assume that as long as bytecode is around, that c_bytecode |
712 | will be of the same length; perhaps a bad assumption? */ | |
f9654187 | 713 | return scm_double_cell (SCM_MAKE_OBJCODE_TAG (SCM_OBJCODE_TYPE_BYTEVECTOR, 0), |
6f3b0cc2 | 714 | (scm_t_bits)data, SCM_UNPACK (bytecode), 0); |
8f5cfc81 KN |
715 | } |
716 | #undef FUNC_NAME | |
717 | ||
b8bc86bc AW |
718 | SCM_DEFINE (scm_bytecode_to_objcode, "bytecode->objcode", 1, 1, 0, |
719 | (SCM bytecode, SCM endianness), | |
de2c0a10 LC |
720 | "") |
721 | #define FUNC_NAME s_scm_bytecode_to_objcode | |
722 | { | |
b8bc86bc AW |
723 | int byte_order; |
724 | ||
725 | if (SCM_UNBNDP (endianness)) | |
726 | byte_order = SCM_BYTE_ORDER; | |
727 | else if (scm_is_eq (endianness, scm_endianness_big)) | |
728 | byte_order = SCM_BYTE_ORDER_BE; | |
729 | else if (scm_is_eq (endianness, scm_endianness_little)) | |
730 | byte_order = SCM_BYTE_ORDER_LE; | |
731 | else | |
732 | scm_wrong_type_arg (FUNC_NAME, 2, endianness); | |
8f5cfc81 | 733 | |
b8bc86bc | 734 | return bytecode_to_objcode (bytecode, byte_order); |
8f5cfc81 KN |
735 | } |
736 | #undef FUNC_NAME | |
737 | ||
b8bc86bc AW |
738 | SCM_DEFINE (scm_objcode_to_bytecode, "objcode->bytecode", 1, 1, 0, |
739 | (SCM objcode, SCM endianness), | |
8f5cfc81 | 740 | "") |
9bb8012d | 741 | #define FUNC_NAME s_scm_objcode_to_bytecode |
8f5cfc81 | 742 | { |
b8bc86bc AW |
743 | scm_t_uint32 len, meta_len, total_len; |
744 | int byte_order; | |
f0b7c3c6 | 745 | |
8f5cfc81 | 746 | SCM_VALIDATE_OBJCODE (1, objcode); |
f0b7c3c6 | 747 | |
b8bc86bc AW |
748 | if (SCM_UNBNDP (endianness)) |
749 | byte_order = SCM_BYTE_ORDER; | |
750 | else if (scm_is_eq (endianness, scm_endianness_big)) | |
751 | byte_order = SCM_BYTE_ORDER_BE; | |
752 | else if (scm_is_eq (endianness, scm_endianness_little)) | |
753 | byte_order = SCM_BYTE_ORDER_LE; | |
754 | else | |
755 | scm_wrong_type_arg (FUNC_NAME, 2, endianness); | |
f0b7c3c6 | 756 | |
b8bc86bc AW |
757 | len = SCM_OBJCODE_LEN (objcode); |
758 | meta_len = SCM_OBJCODE_META_LEN (objcode); | |
de2c0a10 | 759 | |
b8bc86bc AW |
760 | total_len = sizeof (struct scm_objcode); |
761 | total_len += to_native_order (len, byte_order); | |
762 | total_len += to_native_order (meta_len, byte_order); | |
53e28ed9 | 763 | |
b8bc86bc AW |
764 | return scm_c_take_gc_bytevector ((scm_t_int8*)SCM_OBJCODE_DATA (objcode), |
765 | total_len, objcode); | |
8f5cfc81 KN |
766 | } |
767 | #undef FUNC_NAME | |
768 | ||
6f3b0cc2 AW |
769 | void |
770 | scm_i_objcode_print (SCM objcode, SCM port, scm_print_state *pstate) | |
771 | { | |
0607ebbf | 772 | scm_puts_unlocked ("#<objcode ", port); |
6f3b0cc2 | 773 | scm_uintprint ((scm_t_bits)SCM_OBJCODE_BASE (objcode), 16, port); |
0607ebbf | 774 | scm_puts_unlocked (">", port); |
6f3b0cc2 AW |
775 | } |
776 | ||
8f5cfc81 KN |
777 | \f |
778 | void | |
07e56b27 | 779 | scm_bootstrap_objcodes (void) |
8f5cfc81 | 780 | { |
44602b08 AW |
781 | scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION, |
782 | "scm_init_objcodes", | |
60ae5ca2 | 783 | (scm_t_extension_init_func)scm_init_objcodes, NULL); |
07e56b27 AW |
784 | } |
785 | ||
786 | void | |
787 | scm_init_objcodes (void) | |
788 | { | |
8f5cfc81 | 789 | #ifndef SCM_MAGIC_SNARFER |
aeeff258 | 790 | #include "libguile/objcodes.x" |
8f5cfc81 | 791 | #endif |
53e28ed9 AW |
792 | |
793 | scm_c_define ("word-size", scm_from_size_t (sizeof(SCM))); | |
8992a9e3 | 794 | scm_c_define ("byte-order", scm_from_uint16 (SCM_BYTE_ORDER)); |
8f5cfc81 KN |
795 | } |
796 | ||
797 | /* | |
798 | Local Variables: | |
799 | c-file-style: "gnu" | |
800 | End: | |
801 | */ |