Commit | Line | Data |
---|---|---|
4914fe19 | 1 | /* Copyright (C) 2001, 2009, 2010, 2011 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> | |
26 | #include <sys/mman.h> | |
27 | #include <sys/stat.h> | |
28 | #include <sys/types.h> | |
054599f1 | 29 | #include <assert.h> |
1119e493 | 30 | #include <alignof.h> |
8f5cfc81 | 31 | |
560b9c25 | 32 | #include "_scm.h" |
8f5cfc81 KN |
33 | #include "programs.h" |
34 | #include "objcodes.h" | |
35 | ||
4b02bf47 AW |
36 | /* SCM_OBJCODE_COOKIE, defined in _scm.h, is a magic value prepended |
37 | to objcode on disk but not in memory. | |
38 | ||
39 | The length of the header must be a multiple of 8 bytes. */ | |
86cfb42d | 40 | verify (((sizeof (SCM_OBJCODE_COOKIE) - 1) & 7) == 0); |
8f5cfc81 KN |
41 | |
42 | \f | |
43 | /* | |
44 | * Objcode type | |
45 | */ | |
46 | ||
4b02bf47 | 47 | /* The words in an objcode SCM object are as follows: |
6ce3666f | 48 | - scm_tc7_objcode | type | flags |
4b02bf47 | 49 | - the struct scm_objcode C object |
6ce3666f AW |
50 | - the parent of this objcode: either another objcode, a bytevector, |
51 | or, in the case of mmap types, file descriptors (as an inum) | |
52 | - "native code" -- not currently used. | |
4b02bf47 AW |
53 | */ |
54 | ||
8f5cfc81 KN |
55 | static SCM |
56 | make_objcode_by_mmap (int fd) | |
57 | #define FUNC_NAME "make_objcode_by_mmap" | |
58 | { | |
59 | int ret; | |
60 | char *addr; | |
61 | struct stat st; | |
53e28ed9 AW |
62 | SCM sret = SCM_BOOL_F; |
63 | struct scm_objcode *data; | |
8f5cfc81 KN |
64 | |
65 | ret = fstat (fd, &st); | |
0b5f0e49 | 66 | if (ret < 0) |
62082959 | 67 | SCM_SYSERROR; |
8f5cfc81 | 68 | |
86cfb42d | 69 | if (st.st_size <= sizeof (struct scm_objcode) + strlen (SCM_OBJCODE_COOKIE)) |
0b5f0e49 | 70 | scm_misc_error (FUNC_NAME, "object file too small (~a bytes)", |
da8b4747 | 71 | scm_list_1 (SCM_I_MAKINUM (st.st_size))); |
0b5f0e49 | 72 | |
355dd8cb | 73 | addr = mmap (0, st.st_size, PROT_READ, MAP_PRIVATE, fd, 0); |
62082959 | 74 | if (addr == MAP_FAILED) |
376b6bd7 LC |
75 | { |
76 | (void) close (fd); | |
77 | SCM_SYSERROR; | |
78 | } | |
62082959 | 79 | |
e8ab529d AW |
80 | /* The cookie ends with a version of the form M.N, where M is the |
81 | major version and N is the minor version. For this Guile to be | |
82 | able to load an objcode, M must be SCM_OBJCODE_MAJOR_VERSION, and N | |
83 | must be less than or equal to SCM_OBJCODE_MINOR_VERSION. Since N | |
84 | is the last character, we do a strict comparison on all but the | |
85 | last, then a <= on the last one. */ | |
86 | if (memcmp (addr, SCM_OBJCODE_COOKIE, strlen (SCM_OBJCODE_COOKIE) - 1)) | |
376b6bd7 | 87 | { |
4914fe19 | 88 | SCM args = scm_list_1 (scm_from_latin1_stringn |
86cfb42d | 89 | (addr, strlen (SCM_OBJCODE_COOKIE))); |
376b6bd7 LC |
90 | (void) close (fd); |
91 | (void) munmap (addr, st.st_size); | |
7c957b86 | 92 | scm_misc_error (FUNC_NAME, "bad header on object file: ~s", args); |
376b6bd7 | 93 | } |
8f5cfc81 | 94 | |
e8ab529d AW |
95 | { |
96 | char minor_version = addr[strlen (SCM_OBJCODE_COOKIE) - 1]; | |
97 | ||
98 | if (minor_version > SCM_OBJCODE_MINOR_VERSION_STRING[0]) | |
99 | scm_misc_error (FUNC_NAME, "objcode minor version too new (~a > ~a)", | |
100 | scm_list_2 (scm_from_latin1_stringn (&minor_version, 1), | |
101 | scm_from_latin1_string | |
102 | (SCM_OBJCODE_MINOR_VERSION_STRING))); | |
103 | } | |
104 | ||
86cfb42d | 105 | data = (struct scm_objcode*)(addr + strlen (SCM_OBJCODE_COOKIE)); |
53e28ed9 | 106 | |
86cfb42d | 107 | if (data->len + data->metalen != (st.st_size - sizeof (*data) - strlen (SCM_OBJCODE_COOKIE))) |
376b6bd7 LC |
108 | { |
109 | (void) close (fd); | |
110 | (void) munmap (addr, st.st_size); | |
111 | scm_misc_error (FUNC_NAME, "bad length header (~a, ~a)", | |
112 | scm_list_2 (scm_from_size_t (st.st_size), | |
113 | scm_from_uint32 (sizeof (*data) + data->len | |
114 | + data->metalen))); | |
115 | } | |
53e28ed9 | 116 | |
f9654187 | 117 | sret = scm_double_cell (SCM_MAKE_OBJCODE_TAG (SCM_OBJCODE_TYPE_MMAP, 0), |
6f3b0cc2 | 118 | (scm_t_bits)(addr + strlen (SCM_OBJCODE_COOKIE)), |
6ce3666f | 119 | SCM_UNPACK (scm_from_int (fd)), 0); |
53e28ed9 AW |
120 | |
121 | /* FIXME: we leak ourselves and the file descriptor. but then again so does | |
122 | dlopen(). */ | |
123 | return scm_permanent_object (sret); | |
8f5cfc81 KN |
124 | } |
125 | #undef FUNC_NAME | |
126 | ||
53e28ed9 | 127 | SCM |
b67cb286 | 128 | scm_c_make_objcode_slice (SCM parent, const scm_t_uint8 *ptr) |
53e28ed9 | 129 | #define FUNC_NAME "make-objcode-slice" |
8f5cfc81 | 130 | { |
b67cb286 | 131 | const struct scm_objcode *data, *parent_data; |
3dbbe28d | 132 | const scm_t_uint8 *parent_base; |
53e28ed9 AW |
133 | |
134 | SCM_VALIDATE_OBJCODE (1, parent); | |
135 | parent_data = SCM_OBJCODE_DATA (parent); | |
3dbbe28d LC |
136 | parent_base = SCM_C_OBJCODE_BASE (parent_data); |
137 | ||
138 | if (ptr < parent_base | |
139 | || ptr >= (parent_base + parent_data->len + parent_data->metalen | |
53e28ed9 | 140 | - sizeof (struct scm_objcode))) |
3d27ef4b AW |
141 | scm_misc_error |
142 | (FUNC_NAME, "offset out of bounds (~a vs ~a + ~a + ~a)", | |
143 | scm_list_4 (scm_from_unsigned_integer ((scm_t_bits) ptr), | |
144 | scm_from_unsigned_integer ((scm_t_bits) parent_base), | |
145 | scm_from_uint32 (parent_data->len), | |
146 | scm_from_uint32 (parent_data->metalen))); | |
53e28ed9 | 147 | |
e3c9c676 LC |
148 | /* Make sure bytecode for the objcode-meta is suitable aligned. Failing to |
149 | do so leads to SIGBUS/SIGSEGV on some arches (e.g., SPARC). */ | |
1119e493 LC |
150 | assert ((((scm_t_bits) ptr) & |
151 | (alignof_type (struct scm_objcode) - 1UL)) == 0); | |
53e28ed9 | 152 | |
3dbbe28d LC |
153 | data = (struct scm_objcode*) ptr; |
154 | assert (SCM_C_OBJCODE_BASE (data) + data->len + data->metalen | |
155 | <= parent_base + parent_data->len + parent_data->metalen); | |
53e28ed9 | 156 | |
f9654187 | 157 | return scm_double_cell (SCM_MAKE_OBJCODE_TAG (SCM_OBJCODE_TYPE_SLICE, 0), |
6f3b0cc2 | 158 | (scm_t_bits)data, SCM_UNPACK (parent), 0); |
8f5cfc81 KN |
159 | } |
160 | #undef FUNC_NAME | |
161 | ||
162 | \f | |
163 | /* | |
164 | * Scheme interface | |
165 | */ | |
166 | ||
167 | SCM_DEFINE (scm_objcode_p, "objcode?", 1, 0, 0, | |
168 | (SCM obj), | |
169 | "") | |
170 | #define FUNC_NAME s_scm_objcode_p | |
171 | { | |
5c8cefe5 | 172 | return scm_from_bool (SCM_OBJCODE_P (obj)); |
8f5cfc81 KN |
173 | } |
174 | #undef FUNC_NAME | |
175 | ||
1f1ec13b AW |
176 | SCM_DEFINE (scm_objcode_meta, "objcode-meta", 1, 0, 0, |
177 | (SCM objcode), | |
178 | "") | |
179 | #define FUNC_NAME s_scm_objcode_meta | |
180 | { | |
181 | SCM_VALIDATE_OBJCODE (1, objcode); | |
182 | ||
183 | if (SCM_OBJCODE_META_LEN (objcode) == 0) | |
184 | return SCM_BOOL_F; | |
185 | else | |
186 | return scm_c_make_objcode_slice (objcode, (SCM_OBJCODE_BASE (objcode) | |
187 | + SCM_OBJCODE_LEN (objcode))); | |
188 | } | |
189 | #undef FUNC_NAME | |
190 | ||
53e28ed9 AW |
191 | SCM_DEFINE (scm_bytecode_to_objcode, "bytecode->objcode", 1, 0, 0, |
192 | (SCM bytecode), | |
8f5cfc81 KN |
193 | "") |
194 | #define FUNC_NAME s_scm_bytecode_to_objcode | |
195 | { | |
196 | size_t size; | |
b6368dbb | 197 | const scm_t_uint8 *c_bytecode; |
53e28ed9 | 198 | struct scm_objcode *data; |
8f5cfc81 | 199 | |
a2689737 | 200 | if (!scm_is_bytevector (bytecode)) |
054599f1 | 201 | scm_wrong_type_arg (FUNC_NAME, 1, bytecode); |
8f5cfc81 | 202 | |
a2689737 AW |
203 | size = SCM_BYTEVECTOR_LENGTH (bytecode); |
204 | c_bytecode = (const scm_t_uint8*)SCM_BYTEVECTOR_CONTENTS (bytecode); | |
205 | ||
206 | SCM_ASSERT_RANGE (0, bytecode, size >= sizeof(struct scm_objcode)); | |
53e28ed9 | 207 | data = (struct scm_objcode*)c_bytecode; |
ac47d5f6 | 208 | |
ac47d5f6 | 209 | if (data->len + data->metalen != (size - sizeof (*data))) |
a2689737 | 210 | scm_misc_error (FUNC_NAME, "bad bytevector size (~a != ~a)", |
da8b4747 LC |
211 | scm_list_2 (scm_from_size_t (size), |
212 | scm_from_uint32 (sizeof (*data) + data->len + data->metalen))); | |
a2689737 | 213 | |
53e28ed9 AW |
214 | /* foolishly, we assume that as long as bytecode is around, that c_bytecode |
215 | will be of the same length; perhaps a bad assumption? */ | |
f9654187 | 216 | return scm_double_cell (SCM_MAKE_OBJCODE_TAG (SCM_OBJCODE_TYPE_BYTEVECTOR, 0), |
6f3b0cc2 | 217 | (scm_t_bits)data, SCM_UNPACK (bytecode), 0); |
8f5cfc81 KN |
218 | } |
219 | #undef FUNC_NAME | |
220 | ||
221 | SCM_DEFINE (scm_load_objcode, "load-objcode", 1, 0, 0, | |
222 | (SCM file), | |
223 | "") | |
224 | #define FUNC_NAME s_scm_load_objcode | |
225 | { | |
226 | int fd; | |
2d80426a | 227 | char *c_file; |
8f5cfc81 KN |
228 | |
229 | SCM_VALIDATE_STRING (1, file); | |
230 | ||
2d80426a LC |
231 | c_file = scm_to_locale_string (file); |
232 | fd = open (c_file, O_RDONLY); | |
233 | free (c_file); | |
8f5cfc81 KN |
234 | if (fd < 0) SCM_SYSERROR; |
235 | ||
236 | return make_objcode_by_mmap (fd); | |
237 | } | |
238 | #undef FUNC_NAME | |
239 | ||
9bb8012d | 240 | SCM_DEFINE (scm_objcode_to_bytecode, "objcode->bytecode", 1, 0, 0, |
8f5cfc81 KN |
241 | (SCM objcode), |
242 | "") | |
9bb8012d | 243 | #define FUNC_NAME s_scm_objcode_to_bytecode |
8f5cfc81 | 244 | { |
a2689737 | 245 | scm_t_int8 *s8vector; |
53e28ed9 | 246 | scm_t_uint32 len; |
054599f1 | 247 | |
8f5cfc81 | 248 | SCM_VALIDATE_OBJCODE (1, objcode); |
054599f1 | 249 | |
9a690dfb | 250 | len = sizeof (struct scm_objcode) + SCM_OBJCODE_TOTAL_LEN (objcode); |
d7e7a02a | 251 | |
a2689737 AW |
252 | s8vector = scm_malloc (len); |
253 | memcpy (s8vector, SCM_OBJCODE_DATA (objcode), len); | |
054599f1 | 254 | |
a2689737 | 255 | return scm_c_take_bytevector (s8vector, len); |
8f5cfc81 KN |
256 | } |
257 | #undef FUNC_NAME | |
258 | ||
53e28ed9 AW |
259 | SCM_DEFINE (scm_write_objcode, "write-objcode", 2, 0, 0, |
260 | (SCM objcode, SCM port), | |
8f5cfc81 | 261 | "") |
53e28ed9 | 262 | #define FUNC_NAME s_scm_write_objcode |
8f5cfc81 | 263 | { |
8f5cfc81 | 264 | SCM_VALIDATE_OBJCODE (1, objcode); |
53e28ed9 AW |
265 | SCM_VALIDATE_OUTPUT_PORT (2, port); |
266 | ||
86cfb42d | 267 | scm_c_write (port, SCM_OBJCODE_COOKIE, strlen (SCM_OBJCODE_COOKIE)); |
53e28ed9 | 268 | scm_c_write (port, SCM_OBJCODE_DATA (objcode), |
1f1ec13b | 269 | sizeof (struct scm_objcode) + SCM_OBJCODE_TOTAL_LEN (objcode)); |
53e28ed9 AW |
270 | |
271 | return SCM_UNSPECIFIED; | |
8f5cfc81 KN |
272 | } |
273 | #undef FUNC_NAME | |
274 | ||
6f3b0cc2 AW |
275 | void |
276 | scm_i_objcode_print (SCM objcode, SCM port, scm_print_state *pstate) | |
277 | { | |
278 | scm_puts ("#<objcode ", port); | |
279 | scm_uintprint ((scm_t_bits)SCM_OBJCODE_BASE (objcode), 16, port); | |
280 | scm_puts (">", port); | |
281 | } | |
282 | ||
8f5cfc81 KN |
283 | \f |
284 | void | |
07e56b27 | 285 | scm_bootstrap_objcodes (void) |
8f5cfc81 | 286 | { |
44602b08 AW |
287 | scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION, |
288 | "scm_init_objcodes", | |
60ae5ca2 | 289 | (scm_t_extension_init_func)scm_init_objcodes, NULL); |
07e56b27 AW |
290 | } |
291 | ||
8992a9e3 AW |
292 | /* Before, we used __BYTE_ORDER, but that is not defined on all |
293 | systems. So punt and use automake, PDP endianness be damned. */ | |
294 | #ifdef WORDS_BIGENDIAN | |
295 | #define SCM_BYTE_ORDER 4321 | |
296 | #else | |
297 | #define SCM_BYTE_ORDER 1234 | |
298 | #endif | |
299 | ||
07e56b27 AW |
300 | void |
301 | scm_init_objcodes (void) | |
302 | { | |
8f5cfc81 | 303 | #ifndef SCM_MAGIC_SNARFER |
aeeff258 | 304 | #include "libguile/objcodes.x" |
8f5cfc81 | 305 | #endif |
53e28ed9 AW |
306 | |
307 | scm_c_define ("word-size", scm_from_size_t (sizeof(SCM))); | |
8992a9e3 | 308 | scm_c_define ("byte-order", scm_from_uint16 (SCM_BYTE_ORDER)); |
8f5cfc81 KN |
309 | } |
310 | ||
311 | /* | |
312 | Local Variables: | |
313 | c-file-style: "gnu" | |
314 | End: | |
315 | */ |