1 /* Copyright (C) 2001, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
3 * This library is free software; you can redistribute it and/or
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.
8 * This library is distributed in the hope that it will be useful, but
9 * WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
11 * Lesser General Public License for more details.
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
15 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
27 #ifdef HAVE_SYS_MMAN_H
32 #include <sys/types.h>
37 #include <full-read.h>
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
49 /* Byte order of the build machine. */
50 #ifdef WORDS_BIGENDIAN
51 #define SCM_BYTE_ORDER SCM_BYTE_ORDER_BE
53 #define SCM_BYTE_ORDER SCM_BYTE_ORDER_LE
56 /* This file contains the loader for Guile's on-disk format: ELF with
57 some custom tags in the dynamic segment. */
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
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
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 */
85 #ifdef WORDS_BIGENDIAN
86 #define ELFDATA ELFDATA2MSB
88 #define ELFDATA ELFDATA2LSB
94 BYTECODE_KIND_GUILE_2_0
98 pointer_to_procedure (enum bytecode_kind bytecode_kind
, char *ptr
)
100 switch (bytecode_kind
)
102 case BYTECODE_KIND_GUILE_2_0
:
105 scm_t_bits tag
= SCM_MAKE_OBJCODE_TAG (SCM_OBJCODE_TYPE_MMAP
, 0);
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
);
110 case BYTECODE_KIND_NONE
:
117 check_elf_header (const Elf_Ehdr
*header
)
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";
125 if (header
->e_ident
[EI_CLASS
] != ELFCLASS
)
126 return "ELF file does not have native word size";
128 if (header
->e_ident
[EI_DATA
] != ELFDATA
)
129 return "ELF file does not have native byte order";
131 if (header
->e_ident
[EI_VERSION
] != EV_CURRENT
)
132 return "bad ELF version";
134 if (header
->e_ident
[EI_OSABI
] != ELFOSABI_STANDALONE
)
135 return "unexpected OS ABI";
137 if (header
->e_ident
[EI_ABIVERSION
] != 0)
138 return "unexpected ABI version";
140 if (header
->e_type
!= ET_DYN
)
141 return "unexpected ELF type";
143 if (header
->e_machine
!= EM_NONE
)
144 return "unexpected machine";
146 if (header
->e_version
!= EV_CURRENT
)
147 return "unexpected ELF version";
149 if (header
->e_ehsize
!= sizeof *header
)
150 return "unexpected header size";
152 if (header
->e_phentsize
!= sizeof (Elf_Phdr
))
153 return "unexpected program header size";
159 segment_flags_to_prot (Elf_Word flags
)
174 map_segments (int fd
, char **base
,
175 const Elf_Phdr
*from
, const Elf_Phdr
*to
)
177 int prot
= segment_flags_to_prot (from
->p_flags
);
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
);
184 if (ret
== (char *) -1)
194 mprotect_segments (char *base
, const Elf_Phdr
*from
, const Elf_Phdr
*to
)
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
));
202 process_dynamic_segment (char *base
, Elf_Phdr
*dyn_phdr
,
203 SCM
*init_out
, SCM
*entry_out
)
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
;
212 for (i
= 0; i
< dyn_size
; i
++)
214 if (dyn
[i
].d_tag
== DT_NULL
)
217 switch (dyn
[i
].d_tag
)
221 return "duplicate DT_INIT";
222 init
= base
+ dyn
[i
].d_un
.d_val
;
224 case DT_GUILE_GC_ROOT
:
226 return "duplicate DT_GUILE_GC_ROOT";
227 gc_root
= base
+ dyn
[i
].d_un
.d_val
;
229 case DT_GUILE_GC_ROOT_SZ
:
231 return "duplicate DT_GUILE_GC_ROOT_SZ";
232 gc_root_size
= dyn
[i
].d_un
.d_val
;
236 return "duplicate DT_GUILE_ENTRY";
237 entry
= base
+ dyn
[i
].d_un
.d_val
;
239 case DT_GUILE_RTL_VERSION
:
240 if (bytecode_kind
!= BYTECODE_KIND_NONE
)
241 return "duplicate DT_GUILE_RTL_VERSION";
243 scm_t_uint16 major
= dyn
[i
].d_un
.d_val
>> 16;
244 scm_t_uint16 minor
= dyn
[i
].d_un
.d_val
& 0xffff;
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
;
255 if (bytecode_kind
!= BYTECODE_KIND_GUILE_2_0
)
256 return "missing DT_GUILE_RTL_VERSION";
258 return "unexpected DT_INIT";
259 if ((scm_t_uintptr
) entry
% 8)
260 return "unaligned DT_GUILE_ENTRY";
262 return "missing DT_GUILE_ENTRY";
265 GC_add_roots (gc_root
, gc_root
+ gc_root_size
);
267 *init_out
= SCM_BOOL_F
;
268 *entry_out
= pointer_to_procedure (bytecode_kind
, entry
);
272 #define ABORT(msg) do { err_msg = msg; goto cleanup; } while (0)
274 #ifdef HAVE_SYS_MMAN_H
276 load_thunk_from_fd_using_mmap (int fd
)
277 #define FUNC_NAME "load-thunk-from-disk"
281 const char *err_msg
= 0;
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
;
290 if (full_read (fd
, &header
, sizeof header
) != sizeof header
)
291 ABORT ("object file too small");
293 if ((err_msg
= check_elf_header (&header
)))
296 if (lseek (fd
, header
.e_phoff
, SEEK_SET
) == (off_t
) -1)
300 ph
= scm_gc_malloc_pointerless (n
* sizeof (Elf_Phdr
), "segment headers");
302 if (full_read (fd
, ph
, n
* sizeof (Elf_Phdr
)) != n
* sizeof (Elf_Phdr
))
303 ABORT ("failed to read program headers");
305 for (i
= 0; i
< n
; i
++)
310 if (ph
[i
].p_filesz
!= ph
[i
].p_memsz
)
311 ABORT ("expected p_filesz == p_memsz");
314 ABORT ("expected nonzero segment flags");
316 if (ph
[i
].p_type
== PT_DYNAMIC
)
318 if (dynamic_segment
>= 0)
319 ABORT ("expected only one PT_DYNAMIC segment");
323 if (start_segment
< 0)
325 if (!base
&& ph
[i
].p_vaddr
)
326 ABORT ("first loadable vaddr is not 0");
328 start_segment
= prev_segment
= i
;
332 if (ph
[i
].p_flags
== ph
[start_segment
].p_flags
)
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");
342 /* Otherwise we have a new kind of segment. Map previous
344 if (map_segments (fd
, &base
, &ph
[start_segment
], &ph
[prev_segment
]))
347 /* Open a new set of segments. */
348 start_segment
= prev_segment
= i
;
351 /* Map last segments. */
352 if (start_segment
< 0)
353 ABORT ("no loadable segments");
355 if (map_segments (fd
, &base
, &ph
[start_segment
], &ph
[prev_segment
]))
358 if (dynamic_segment
< 0)
359 ABORT ("no PT_DYNAMIC segment");
361 if ((err_msg
= process_dynamic_segment (base
, &ph
[dynamic_segment
],
365 if (scm_is_true (init
))
368 /* Finally! Return the thunk. */
371 /* FIXME: munmap on error? */
374 int errno_save
= errno
;
379 scm_misc_error (FUNC_NAME
, err_msg
? err_msg
: "error loading ELF file",
384 #endif /* HAVE_SYS_MMAN_H */
387 load_thunk_from_memory (char *data
, size_t len
)
388 #define FUNC_NAME "load-thunk-from-memory"
392 const char *err_msg
= 0;
394 size_t n
, memsz
= 0, alignment
= 8;
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
;
402 if (len
< sizeof header
)
403 ABORT ("object file too small");
405 memcpy (&header
, data
, sizeof header
);
407 if ((err_msg
= check_elf_header (&header
)))
411 if (len
< header
.e_phoff
+ n
* sizeof (Elf_Phdr
))
413 ph
= (Elf_Phdr
*) (data
+ header
.e_phoff
);
415 for (i
= 0; i
< n
; i
++)
420 if (ph
[i
].p_filesz
!= ph
[i
].p_memsz
)
421 ABORT ("expected p_filesz == p_memsz");
424 ABORT ("expected nonzero segment flags");
426 if (ph
[i
].p_align
< alignment
)
428 if (ph
[i
].p_align
% alignment
)
429 ABORT ("expected new alignment to be multiple of old");
430 alignment
= ph
[i
].p_align
;
433 if (ph
[i
].p_type
== PT_DYNAMIC
)
435 if (dynamic_segment
>= 0)
436 ABORT ("expected only one PT_DYNAMIC segment");
440 if (first_loadable
< 0)
443 ABORT ("first loadable vaddr is not 0");
448 if (ph
[i
].p_vaddr
< memsz
)
449 ABORT ("overlapping segments");
451 if (ph
[i
].p_offset
+ ph
[i
].p_filesz
> len
)
452 ABORT ("segment beyond end of byte array");
454 memsz
= ph
[i
].p_vaddr
+ ph
[i
].p_memsz
;
457 if (first_loadable
< 0)
458 ABORT ("no loadable segments");
460 if (dynamic_segment
< 0)
461 ABORT ("no PT_DYNAMIC segment");
463 /* Now copy segments. */
465 /* We leak this memory, as we leak the memory mappings in
466 load_thunk_from_fd_using_mmap.
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. */
473 base
= malloc (memsz
);
478 if ((errno
= posix_memalign ((void **) &base
, alignment
, memsz
)))
481 memset (base
, 0, memsz
);
483 for (i
= 0; i
< n
; i
++)
488 memcpy (base
+ ph
[i
].p_vaddr
,
489 data
+ ph
[i
].p_offset
,
492 if (start_segment
< 0)
494 start_segment
= prev_segment
= i
;
498 if (ph
[i
].p_flags
== ph
[start_segment
].p_flags
)
504 if (alignment
== 4096)
505 if (mprotect_segments (base
, &ph
[start_segment
], &ph
[prev_segment
]))
508 /* Open a new set of segments. */
509 start_segment
= prev_segment
= i
;
512 /* Mprotect the last segments. */
513 if (alignment
== 4096)
514 if (mprotect_segments (base
, &ph
[start_segment
], &ph
[prev_segment
]))
517 if ((err_msg
= process_dynamic_segment (base
, &ph
[dynamic_segment
],
521 if (scm_is_true (init
))
524 /* Finally! Return the thunk. */
531 scm_misc_error (FUNC_NAME
, err_msg
? err_msg
: "error loading ELF file",
537 #ifndef HAVE_SYS_MMAN_H
539 load_thunk_from_fd_using_read (int fd
)
540 #define FUNC_NAME "load-thunk-from-disk"
547 ret
= fstat (fd
, &st
);
551 data
= scm_gc_malloc_pointerless (len
, "objcode");
552 if (full_read (fd
, data
, len
) != len
)
554 int errno_save
= errno
;
559 scm_misc_error (FUNC_NAME
, "short read while loading objcode",
563 return load_thunk_from_memory (data
, len
);
566 #endif /* ! HAVE_SYS_MMAN_H */
568 SCM_DEFINE (scm_load_thunk_from_file
, "load-thunk-from-file", 1, 0, 0,
571 #define FUNC_NAME s_scm_load_thunk_from_file
576 SCM_VALIDATE_STRING (1, filename
);
578 c_filename
= scm_to_locale_string (filename
);
579 fd
= open (c_filename
, O_RDONLY
| O_CLOEXEC
);
581 if (fd
< 0) SCM_SYSERROR
;
583 #ifdef HAVE_SYS_MMAN_H
584 return load_thunk_from_fd_using_mmap (fd
);
586 return load_thunk_from_fd_using_read (fd
);
591 SCM_DEFINE (scm_load_thunk_from_memory
, "load-thunk-from-memory", 1, 0, 0,
594 #define FUNC_NAME s_scm_load_thunk_from_memory
596 SCM_VALIDATE_BYTEVECTOR (1, bv
);
598 return load_thunk_from_memory ((char *) SCM_BYTEVECTOR_CONTENTS (bv
),
599 SCM_BYTEVECTOR_LENGTH (bv
));
608 /* Convert X, which is in byte order BYTE_ORDER, to its native
610 static inline uint32_t
611 to_native_order (uint32_t x
, int byte_order
)
613 if (byte_order
== SCM_BYTE_ORDER
)
620 scm_c_make_objcode_slice (SCM parent
, const scm_t_uint8
*ptr
)
621 #define FUNC_NAME "make-objcode-slice"
623 const struct scm_objcode
*data
, *parent_data
;
624 const scm_t_uint8
*parent_base
;
626 SCM_VALIDATE_OBJCODE (1, parent
);
627 parent_data
= SCM_OBJCODE_DATA (parent
);
628 parent_base
= SCM_C_OBJCODE_BASE (parent_data
);
630 if (ptr
< parent_base
631 || ptr
>= (parent_base
+ parent_data
->len
+ parent_data
->metalen
632 - sizeof (struct scm_objcode
)))
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
)));
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). */
642 assert ((((scm_t_bits
) ptr
) &
643 (alignof_type (struct scm_objcode
) - 1UL)) == 0);
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
);
649 return scm_double_cell (SCM_MAKE_OBJCODE_TAG (SCM_OBJCODE_TYPE_SLICE
, 0),
650 (scm_t_bits
)data
, SCM_UNPACK (parent
), 0);
659 SCM_DEFINE (scm_objcode_p
, "objcode?", 1, 0, 0,
662 #define FUNC_NAME s_scm_objcode_p
664 return scm_from_bool (SCM_OBJCODE_P (obj
));
668 SCM_DEFINE (scm_objcode_meta
, "objcode-meta", 1, 0, 0,
671 #define FUNC_NAME s_scm_objcode_meta
673 SCM_VALIDATE_OBJCODE (1, objcode
);
675 if (SCM_OBJCODE_META_LEN (objcode
) == 0)
678 return scm_c_make_objcode_slice (objcode
, (SCM_OBJCODE_BASE (objcode
)
679 + SCM_OBJCODE_LEN (objcode
)));
683 /* Wrap BYTECODE in objcode, interpreting its lengths according to
686 bytecode_to_objcode (SCM bytecode
, int byte_order
)
687 #define FUNC_NAME "bytecode->objcode"
689 size_t size
, len
, metalen
;
690 const scm_t_uint8
*c_bytecode
;
691 struct scm_objcode
*data
;
693 if (!scm_is_bytevector (bytecode
))
694 scm_wrong_type_arg (FUNC_NAME
, 1, bytecode
);
696 size
= SCM_BYTEVECTOR_LENGTH (bytecode
);
697 c_bytecode
= (const scm_t_uint8
*)SCM_BYTEVECTOR_CONTENTS (bytecode
);
699 SCM_ASSERT_RANGE (0, bytecode
, size
>= sizeof(struct scm_objcode
));
700 data
= (struct scm_objcode
*)c_bytecode
;
702 len
= to_native_order (data
->len
, byte_order
);
703 metalen
= to_native_order (data
->metalen
, byte_order
);
705 if (len
+ metalen
!= (size
- sizeof (*data
)))
706 scm_misc_error (FUNC_NAME
, "bad bytevector size (~a != ~a)",
707 scm_list_2 (scm_from_size_t (size
),
708 scm_from_uint32 (sizeof (*data
) + len
+ metalen
)));
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? */
712 return scm_double_cell (SCM_MAKE_OBJCODE_TAG (SCM_OBJCODE_TYPE_BYTEVECTOR
, 0),
713 (scm_t_bits
)data
, SCM_UNPACK (bytecode
), 0);
717 SCM_DEFINE (scm_bytecode_to_objcode
, "bytecode->objcode", 1, 1, 0,
718 (SCM bytecode
, SCM endianness
),
720 #define FUNC_NAME s_scm_bytecode_to_objcode
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
;
731 scm_wrong_type_arg (FUNC_NAME
, 2, endianness
);
733 return bytecode_to_objcode (bytecode
, byte_order
);
737 SCM_DEFINE (scm_objcode_to_bytecode
, "objcode->bytecode", 1, 1, 0,
738 (SCM objcode
, SCM endianness
),
740 #define FUNC_NAME s_scm_objcode_to_bytecode
742 scm_t_uint32 len
, meta_len
, total_len
;
745 SCM_VALIDATE_OBJCODE (1, objcode
);
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
;
754 scm_wrong_type_arg (FUNC_NAME
, 2, endianness
);
756 len
= SCM_OBJCODE_LEN (objcode
);
757 meta_len
= SCM_OBJCODE_META_LEN (objcode
);
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
);
763 return scm_c_take_gc_bytevector ((scm_t_int8
*)SCM_OBJCODE_DATA (objcode
),
769 scm_i_objcode_print (SCM objcode
, SCM port
, scm_print_state
*pstate
)
771 scm_puts_unlocked ("#<objcode ", port
);
772 scm_uintprint ((scm_t_bits
)SCM_OBJCODE_BASE (objcode
), 16, port
);
773 scm_puts_unlocked (">", port
);
778 scm_bootstrap_objcodes (void)
780 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION
,
782 (scm_t_extension_init_func
)scm_init_objcodes
, NULL
);
786 scm_init_objcodes (void)
788 #ifndef SCM_MAGIC_SNARFER
789 #include "libguile/objcodes.x"
792 scm_c_define ("word-size", scm_from_size_t (sizeof(SCM
)));
793 scm_c_define ("byte-order", scm_from_uint16 (SCM_BYTE_ORDER
));