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