Commit | Line | Data |
---|---|---|
60ed31d2 | 1 | /* Copyright (C) 2001, 2009 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> |
8f5cfc81 | 30 | |
560b9c25 | 31 | #include "_scm.h" |
83495480 | 32 | #include "vm-bootstrap.h" |
8f5cfc81 KN |
33 | #include "programs.h" |
34 | #include "objcodes.h" | |
35 | ||
9e1a18db LC |
36 | /* The endianness marker in objcode. */ |
37 | #ifdef WORDS_BIGENDIAN | |
38 | # define OBJCODE_ENDIANNESS "BE" | |
39 | #else | |
40 | # define OBJCODE_ENDIANNESS "LE" | |
41 | #endif | |
42 | ||
43 | #define _OBJCODE_STRINGIFY(x) # x | |
44 | #define OBJCODE_STRINGIFY(x) _OBJCODE_STRINGIFY (x) | |
45 | ||
46 | /* The word size marker in objcode. */ | |
47 | #define OBJCODE_WORD_SIZE OBJCODE_STRINGIFY (SIZEOF_VOID_P) | |
48 | ||
53e28ed9 | 49 | /* nb, the length of the header should be a multiple of 8 bytes */ |
9e1a18db LC |
50 | #define OBJCODE_COOKIE \ |
51 | "GOOF-0.6-" OBJCODE_ENDIANNESS "-" OBJCODE_WORD_SIZE "---" | |
8f5cfc81 KN |
52 | |
53 | \f | |
54 | /* | |
55 | * Objcode type | |
56 | */ | |
57 | ||
f9e8c09d | 58 | scm_t_bits scm_tc16_objcode; |
8f5cfc81 | 59 | |
8f5cfc81 KN |
60 | static SCM |
61 | make_objcode_by_mmap (int fd) | |
62 | #define FUNC_NAME "make_objcode_by_mmap" | |
63 | { | |
64 | int ret; | |
65 | char *addr; | |
66 | struct stat st; | |
53e28ed9 AW |
67 | SCM sret = SCM_BOOL_F; |
68 | struct scm_objcode *data; | |
8f5cfc81 KN |
69 | |
70 | ret = fstat (fd, &st); | |
0b5f0e49 | 71 | if (ret < 0) |
62082959 | 72 | SCM_SYSERROR; |
8f5cfc81 | 73 | |
53e28ed9 | 74 | if (st.st_size <= sizeof (struct scm_objcode) + strlen (OBJCODE_COOKIE)) |
0b5f0e49 | 75 | scm_misc_error (FUNC_NAME, "object file too small (~a bytes)", |
da8b4747 | 76 | scm_list_1 (SCM_I_MAKINUM (st.st_size))); |
0b5f0e49 | 77 | |
8f5cfc81 | 78 | addr = mmap (0, st.st_size, PROT_READ, MAP_SHARED, fd, 0); |
62082959 | 79 | if (addr == MAP_FAILED) |
376b6bd7 LC |
80 | { |
81 | (void) close (fd); | |
82 | SCM_SYSERROR; | |
83 | } | |
62082959 LC |
84 | |
85 | if (memcmp (addr, OBJCODE_COOKIE, strlen (OBJCODE_COOKIE))) | |
376b6bd7 | 86 | { |
7c957b86 AW |
87 | SCM args = scm_list_1 (scm_from_locale_stringn |
88 | (addr, strlen (OBJCODE_COOKIE))); | |
376b6bd7 LC |
89 | (void) close (fd); |
90 | (void) munmap (addr, st.st_size); | |
7c957b86 | 91 | scm_misc_error (FUNC_NAME, "bad header on object file: ~s", args); |
376b6bd7 | 92 | } |
8f5cfc81 | 93 | |
53e28ed9 AW |
94 | data = (struct scm_objcode*)(addr + strlen (OBJCODE_COOKIE)); |
95 | ||
1f1ec13b | 96 | if (data->len + data->metalen != (st.st_size - sizeof (*data) - strlen (OBJCODE_COOKIE))) |
376b6bd7 LC |
97 | { |
98 | (void) close (fd); | |
99 | (void) munmap (addr, st.st_size); | |
100 | scm_misc_error (FUNC_NAME, "bad length header (~a, ~a)", | |
101 | scm_list_2 (scm_from_size_t (st.st_size), | |
102 | scm_from_uint32 (sizeof (*data) + data->len | |
103 | + data->metalen))); | |
104 | } | |
53e28ed9 AW |
105 | |
106 | SCM_NEWSMOB3 (sret, scm_tc16_objcode, addr + strlen (OBJCODE_COOKIE), | |
107 | SCM_PACK (SCM_BOOL_F), fd); | |
108 | SCM_SET_SMOB_FLAGS (sret, SCM_F_OBJCODE_IS_MMAP); | |
109 | ||
110 | /* FIXME: we leak ourselves and the file descriptor. but then again so does | |
111 | dlopen(). */ | |
112 | return scm_permanent_object (sret); | |
8f5cfc81 KN |
113 | } |
114 | #undef FUNC_NAME | |
115 | ||
53e28ed9 AW |
116 | SCM |
117 | scm_c_make_objcode_slice (SCM parent, scm_t_uint8 *ptr) | |
118 | #define FUNC_NAME "make-objcode-slice" | |
8f5cfc81 | 119 | { |
53e28ed9 AW |
120 | struct scm_objcode *data, *parent_data; |
121 | SCM ret; | |
122 | ||
123 | SCM_VALIDATE_OBJCODE (1, parent); | |
124 | parent_data = SCM_OBJCODE_DATA (parent); | |
125 | ||
126 | if (ptr < parent_data->base | |
1f1ec13b | 127 | || ptr >= (parent_data->base + parent_data->len + parent_data->metalen |
53e28ed9 | 128 | - sizeof (struct scm_objcode))) |
1f1ec13b | 129 | scm_misc_error (FUNC_NAME, "offset out of bounds (~a vs ~a + ~a + ~a)", |
da8b4747 LC |
130 | scm_list_4 (scm_from_ulong ((unsigned long)ptr), |
131 | scm_from_ulong ((unsigned long)parent_data->base), | |
132 | scm_from_uint32 (parent_data->len), | |
133 | scm_from_uint32 (parent_data->metalen))); | |
53e28ed9 AW |
134 | |
135 | data = (struct scm_objcode*)ptr; | |
1f1ec13b | 136 | if (data->base + data->len + data->metalen > parent_data->base + parent_data->len + parent_data->metalen) |
53e28ed9 AW |
137 | abort (); |
138 | ||
139 | SCM_NEWSMOB2 (ret, scm_tc16_objcode, data, parent); | |
140 | SCM_SET_SMOB_FLAGS (ret, SCM_F_OBJCODE_IS_SLICE); | |
141 | return ret; | |
8f5cfc81 KN |
142 | } |
143 | #undef FUNC_NAME | |
144 | ||
53e28ed9 AW |
145 | static SCM |
146 | objcode_mark (SCM obj) | |
147 | { | |
148 | return SCM_SMOB_OBJECT_2 (obj); | |
149 | } | |
150 | ||
8f5cfc81 KN |
151 | \f |
152 | /* | |
153 | * Scheme interface | |
154 | */ | |
155 | ||
156 | SCM_DEFINE (scm_objcode_p, "objcode?", 1, 0, 0, | |
157 | (SCM obj), | |
158 | "") | |
159 | #define FUNC_NAME s_scm_objcode_p | |
160 | { | |
161 | return SCM_BOOL (SCM_OBJCODE_P (obj)); | |
162 | } | |
163 | #undef FUNC_NAME | |
164 | ||
1f1ec13b AW |
165 | SCM_DEFINE (scm_objcode_meta, "objcode-meta", 1, 0, 0, |
166 | (SCM objcode), | |
167 | "") | |
168 | #define FUNC_NAME s_scm_objcode_meta | |
169 | { | |
170 | SCM_VALIDATE_OBJCODE (1, objcode); | |
171 | ||
172 | if (SCM_OBJCODE_META_LEN (objcode) == 0) | |
173 | return SCM_BOOL_F; | |
174 | else | |
175 | return scm_c_make_objcode_slice (objcode, (SCM_OBJCODE_BASE (objcode) | |
176 | + SCM_OBJCODE_LEN (objcode))); | |
177 | } | |
178 | #undef FUNC_NAME | |
179 | ||
53e28ed9 AW |
180 | SCM_DEFINE (scm_bytecode_to_objcode, "bytecode->objcode", 1, 0, 0, |
181 | (SCM bytecode), | |
8f5cfc81 KN |
182 | "") |
183 | #define FUNC_NAME s_scm_bytecode_to_objcode | |
184 | { | |
185 | size_t size; | |
054599f1 LC |
186 | ssize_t increment; |
187 | scm_t_array_handle handle; | |
b6368dbb | 188 | const scm_t_uint8 *c_bytecode; |
53e28ed9 | 189 | struct scm_objcode *data; |
8f5cfc81 KN |
190 | SCM objcode; |
191 | ||
53e28ed9 | 192 | if (scm_is_false (scm_u8vector_p (bytecode))) |
054599f1 | 193 | scm_wrong_type_arg (FUNC_NAME, 1, bytecode); |
8f5cfc81 | 194 | |
054599f1 | 195 | c_bytecode = scm_u8vector_elements (bytecode, &handle, &size, &increment); |
53e28ed9 AW |
196 | data = (struct scm_objcode*)c_bytecode; |
197 | SCM_NEWSMOB2 (objcode, scm_tc16_objcode, data, bytecode); | |
054599f1 | 198 | scm_array_handle_release (&handle); |
ac47d5f6 AW |
199 | |
200 | SCM_ASSERT_RANGE (0, bytecode, size >= sizeof(struct scm_objcode)); | |
201 | if (data->len + data->metalen != (size - sizeof (*data))) | |
202 | scm_misc_error (FUNC_NAME, "bad u8vector size (~a != ~a)", | |
da8b4747 LC |
203 | scm_list_2 (scm_from_size_t (size), |
204 | scm_from_uint32 (sizeof (*data) + data->len + data->metalen))); | |
53e28ed9 | 205 | assert (increment == 1); |
53e28ed9 AW |
206 | SCM_SET_SMOB_FLAGS (objcode, SCM_F_OBJCODE_IS_U8VECTOR); |
207 | ||
208 | /* foolishly, we assume that as long as bytecode is around, that c_bytecode | |
209 | will be of the same length; perhaps a bad assumption? */ | |
d8eeb67c | 210 | |
8f5cfc81 KN |
211 | return objcode; |
212 | } | |
213 | #undef FUNC_NAME | |
214 | ||
215 | SCM_DEFINE (scm_load_objcode, "load-objcode", 1, 0, 0, | |
216 | (SCM file), | |
217 | "") | |
218 | #define FUNC_NAME s_scm_load_objcode | |
219 | { | |
220 | int fd; | |
2d80426a | 221 | char *c_file; |
8f5cfc81 KN |
222 | |
223 | SCM_VALIDATE_STRING (1, file); | |
224 | ||
2d80426a LC |
225 | c_file = scm_to_locale_string (file); |
226 | fd = open (c_file, O_RDONLY); | |
227 | free (c_file); | |
8f5cfc81 KN |
228 | if (fd < 0) SCM_SYSERROR; |
229 | ||
230 | return make_objcode_by_mmap (fd); | |
231 | } | |
232 | #undef FUNC_NAME | |
233 | ||
9bb8012d | 234 | SCM_DEFINE (scm_objcode_to_bytecode, "objcode->bytecode", 1, 0, 0, |
8f5cfc81 KN |
235 | (SCM objcode), |
236 | "") | |
9bb8012d | 237 | #define FUNC_NAME s_scm_objcode_to_bytecode |
8f5cfc81 | 238 | { |
b6368dbb | 239 | scm_t_uint8 *u8vector; |
53e28ed9 | 240 | scm_t_uint32 len; |
054599f1 | 241 | |
8f5cfc81 | 242 | SCM_VALIDATE_OBJCODE (1, objcode); |
054599f1 | 243 | |
1f1ec13b | 244 | len = sizeof(struct scm_objcode) + SCM_OBJCODE_TOTAL_LEN (objcode); |
054599f1 | 245 | /* FIXME: Is `gc_malloc' ok here? */ |
53e28ed9 AW |
246 | u8vector = scm_gc_malloc (len, "objcode-u8vector"); |
247 | memcpy (u8vector, SCM_OBJCODE_DATA (objcode), len); | |
054599f1 | 248 | |
53e28ed9 | 249 | return scm_take_u8vector (u8vector, len); |
8f5cfc81 KN |
250 | } |
251 | #undef FUNC_NAME | |
252 | ||
53e28ed9 AW |
253 | SCM_DEFINE (scm_write_objcode, "write-objcode", 2, 0, 0, |
254 | (SCM objcode, SCM port), | |
8f5cfc81 | 255 | "") |
53e28ed9 | 256 | #define FUNC_NAME s_scm_write_objcode |
8f5cfc81 | 257 | { |
8f5cfc81 | 258 | SCM_VALIDATE_OBJCODE (1, objcode); |
53e28ed9 AW |
259 | SCM_VALIDATE_OUTPUT_PORT (2, port); |
260 | ||
261 | scm_c_write (port, OBJCODE_COOKIE, strlen (OBJCODE_COOKIE)); | |
262 | scm_c_write (port, SCM_OBJCODE_DATA (objcode), | |
1f1ec13b | 263 | sizeof (struct scm_objcode) + SCM_OBJCODE_TOTAL_LEN (objcode)); |
53e28ed9 AW |
264 | |
265 | return SCM_UNSPECIFIED; | |
8f5cfc81 KN |
266 | } |
267 | #undef FUNC_NAME | |
268 | ||
269 | \f | |
270 | void | |
07e56b27 | 271 | scm_bootstrap_objcodes (void) |
8f5cfc81 KN |
272 | { |
273 | scm_tc16_objcode = scm_make_smob_type ("objcode", 0); | |
53e28ed9 | 274 | scm_set_smob_mark (scm_tc16_objcode, objcode_mark); |
60ae5ca2 AW |
275 | scm_c_register_extension ("libguile", "scm_init_objcodes", |
276 | (scm_t_extension_init_func)scm_init_objcodes, NULL); | |
07e56b27 AW |
277 | } |
278 | ||
8992a9e3 AW |
279 | /* Before, we used __BYTE_ORDER, but that is not defined on all |
280 | systems. So punt and use automake, PDP endianness be damned. */ | |
281 | #ifdef WORDS_BIGENDIAN | |
282 | #define SCM_BYTE_ORDER 4321 | |
283 | #else | |
284 | #define SCM_BYTE_ORDER 1234 | |
285 | #endif | |
286 | ||
07e56b27 AW |
287 | void |
288 | scm_init_objcodes (void) | |
289 | { | |
290 | scm_bootstrap_vm (); | |
8f5cfc81 KN |
291 | |
292 | #ifndef SCM_MAGIC_SNARFER | |
aeeff258 | 293 | #include "libguile/objcodes.x" |
8f5cfc81 | 294 | #endif |
53e28ed9 AW |
295 | |
296 | scm_c_define ("word-size", scm_from_size_t (sizeof(SCM))); | |
8992a9e3 | 297 | scm_c_define ("byte-order", scm_from_uint16 (SCM_BYTE_ORDER)); |
8f5cfc81 KN |
298 | } |
299 | ||
300 | /* | |
301 | Local Variables: | |
302 | c-file-style: "gnu" | |
303 | End: | |
304 | */ |