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 | ||
fb9600de AW |
92 | static void register_elf (char *data, size_t len); |
93 | ||
afc74c29 AW |
94 | enum bytecode_kind |
95 | { | |
96 | BYTECODE_KIND_NONE, | |
97 | BYTECODE_KIND_GUILE_2_0 | |
98 | }; | |
99 | ||
100 | static SCM | |
101 | pointer_to_procedure (enum bytecode_kind bytecode_kind, char *ptr) | |
102 | { | |
103 | switch (bytecode_kind) | |
104 | { | |
105 | case BYTECODE_KIND_GUILE_2_0: | |
106 | { | |
107 | SCM objcode; | |
108 | scm_t_bits tag = SCM_MAKE_OBJCODE_TAG (SCM_OBJCODE_TYPE_MMAP, 0); | |
109 | ||
110 | objcode = scm_double_cell (tag, (scm_t_bits) ptr, SCM_BOOL_F_BITS, 0); | |
111 | return scm_make_program (objcode, SCM_BOOL_F, SCM_UNDEFINED); | |
112 | } | |
113 | case BYTECODE_KIND_NONE: | |
114 | default: | |
115 | abort (); | |
116 | } | |
117 | } | |
118 | ||
119 | static const char* | |
120 | check_elf_header (const Elf_Ehdr *header) | |
121 | { | |
122 | if (!(header->e_ident[EI_MAG0] == ELFMAG0 | |
123 | && header->e_ident[EI_MAG1] == ELFMAG1 | |
124 | && header->e_ident[EI_MAG2] == ELFMAG2 | |
125 | && header->e_ident[EI_MAG3] == ELFMAG3)) | |
126 | return "not an ELF file"; | |
127 | ||
128 | if (header->e_ident[EI_CLASS] != ELFCLASS) | |
129 | return "ELF file does not have native word size"; | |
130 | ||
131 | if (header->e_ident[EI_DATA] != ELFDATA) | |
132 | return "ELF file does not have native byte order"; | |
133 | ||
134 | if (header->e_ident[EI_VERSION] != EV_CURRENT) | |
135 | return "bad ELF version"; | |
136 | ||
137 | if (header->e_ident[EI_OSABI] != ELFOSABI_STANDALONE) | |
138 | return "unexpected OS ABI"; | |
139 | ||
140 | if (header->e_ident[EI_ABIVERSION] != 0) | |
141 | return "unexpected ABI version"; | |
142 | ||
143 | if (header->e_type != ET_DYN) | |
144 | return "unexpected ELF type"; | |
145 | ||
146 | if (header->e_machine != EM_NONE) | |
147 | return "unexpected machine"; | |
148 | ||
149 | if (header->e_version != EV_CURRENT) | |
150 | return "unexpected ELF version"; | |
151 | ||
152 | if (header->e_ehsize != sizeof *header) | |
153 | return "unexpected header size"; | |
154 | ||
155 | if (header->e_phentsize != sizeof (Elf_Phdr)) | |
156 | return "unexpected program header size"; | |
157 | ||
158 | return NULL; | |
159 | } | |
160 | ||
e1aee492 AW |
161 | #define IS_ALIGNED(offset, alignment) \ |
162 | (!((offset) & ((alignment) - 1))) | |
163 | #define ALIGN(offset, alignment) \ | |
164 | ((offset + (alignment - 1)) & ~(alignment - 1)) | |
165 | ||
166 | /* Return the alignment required by the ELF at DATA, of LEN bytes. */ | |
167 | static size_t | |
168 | elf_alignment (const char *data, size_t len) | |
afc74c29 | 169 | { |
e1aee492 AW |
170 | Elf_Ehdr *header; |
171 | int i; | |
172 | size_t alignment = 8; | |
173 | ||
174 | if (len < sizeof(Elf_Ehdr)) | |
175 | return alignment; | |
176 | header = (Elf_Ehdr *) data; | |
177 | if (header->e_phoff + header->e_phnum * header->e_phentsize >= len) | |
178 | return alignment; | |
179 | for (i = 0; i < header->e_phnum; i++) | |
180 | { | |
181 | Elf_Phdr *phdr; | |
182 | const char *phdr_addr = data + header->e_phoff + i * header->e_phentsize; | |
afc74c29 | 183 | |
e1aee492 AW |
184 | if (!IS_ALIGNED ((scm_t_uintptr) phdr_addr, alignof_type (Elf_Phdr))) |
185 | return alignment; | |
186 | phdr = (Elf_Phdr *) phdr_addr; | |
187 | ||
188 | if (phdr->p_align & (phdr->p_align - 1)) | |
189 | return alignment; | |
190 | ||
191 | if (phdr->p_align > alignment) | |
192 | alignment = phdr->p_align; | |
193 | } | |
194 | ||
195 | return alignment; | |
afc74c29 AW |
196 | } |
197 | ||
e1aee492 AW |
198 | /* This function leaks the memory that it allocates. */ |
199 | static char* | |
200 | alloc_aligned (size_t len, unsigned alignment) | |
afc74c29 | 201 | { |
afc74c29 AW |
202 | char *ret; |
203 | ||
e1aee492 AW |
204 | if (alignment == 8) |
205 | { | |
206 | /* FIXME: Assert that we actually have an 8-byte-aligned malloc. */ | |
207 | ret = malloc (len); | |
208 | } | |
209 | #if defined(HAVE_SYS_MMAN_H) && defined(MMAP_ANONYMOUS) | |
210 | else if (alignment == SCM_PAGE_SIZE) | |
211 | { | |
212 | ret = mmap (NULL, len, PROT_READ | PROT_WRITE, -1, 0); | |
213 | if (ret == MAP_FAILED) | |
214 | SCM_SYSERROR; | |
215 | } | |
216 | #endif | |
217 | else | |
218 | { | |
219 | if (len + alignment < len) | |
220 | abort (); | |
221 | ||
222 | ret = malloc (len + alignment - 1); | |
223 | if (!ret) | |
224 | abort (); | |
225 | ret = (char *) ALIGN ((scm_t_uintptr) ret, alignment); | |
226 | } | |
227 | ||
228 | return ret; | |
229 | } | |
afc74c29 | 230 | |
e1aee492 AW |
231 | static char* |
232 | copy_and_align_elf_data (const char *data, size_t len) | |
233 | { | |
234 | size_t alignment; | |
235 | char *copy; | |
afc74c29 | 236 | |
e1aee492 AW |
237 | alignment = elf_alignment (data, len); |
238 | copy = alloc_aligned (len, alignment); | |
239 | memcpy(copy, data, len); | |
afc74c29 | 240 | |
e1aee492 | 241 | return copy; |
afc74c29 AW |
242 | } |
243 | ||
e1aee492 | 244 | #ifdef HAVE_SYS_MMAN_H |
afc74c29 | 245 | static int |
e1aee492 | 246 | segment_flags_to_prot (Elf_Word flags) |
afc74c29 | 247 | { |
e1aee492 AW |
248 | int prot = 0; |
249 | ||
250 | if (flags & PF_X) | |
251 | prot |= PROT_EXEC; | |
252 | if (flags & PF_W) | |
253 | prot |= PROT_WRITE; | |
254 | if (flags & PF_R) | |
255 | prot |= PROT_READ; | |
256 | ||
257 | return prot; | |
afc74c29 | 258 | } |
e1aee492 | 259 | #endif |
afc74c29 AW |
260 | |
261 | static char* | |
262 | process_dynamic_segment (char *base, Elf_Phdr *dyn_phdr, | |
263 | SCM *init_out, SCM *entry_out) | |
264 | { | |
265 | char *dyn_addr = base + dyn_phdr->p_vaddr; | |
266 | Elf_Dyn *dyn = (Elf_Dyn *) dyn_addr; | |
267 | size_t i, dyn_size = dyn_phdr->p_memsz / sizeof (Elf_Dyn); | |
268 | char *init = 0, *gc_root = 0, *entry = 0; | |
269 | scm_t_ptrdiff gc_root_size = 0; | |
270 | enum bytecode_kind bytecode_kind = BYTECODE_KIND_NONE; | |
271 | ||
272 | for (i = 0; i < dyn_size; i++) | |
273 | { | |
274 | if (dyn[i].d_tag == DT_NULL) | |
275 | break; | |
276 | ||
277 | switch (dyn[i].d_tag) | |
278 | { | |
279 | case DT_INIT: | |
280 | if (init) | |
281 | return "duplicate DT_INIT"; | |
282 | init = base + dyn[i].d_un.d_val; | |
283 | break; | |
284 | case DT_GUILE_GC_ROOT: | |
285 | if (gc_root) | |
286 | return "duplicate DT_GUILE_GC_ROOT"; | |
287 | gc_root = base + dyn[i].d_un.d_val; | |
288 | break; | |
289 | case DT_GUILE_GC_ROOT_SZ: | |
290 | if (gc_root_size) | |
291 | return "duplicate DT_GUILE_GC_ROOT_SZ"; | |
292 | gc_root_size = dyn[i].d_un.d_val; | |
293 | break; | |
294 | case DT_GUILE_ENTRY: | |
295 | if (entry) | |
296 | return "duplicate DT_GUILE_ENTRY"; | |
297 | entry = base + dyn[i].d_un.d_val; | |
298 | break; | |
299 | case DT_GUILE_RTL_VERSION: | |
300 | if (bytecode_kind != BYTECODE_KIND_NONE) | |
301 | return "duplicate DT_GUILE_RTL_VERSION"; | |
302 | { | |
303 | scm_t_uint16 major = dyn[i].d_un.d_val >> 16; | |
304 | scm_t_uint16 minor = dyn[i].d_un.d_val & 0xffff; | |
305 | if (major != 0x0200) | |
306 | return "incompatible bytecode kind"; | |
307 | if (minor > SCM_OBJCODE_MINOR_VERSION) | |
308 | return "incompatible bytecode version"; | |
309 | bytecode_kind = BYTECODE_KIND_GUILE_2_0; | |
310 | break; | |
311 | } | |
312 | } | |
313 | } | |
314 | ||
315 | if (bytecode_kind != BYTECODE_KIND_GUILE_2_0) | |
316 | return "missing DT_GUILE_RTL_VERSION"; | |
317 | if (init) | |
318 | return "unexpected DT_INIT"; | |
319 | if ((scm_t_uintptr) entry % 8) | |
320 | return "unaligned DT_GUILE_ENTRY"; | |
321 | if (!entry) | |
322 | return "missing DT_GUILE_ENTRY"; | |
323 | ||
324 | if (gc_root) | |
325 | GC_add_roots (gc_root, gc_root + gc_root_size); | |
326 | ||
327 | *init_out = SCM_BOOL_F; | |
328 | *entry_out = pointer_to_procedure (bytecode_kind, entry); | |
329 | return NULL; | |
330 | } | |
331 | ||
332 | #define ABORT(msg) do { err_msg = msg; goto cleanup; } while (0) | |
333 | ||
afc74c29 | 334 | static SCM |
e1aee492 AW |
335 | load_thunk_from_memory (char *data, size_t len, int is_read_only) |
336 | #define FUNC_NAME "load-thunk-from-memory" | |
afc74c29 | 337 | { |
e1aee492 | 338 | Elf_Ehdr *header; |
afc74c29 AW |
339 | Elf_Phdr *ph; |
340 | const char *err_msg = 0; | |
e1aee492 | 341 | size_t n, alignment = 8; |
afc74c29 | 342 | int i; |
afc74c29 AW |
343 | int dynamic_segment = -1; |
344 | SCM init = SCM_BOOL_F, entry = SCM_BOOL_F; | |
345 | ||
e1aee492 | 346 | if (len < sizeof *header) |
afc74c29 AW |
347 | ABORT ("object file too small"); |
348 | ||
e1aee492 | 349 | header = (Elf_Ehdr*) data; |
afc74c29 | 350 | |
e1aee492 | 351 | if ((err_msg = check_elf_header (header))) |
afc74c29 AW |
352 | goto cleanup; |
353 | ||
e1aee492 AW |
354 | if (header->e_phnum == 0) |
355 | ABORT ("no loadable segments"); | |
356 | n = header->e_phnum; | |
afc74c29 | 357 | |
e1aee492 | 358 | if (len < header->e_phoff + n * sizeof (Elf_Phdr)) |
afc74c29 AW |
359 | ABORT ("object file too small"); |
360 | ||
e1aee492 | 361 | ph = (Elf_Phdr*) (data + header->e_phoff); |
afc74c29 | 362 | |
e1aee492 | 363 | /* Check that the segment table is sane. */ |
afc74c29 AW |
364 | for (i = 0; i < n; i++) |
365 | { | |
afc74c29 AW |
366 | if (ph[i].p_filesz != ph[i].p_memsz) |
367 | ABORT ("expected p_filesz == p_memsz"); | |
368 | ||
369 | if (!ph[i].p_flags) | |
370 | ABORT ("expected nonzero segment flags"); | |
371 | ||
372 | if (ph[i].p_align < alignment) | |
373 | { | |
374 | if (ph[i].p_align % alignment) | |
375 | ABORT ("expected new alignment to be multiple of old"); | |
376 | alignment = ph[i].p_align; | |
377 | } | |
378 | ||
379 | if (ph[i].p_type == PT_DYNAMIC) | |
380 | { | |
381 | if (dynamic_segment >= 0) | |
382 | ABORT ("expected only one PT_DYNAMIC segment"); | |
383 | dynamic_segment = i; | |
384 | } | |
385 | ||
e1aee492 | 386 | if (i == 0) |
afc74c29 | 387 | { |
e1aee492 | 388 | if (ph[i].p_vaddr != 0) |
afc74c29 | 389 | ABORT ("first loadable vaddr is not 0"); |
afc74c29 | 390 | } |
e1aee492 AW |
391 | else |
392 | { | |
393 | if (ph[i].p_vaddr < ph[i-1].p_vaddr + ph[i-1].p_memsz) | |
394 | ABORT ("overlapping segments"); | |
afc74c29 | 395 | |
e1aee492 AW |
396 | if (ph[i].p_offset + ph[i].p_filesz > len) |
397 | ABORT ("segment beyond end of byte array"); | |
398 | } | |
afc74c29 AW |
399 | } |
400 | ||
afc74c29 AW |
401 | if (dynamic_segment < 0) |
402 | ABORT ("no PT_DYNAMIC segment"); | |
403 | ||
e1aee492 AW |
404 | if (!IS_ALIGNED ((scm_t_uintptr) data, alignment)) |
405 | ABORT ("incorrectly aligned base"); | |
afc74c29 | 406 | |
e1aee492 AW |
407 | /* Allow writes to writable pages. */ |
408 | if (is_read_only) | |
afc74c29 | 409 | { |
e1aee492 AW |
410 | #ifdef HAVE_SYS_MMAN_H |
411 | for (i = 0; i < n; i++) | |
afc74c29 | 412 | { |
e1aee492 AW |
413 | if (ph[i].p_flags == PF_R) |
414 | continue; | |
415 | if (ph[i].p_align != 4096) | |
416 | continue; | |
417 | ||
418 | if (mprotect (data + ph[i].p_vaddr, | |
419 | ph[i].p_memsz, | |
420 | segment_flags_to_prot (ph[i].p_flags))) | |
421 | goto cleanup; | |
afc74c29 | 422 | } |
e1aee492 AW |
423 | #else |
424 | ABORT ("expected writable pages"); | |
425 | #endif | |
afc74c29 AW |
426 | } |
427 | ||
e1aee492 | 428 | if ((err_msg = process_dynamic_segment (data, &ph[dynamic_segment], |
afc74c29 AW |
429 | &init, &entry))) |
430 | goto cleanup; | |
431 | ||
432 | if (scm_is_true (init)) | |
433 | scm_call_0 (init); | |
434 | ||
fb9600de AW |
435 | register_elf (data, len); |
436 | ||
afc74c29 AW |
437 | /* Finally! Return the thunk. */ |
438 | return entry; | |
439 | ||
440 | cleanup: | |
441 | { | |
442 | if (errno) | |
443 | SCM_SYSERROR; | |
444 | scm_misc_error (FUNC_NAME, err_msg ? err_msg : "error loading ELF file", | |
445 | SCM_EOL); | |
446 | } | |
447 | } | |
448 | #undef FUNC_NAME | |
449 | ||
e1aee492 AW |
450 | #define SCM_PAGE_SIZE 4096 |
451 | ||
452 | static char* | |
453 | map_file_contents (int fd, size_t len, int *is_read_only) | |
454 | #define FUNC_NAME "load-thunk-from-file" | |
afc74c29 AW |
455 | { |
456 | char *data; | |
afc74c29 | 457 | |
e1aee492 AW |
458 | #ifdef HAVE_SYS_MMAN_H |
459 | data = mmap (NULL, len, PROT_READ, MAP_PRIVATE, fd, 0); | |
460 | if (data == MAP_FAILED) | |
afc74c29 | 461 | SCM_SYSERROR; |
e1aee492 AW |
462 | *is_read_only = 1; |
463 | #else | |
464 | if (lseek (fd, 0, SEEK_START) < 0) | |
465 | { | |
466 | int errno_save = errno; | |
467 | (void) close (fd); | |
468 | errno = errno_save; | |
469 | SCM_SYSERROR; | |
470 | } | |
471 | ||
472 | /* Given that we are using the read fallback, optimistically assume | |
473 | that the .go files were made with 8-byte alignment. | |
474 | alignment. */ | |
475 | data = malloc (end); | |
476 | if (!data) | |
477 | { | |
478 | (void) close (fd); | |
479 | scm_misc_error (FUNC_NAME, "failed to allocate ~A bytes", | |
480 | scm_list_1 (scm_from_size_t (end))); | |
481 | } | |
482 | ||
483 | if (full_read (fd, data, end) != end) | |
afc74c29 AW |
484 | { |
485 | int errno_save = errno; | |
486 | (void) close (fd); | |
487 | errno = errno_save; | |
488 | if (errno) | |
489 | SCM_SYSERROR; | |
490 | scm_misc_error (FUNC_NAME, "short read while loading objcode", | |
491 | SCM_EOL); | |
492 | } | |
e1aee492 AW |
493 | |
494 | /* If our optimism failed, fall back. */ | |
495 | { | |
496 | unsigned alignment = sniff_elf_alignment (data, end); | |
497 | ||
498 | if (alignment != 8) | |
499 | { | |
500 | char *copy = copy_and_align_elf_data (data, end, alignment); | |
501 | free (data); | |
502 | data = copy; | |
503 | } | |
504 | } | |
505 | ||
506 | *is_read_only = 0; | |
507 | #endif | |
508 | ||
509 | return data; | |
afc74c29 AW |
510 | } |
511 | #undef FUNC_NAME | |
afc74c29 AW |
512 | |
513 | SCM_DEFINE (scm_load_thunk_from_file, "load-thunk-from-file", 1, 0, 0, | |
514 | (SCM filename), | |
515 | "") | |
516 | #define FUNC_NAME s_scm_load_thunk_from_file | |
517 | { | |
518 | char *c_filename; | |
e1aee492 AW |
519 | int fd, is_read_only; |
520 | off_t end; | |
521 | char *data; | |
afc74c29 AW |
522 | |
523 | SCM_VALIDATE_STRING (1, filename); | |
524 | ||
525 | c_filename = scm_to_locale_string (filename); | |
26d14806 | 526 | fd = open (c_filename, O_RDONLY | O_BINARY | O_CLOEXEC); |
afc74c29 AW |
527 | free (c_filename); |
528 | if (fd < 0) SCM_SYSERROR; | |
529 | ||
e1aee492 AW |
530 | end = lseek (fd, 0, SEEK_END); |
531 | if (end < 0) | |
532 | SCM_SYSERROR; | |
533 | ||
534 | data = map_file_contents (fd, end, &is_read_only); | |
535 | ||
536 | (void) close (fd); | |
537 | ||
538 | return load_thunk_from_memory (data, end, is_read_only); | |
afc74c29 AW |
539 | } |
540 | #undef FUNC_NAME | |
541 | ||
542 | SCM_DEFINE (scm_load_thunk_from_memory, "load-thunk-from-memory", 1, 0, 0, | |
543 | (SCM bv), | |
544 | "") | |
545 | #define FUNC_NAME s_scm_load_thunk_from_memory | |
546 | { | |
e1aee492 AW |
547 | char *data; |
548 | size_t len; | |
549 | ||
afc74c29 AW |
550 | SCM_VALIDATE_BYTEVECTOR (1, bv); |
551 | ||
e1aee492 AW |
552 | data = (char *) SCM_BYTEVECTOR_CONTENTS (bv); |
553 | len = SCM_BYTEVECTOR_LENGTH (bv); | |
554 | ||
555 | /* Copy data in order to align it, to trace its GC roots and | |
556 | writable sections, and to keep it in memory. */ | |
557 | ||
558 | data = copy_and_align_elf_data (data, len); | |
559 | ||
560 | return load_thunk_from_memory (data, len, 0); | |
afc74c29 AW |
561 | } |
562 | #undef FUNC_NAME | |
563 | ||
564 | \f | |
8f5cfc81 KN |
565 | /* |
566 | * Objcode type | |
567 | */ | |
568 | ||
b8bc86bc | 569 | /* Convert X, which is in byte order BYTE_ORDER, to its native |
de2c0a10 LC |
570 | representation. */ |
571 | static inline uint32_t | |
b8bc86bc | 572 | to_native_order (uint32_t x, int byte_order) |
de2c0a10 | 573 | { |
b8bc86bc | 574 | if (byte_order == SCM_BYTE_ORDER) |
de2c0a10 LC |
575 | return x; |
576 | else | |
577 | return bswap_32 (x); | |
578 | } | |
579 | ||
53e28ed9 | 580 | SCM |
b67cb286 | 581 | scm_c_make_objcode_slice (SCM parent, const scm_t_uint8 *ptr) |
53e28ed9 | 582 | #define FUNC_NAME "make-objcode-slice" |
8f5cfc81 | 583 | { |
b67cb286 | 584 | const struct scm_objcode *data, *parent_data; |
3dbbe28d | 585 | const scm_t_uint8 *parent_base; |
53e28ed9 AW |
586 | |
587 | SCM_VALIDATE_OBJCODE (1, parent); | |
588 | parent_data = SCM_OBJCODE_DATA (parent); | |
3dbbe28d LC |
589 | parent_base = SCM_C_OBJCODE_BASE (parent_data); |
590 | ||
591 | if (ptr < parent_base | |
592 | || ptr >= (parent_base + parent_data->len + parent_data->metalen | |
53e28ed9 | 593 | - sizeof (struct scm_objcode))) |
3d27ef4b AW |
594 | scm_misc_error |
595 | (FUNC_NAME, "offset out of bounds (~a vs ~a + ~a + ~a)", | |
596 | scm_list_4 (scm_from_unsigned_integer ((scm_t_bits) ptr), | |
597 | scm_from_unsigned_integer ((scm_t_bits) parent_base), | |
598 | scm_from_uint32 (parent_data->len), | |
599 | scm_from_uint32 (parent_data->metalen))); | |
53e28ed9 | 600 | |
e3c9c676 LC |
601 | /* Make sure bytecode for the objcode-meta is suitable aligned. Failing to |
602 | do so leads to SIGBUS/SIGSEGV on some arches (e.g., SPARC). */ | |
1119e493 LC |
603 | assert ((((scm_t_bits) ptr) & |
604 | (alignof_type (struct scm_objcode) - 1UL)) == 0); | |
53e28ed9 | 605 | |
3dbbe28d LC |
606 | data = (struct scm_objcode*) ptr; |
607 | assert (SCM_C_OBJCODE_BASE (data) + data->len + data->metalen | |
608 | <= parent_base + parent_data->len + parent_data->metalen); | |
53e28ed9 | 609 | |
f9654187 | 610 | return scm_double_cell (SCM_MAKE_OBJCODE_TAG (SCM_OBJCODE_TYPE_SLICE, 0), |
6f3b0cc2 | 611 | (scm_t_bits)data, SCM_UNPACK (parent), 0); |
8f5cfc81 KN |
612 | } |
613 | #undef FUNC_NAME | |
614 | ||
fb9600de AW |
615 | struct mapped_elf_image |
616 | { | |
617 | char *start; | |
618 | char *end; | |
619 | }; | |
620 | ||
621 | static struct mapped_elf_image *mapped_elf_images = NULL; | |
622 | static size_t mapped_elf_images_count = 0; | |
623 | static size_t mapped_elf_images_allocated = 0; | |
624 | ||
625 | static size_t | |
626 | find_mapped_elf_insertion_index (char *ptr) | |
627 | { | |
628 | /* "mapped_elf_images_count" must never be dereferenced. */ | |
629 | size_t start = 0, end = mapped_elf_images_count; | |
630 | ||
631 | while (start < end) | |
632 | { | |
633 | size_t n = start + (end - start) / 2; | |
634 | ||
635 | if (ptr < mapped_elf_images[n].end) | |
636 | end = n; | |
637 | else | |
638 | start = n + 1; | |
639 | } | |
640 | ||
641 | return start; | |
642 | } | |
643 | ||
644 | static void | |
645 | register_elf (char *data, size_t len) | |
646 | { | |
647 | scm_i_pthread_mutex_lock (&scm_i_misc_mutex); | |
648 | { | |
649 | /* My kingdom for a generic growable sorted vector library. */ | |
650 | if (mapped_elf_images_count == mapped_elf_images_allocated) | |
651 | { | |
652 | struct mapped_elf_image *prev; | |
653 | size_t n; | |
654 | ||
655 | if (mapped_elf_images_allocated) | |
656 | mapped_elf_images_allocated *= 2; | |
657 | else | |
658 | mapped_elf_images_allocated = 16; | |
659 | ||
660 | prev = mapped_elf_images; | |
661 | mapped_elf_images = | |
662 | scm_gc_malloc_pointerless (sizeof (*mapped_elf_images) | |
663 | * mapped_elf_images_allocated, | |
664 | "mapped elf images"); | |
665 | ||
666 | for (n = 0; n < mapped_elf_images_count; n++) | |
667 | { | |
668 | mapped_elf_images[n].start = prev[n].start; | |
669 | mapped_elf_images[n].end = prev[n].end; | |
670 | } | |
671 | } | |
672 | ||
673 | { | |
674 | size_t end; | |
675 | size_t n = find_mapped_elf_insertion_index (data); | |
676 | ||
677 | for (end = mapped_elf_images_count; n < end; end--) | |
678 | { | |
679 | mapped_elf_images[end].start = mapped_elf_images[end - 1].start; | |
680 | mapped_elf_images[end].end = mapped_elf_images[end - 1].end; | |
681 | } | |
682 | mapped_elf_images_count++; | |
683 | ||
684 | mapped_elf_images[n].start = data; | |
685 | mapped_elf_images[n].end = data + len; | |
686 | } | |
687 | } | |
688 | scm_i_pthread_mutex_unlock (&scm_i_misc_mutex); | |
689 | } | |
690 | ||
691 | static SCM | |
692 | scm_find_mapped_elf_image (SCM ip) | |
693 | { | |
694 | char *ptr = (char *) scm_to_uintptr_t (ip); | |
695 | SCM result; | |
696 | ||
697 | scm_i_pthread_mutex_lock (&scm_i_misc_mutex); | |
698 | { | |
699 | size_t n = find_mapped_elf_insertion_index ((char *) ptr); | |
700 | if (n < mapped_elf_images_count | |
701 | && mapped_elf_images[n].start <= ptr | |
702 | && ptr < mapped_elf_images[n].end) | |
703 | { | |
704 | signed char *data = (signed char *) mapped_elf_images[n].start; | |
705 | size_t len = mapped_elf_images[n].end - mapped_elf_images[n].start; | |
706 | result = scm_c_take_gc_bytevector (data, len, SCM_BOOL_F); | |
707 | } | |
708 | else | |
709 | result = SCM_BOOL_F; | |
710 | } | |
711 | scm_i_pthread_mutex_unlock (&scm_i_misc_mutex); | |
712 | ||
713 | return result; | |
714 | } | |
715 | ||
8f5cfc81 KN |
716 | \f |
717 | /* | |
718 | * Scheme interface | |
719 | */ | |
720 | ||
721 | SCM_DEFINE (scm_objcode_p, "objcode?", 1, 0, 0, | |
722 | (SCM obj), | |
723 | "") | |
724 | #define FUNC_NAME s_scm_objcode_p | |
725 | { | |
5c8cefe5 | 726 | return scm_from_bool (SCM_OBJCODE_P (obj)); |
8f5cfc81 KN |
727 | } |
728 | #undef FUNC_NAME | |
729 | ||
1f1ec13b AW |
730 | SCM_DEFINE (scm_objcode_meta, "objcode-meta", 1, 0, 0, |
731 | (SCM objcode), | |
732 | "") | |
733 | #define FUNC_NAME s_scm_objcode_meta | |
734 | { | |
735 | SCM_VALIDATE_OBJCODE (1, objcode); | |
736 | ||
737 | if (SCM_OBJCODE_META_LEN (objcode) == 0) | |
738 | return SCM_BOOL_F; | |
739 | else | |
740 | return scm_c_make_objcode_slice (objcode, (SCM_OBJCODE_BASE (objcode) | |
741 | + SCM_OBJCODE_LEN (objcode))); | |
742 | } | |
743 | #undef FUNC_NAME | |
744 | ||
b8bc86bc AW |
745 | /* Wrap BYTECODE in objcode, interpreting its lengths according to |
746 | BYTE_ORDER. */ | |
de2c0a10 | 747 | static SCM |
b8bc86bc | 748 | bytecode_to_objcode (SCM bytecode, int byte_order) |
de2c0a10 | 749 | #define FUNC_NAME "bytecode->objcode" |
8f5cfc81 | 750 | { |
de2c0a10 | 751 | size_t size, len, metalen; |
b6368dbb | 752 | const scm_t_uint8 *c_bytecode; |
53e28ed9 | 753 | struct scm_objcode *data; |
8f5cfc81 | 754 | |
a2689737 | 755 | if (!scm_is_bytevector (bytecode)) |
054599f1 | 756 | scm_wrong_type_arg (FUNC_NAME, 1, bytecode); |
8f5cfc81 | 757 | |
a2689737 AW |
758 | size = SCM_BYTEVECTOR_LENGTH (bytecode); |
759 | c_bytecode = (const scm_t_uint8*)SCM_BYTEVECTOR_CONTENTS (bytecode); | |
de2c0a10 | 760 | |
a2689737 | 761 | SCM_ASSERT_RANGE (0, bytecode, size >= sizeof(struct scm_objcode)); |
53e28ed9 | 762 | data = (struct scm_objcode*)c_bytecode; |
ac47d5f6 | 763 | |
b8bc86bc AW |
764 | len = to_native_order (data->len, byte_order); |
765 | metalen = to_native_order (data->metalen, byte_order); | |
de2c0a10 LC |
766 | |
767 | if (len + metalen != (size - sizeof (*data))) | |
a2689737 | 768 | scm_misc_error (FUNC_NAME, "bad bytevector size (~a != ~a)", |
da8b4747 | 769 | scm_list_2 (scm_from_size_t (size), |
de2c0a10 | 770 | scm_from_uint32 (sizeof (*data) + len + metalen))); |
a2689737 | 771 | |
53e28ed9 AW |
772 | /* foolishly, we assume that as long as bytecode is around, that c_bytecode |
773 | will be of the same length; perhaps a bad assumption? */ | |
f9654187 | 774 | return scm_double_cell (SCM_MAKE_OBJCODE_TAG (SCM_OBJCODE_TYPE_BYTEVECTOR, 0), |
6f3b0cc2 | 775 | (scm_t_bits)data, SCM_UNPACK (bytecode), 0); |
8f5cfc81 KN |
776 | } |
777 | #undef FUNC_NAME | |
778 | ||
b8bc86bc AW |
779 | SCM_DEFINE (scm_bytecode_to_objcode, "bytecode->objcode", 1, 1, 0, |
780 | (SCM bytecode, SCM endianness), | |
de2c0a10 LC |
781 | "") |
782 | #define FUNC_NAME s_scm_bytecode_to_objcode | |
783 | { | |
b8bc86bc AW |
784 | int byte_order; |
785 | ||
786 | if (SCM_UNBNDP (endianness)) | |
787 | byte_order = SCM_BYTE_ORDER; | |
788 | else if (scm_is_eq (endianness, scm_endianness_big)) | |
789 | byte_order = SCM_BYTE_ORDER_BE; | |
790 | else if (scm_is_eq (endianness, scm_endianness_little)) | |
791 | byte_order = SCM_BYTE_ORDER_LE; | |
792 | else | |
793 | scm_wrong_type_arg (FUNC_NAME, 2, endianness); | |
8f5cfc81 | 794 | |
b8bc86bc | 795 | return bytecode_to_objcode (bytecode, byte_order); |
8f5cfc81 KN |
796 | } |
797 | #undef FUNC_NAME | |
798 | ||
b8bc86bc AW |
799 | SCM_DEFINE (scm_objcode_to_bytecode, "objcode->bytecode", 1, 1, 0, |
800 | (SCM objcode, SCM endianness), | |
8f5cfc81 | 801 | "") |
9bb8012d | 802 | #define FUNC_NAME s_scm_objcode_to_bytecode |
8f5cfc81 | 803 | { |
b8bc86bc AW |
804 | scm_t_uint32 len, meta_len, total_len; |
805 | int byte_order; | |
f0b7c3c6 | 806 | |
8f5cfc81 | 807 | SCM_VALIDATE_OBJCODE (1, objcode); |
f0b7c3c6 | 808 | |
b8bc86bc AW |
809 | if (SCM_UNBNDP (endianness)) |
810 | byte_order = SCM_BYTE_ORDER; | |
811 | else if (scm_is_eq (endianness, scm_endianness_big)) | |
812 | byte_order = SCM_BYTE_ORDER_BE; | |
813 | else if (scm_is_eq (endianness, scm_endianness_little)) | |
814 | byte_order = SCM_BYTE_ORDER_LE; | |
815 | else | |
816 | scm_wrong_type_arg (FUNC_NAME, 2, endianness); | |
f0b7c3c6 | 817 | |
b8bc86bc AW |
818 | len = SCM_OBJCODE_LEN (objcode); |
819 | meta_len = SCM_OBJCODE_META_LEN (objcode); | |
de2c0a10 | 820 | |
b8bc86bc AW |
821 | total_len = sizeof (struct scm_objcode); |
822 | total_len += to_native_order (len, byte_order); | |
823 | total_len += to_native_order (meta_len, byte_order); | |
53e28ed9 | 824 | |
b8bc86bc AW |
825 | return scm_c_take_gc_bytevector ((scm_t_int8*)SCM_OBJCODE_DATA (objcode), |
826 | total_len, objcode); | |
8f5cfc81 KN |
827 | } |
828 | #undef FUNC_NAME | |
829 | ||
6f3b0cc2 AW |
830 | void |
831 | scm_i_objcode_print (SCM objcode, SCM port, scm_print_state *pstate) | |
832 | { | |
0607ebbf | 833 | scm_puts_unlocked ("#<objcode ", port); |
6f3b0cc2 | 834 | scm_uintprint ((scm_t_bits)SCM_OBJCODE_BASE (objcode), 16, port); |
0607ebbf | 835 | scm_puts_unlocked (">", port); |
6f3b0cc2 AW |
836 | } |
837 | ||
8f5cfc81 KN |
838 | \f |
839 | void | |
07e56b27 | 840 | scm_bootstrap_objcodes (void) |
8f5cfc81 | 841 | { |
44602b08 AW |
842 | scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION, |
843 | "scm_init_objcodes", | |
60ae5ca2 | 844 | (scm_t_extension_init_func)scm_init_objcodes, NULL); |
07e56b27 AW |
845 | } |
846 | ||
847 | void | |
848 | scm_init_objcodes (void) | |
849 | { | |
8f5cfc81 | 850 | #ifndef SCM_MAGIC_SNARFER |
aeeff258 | 851 | #include "libguile/objcodes.x" |
8f5cfc81 | 852 | #endif |
53e28ed9 | 853 | |
fb9600de AW |
854 | scm_c_define_gsubr ("find-mapped-elf-image", 1, 0, 0, |
855 | (scm_t_subr) scm_find_mapped_elf_image); | |
856 | ||
53e28ed9 | 857 | scm_c_define ("word-size", scm_from_size_t (sizeof(SCM))); |
8992a9e3 | 858 | scm_c_define ("byte-order", scm_from_uint16 (SCM_BYTE_ORDER)); |
8f5cfc81 KN |
859 | } |
860 | ||
861 | /* | |
862 | Local Variables: | |
863 | c-file-style: "gnu" | |
864 | End: | |
865 | */ |