Commit | Line | Data |
---|---|---|
8f5cfc81 KN |
1 | /* Copyright (C) 2001 Free Software Foundation, Inc. |
2 | * | |
3 | * This program is free software; you can redistribute it and/or modify | |
4 | * it under the terms of the GNU General Public License as published by | |
5 | * the Free Software Foundation; either version 2, or (at your option) | |
6 | * any later version. | |
7 | * | |
8 | * This program is distributed in the hope that it will be useful, | |
9 | * but WITHOUT ANY WARRANTY; without even the implied warranty of | |
10 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
11 | * GNU General Public License for more details. | |
12 | * | |
13 | * You should have received a copy of the GNU General Public License | |
14 | * along with this software; see the file COPYING. If not, write to | |
15 | * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, | |
16 | * Boston, MA 02111-1307 USA | |
17 | * | |
18 | * As a special exception, the Free Software Foundation gives permission | |
19 | * for additional uses of the text contained in its release of GUILE. | |
20 | * | |
21 | * The exception is that, if you link the GUILE library with other files | |
22 | * to produce an executable, this does not by itself cause the | |
23 | * resulting executable to be covered by the GNU General Public License. | |
24 | * Your use of that executable is in no way restricted on account of | |
25 | * linking the GUILE library code into it. | |
26 | * | |
27 | * This exception does not however invalidate any other reasons why | |
28 | * the executable file might be covered by the GNU General Public License. | |
29 | * | |
30 | * This exception applies only to the code released by the | |
31 | * Free Software Foundation under the name GUILE. If you copy | |
32 | * code from other Free Software Foundation releases into a copy of | |
33 | * GUILE, as the General Public License permits, the exception does | |
34 | * not apply to the code that you add in this way. To avoid misleading | |
35 | * anyone as to the status of such modified files, you must delete | |
36 | * this exception notice from them. | |
37 | * | |
38 | * If you write modifications of your own for GUILE, it is your choice | |
39 | * whether to permit this exception to apply to your modifications. | |
40 | * If you do not wish that, delete this exception notice. */ | |
41 | ||
42 | #include <string.h> | |
43 | #include <fcntl.h> | |
44 | #include <unistd.h> | |
45 | #include <sys/mman.h> | |
46 | #include <sys/stat.h> | |
47 | #include <sys/types.h> | |
054599f1 | 48 | #include <assert.h> |
8f5cfc81 KN |
49 | |
50 | #include "programs.h" | |
51 | #include "objcodes.h" | |
52 | ||
53 | #define OBJCODE_COOKIE "GOOF-0.5" | |
54 | ||
55 | \f | |
56 | /* | |
57 | * Objcode type | |
58 | */ | |
59 | ||
f9e8c09d | 60 | scm_t_bits scm_tc16_objcode; |
8f5cfc81 KN |
61 | |
62 | static SCM | |
63 | make_objcode (size_t size) | |
64 | #define FUNC_NAME "make_objcode" | |
65 | { | |
d8eeb67c LC |
66 | struct scm_objcode *p = scm_gc_malloc (sizeof (struct scm_objcode), |
67 | "objcode"); | |
8f5cfc81 | 68 | p->size = size; |
d8eeb67c | 69 | p->base = scm_gc_malloc (size, "objcode-base"); |
8f5cfc81 KN |
70 | p->fd = -1; |
71 | SCM_RETURN_NEWSMOB (scm_tc16_objcode, p); | |
72 | } | |
73 | #undef FUNC_NAME | |
74 | ||
75 | static SCM | |
76 | make_objcode_by_mmap (int fd) | |
77 | #define FUNC_NAME "make_objcode_by_mmap" | |
78 | { | |
79 | int ret; | |
80 | char *addr; | |
81 | struct stat st; | |
82 | struct scm_objcode *p; | |
83 | ||
84 | ret = fstat (fd, &st); | |
0b5f0e49 | 85 | if (ret < 0) |
62082959 | 86 | SCM_SYSERROR; |
8f5cfc81 | 87 | |
0b5f0e49 LC |
88 | if (st.st_size <= strlen (OBJCODE_COOKIE)) |
89 | scm_misc_error (FUNC_NAME, "object file too small (~a bytes)", | |
90 | SCM_LIST1 (SCM_I_MAKINUM (st.st_size))); | |
91 | ||
8f5cfc81 | 92 | addr = mmap (0, st.st_size, PROT_READ, MAP_SHARED, fd, 0); |
62082959 LC |
93 | if (addr == MAP_FAILED) |
94 | SCM_SYSERROR; | |
95 | ||
96 | if (memcmp (addr, OBJCODE_COOKIE, strlen (OBJCODE_COOKIE))) | |
97 | SCM_SYSERROR; | |
8f5cfc81 | 98 | |
d8eeb67c | 99 | p = scm_gc_malloc (sizeof (struct scm_objcode), "objcode"); |
8f5cfc81 KN |
100 | p->size = st.st_size; |
101 | p->base = addr; | |
102 | p->fd = fd; | |
103 | SCM_RETURN_NEWSMOB (scm_tc16_objcode, p); | |
104 | } | |
105 | #undef FUNC_NAME | |
106 | ||
107 | static scm_sizet | |
108 | objcode_free (SCM obj) | |
109 | #define FUNC_NAME "objcode_free" | |
110 | { | |
d8eeb67c | 111 | size_t size = sizeof (struct scm_objcode); |
8f5cfc81 KN |
112 | struct scm_objcode *p = SCM_OBJCODE_DATA (obj); |
113 | ||
114 | if (p->fd >= 0) | |
115 | { | |
116 | int rv; | |
117 | rv = munmap (p->base, p->size); | |
118 | if (rv < 0) SCM_SYSERROR; | |
119 | rv = close (p->fd); | |
120 | if (rv < 0) SCM_SYSERROR; | |
121 | } | |
122 | else | |
d8eeb67c LC |
123 | scm_gc_free (p->base, p->size, "objcode-base"); |
124 | ||
125 | scm_gc_free (p, size, "objcode"); | |
8f5cfc81 | 126 | |
d8eeb67c | 127 | return 0; |
8f5cfc81 KN |
128 | } |
129 | #undef FUNC_NAME | |
130 | ||
131 | \f | |
132 | /* | |
133 | * Scheme interface | |
134 | */ | |
135 | ||
135b32ee LC |
136 | #if 0 |
137 | SCM_DEFINE (scm_do_pair, "do-pair", 2, 0, 0, | |
138 | (SCM car, SCM cdr), | |
139 | "This is a stupid test to see how cells work. (Ludo)") | |
140 | { | |
141 | static SCM room[512]; | |
142 | static SCM *where = &room[0]; | |
143 | SCM the_pair; | |
144 | size_t incr; | |
145 | ||
146 | if ((scm_t_bits)where & 6) | |
147 | { | |
148 | /* Align the cell pointer so that Guile considers it as a | |
149 | non-immediate object (see tags.h). */ | |
150 | incr = (scm_t_bits)where & 6; | |
151 | incr = (~incr) & 7; | |
152 | where += incr; | |
153 | } | |
154 | ||
155 | printf ("do-pair: pool @ %p, pair @ %p\n", &room[0], where); | |
156 | where[0] = car; | |
157 | where[1] = cdr; | |
158 | ||
159 | the_pair = PTR2SCM (where); | |
160 | /* This doesn't work because SCM_SET_GC_MARK will look for some sort of a | |
161 | "mark bitmap" at the end of a supposed cell segment which doesn't | |
162 | exist. */ | |
163 | ||
164 | return (the_pair); | |
165 | } | |
166 | #endif | |
167 | ||
8f5cfc81 KN |
168 | SCM_DEFINE (scm_objcode_p, "objcode?", 1, 0, 0, |
169 | (SCM obj), | |
170 | "") | |
171 | #define FUNC_NAME s_scm_objcode_p | |
172 | { | |
173 | return SCM_BOOL (SCM_OBJCODE_P (obj)); | |
174 | } | |
175 | #undef FUNC_NAME | |
176 | ||
177 | SCM_DEFINE (scm_bytecode_to_objcode, "bytecode->objcode", 3, 0, 0, | |
178 | (SCM bytecode, SCM nlocs, SCM nexts), | |
179 | "") | |
180 | #define FUNC_NAME s_scm_bytecode_to_objcode | |
181 | { | |
182 | size_t size; | |
054599f1 LC |
183 | ssize_t increment; |
184 | scm_t_array_handle handle; | |
185 | char *base; | |
b6368dbb | 186 | const scm_t_uint8 *c_bytecode; |
8f5cfc81 KN |
187 | SCM objcode; |
188 | ||
054599f1 LC |
189 | if (scm_u8vector_p (bytecode) != SCM_BOOL_T) |
190 | scm_wrong_type_arg (FUNC_NAME, 1, bytecode); | |
62082959 LC |
191 | SCM_VALIDATE_NUMBER (2, nlocs); |
192 | SCM_VALIDATE_NUMBER (3, nexts); | |
8f5cfc81 | 193 | |
054599f1 LC |
194 | c_bytecode = scm_u8vector_elements (bytecode, &handle, &size, &increment); |
195 | assert (increment == 1); | |
196 | ||
fa19602c LC |
197 | /* Account for the 10 byte-long header. */ |
198 | size += 10; | |
8f5cfc81 KN |
199 | objcode = make_objcode (size); |
200 | base = SCM_OBJCODE_BASE (objcode); | |
201 | ||
202 | memcpy (base, OBJCODE_COOKIE, 8); | |
62082959 LC |
203 | base[8] = scm_to_uint8 (nlocs); |
204 | base[9] = scm_to_uint8 (nexts); | |
d8eeb67c | 205 | |
d8eeb67c | 206 | memcpy (base + 10, c_bytecode, size - 10); |
054599f1 LC |
207 | |
208 | scm_array_handle_release (&handle); | |
d8eeb67c | 209 | |
8f5cfc81 KN |
210 | return objcode; |
211 | } | |
212 | #undef FUNC_NAME | |
213 | ||
214 | SCM_DEFINE (scm_load_objcode, "load-objcode", 1, 0, 0, | |
215 | (SCM file), | |
216 | "") | |
217 | #define FUNC_NAME s_scm_load_objcode | |
218 | { | |
219 | int fd; | |
2d80426a | 220 | char *c_file; |
8f5cfc81 KN |
221 | |
222 | SCM_VALIDATE_STRING (1, file); | |
223 | ||
2d80426a LC |
224 | c_file = scm_to_locale_string (file); |
225 | fd = open (c_file, O_RDONLY); | |
226 | free (c_file); | |
8f5cfc81 KN |
227 | if (fd < 0) SCM_SYSERROR; |
228 | ||
229 | return make_objcode_by_mmap (fd); | |
230 | } | |
231 | #undef FUNC_NAME | |
232 | ||
054599f1 | 233 | SCM_DEFINE (scm_objcode_to_u8vector, "objcode->u8vector", 1, 0, 0, |
8f5cfc81 KN |
234 | (SCM objcode), |
235 | "") | |
054599f1 | 236 | #define FUNC_NAME s_scm_objcode_to_u8vector |
8f5cfc81 | 237 | { |
b6368dbb | 238 | scm_t_uint8 *u8vector; |
054599f1 LC |
239 | size_t size; |
240 | ||
8f5cfc81 | 241 | SCM_VALIDATE_OBJCODE (1, objcode); |
054599f1 LC |
242 | |
243 | size = SCM_OBJCODE_SIZE (objcode); | |
244 | /* FIXME: Is `gc_malloc' ok here? */ | |
245 | u8vector = scm_gc_malloc (size, "objcode-u8vector"); | |
246 | memcpy (u8vector, SCM_OBJCODE_BASE (objcode), size); | |
247 | ||
248 | return scm_take_u8vector (u8vector, size); | |
8f5cfc81 KN |
249 | } |
250 | #undef FUNC_NAME | |
251 | ||
252 | SCM_DEFINE (scm_objcode_to_program, "objcode->program", 1, 0, 0, | |
253 | (SCM objcode), | |
254 | "") | |
255 | #define FUNC_NAME s_scm_objcode_to_program | |
256 | { | |
257 | SCM prog; | |
258 | size_t size; | |
259 | char *base; | |
ac99cb0c | 260 | struct scm_program *p; |
8f5cfc81 KN |
261 | |
262 | SCM_VALIDATE_OBJCODE (1, objcode); | |
263 | ||
264 | base = SCM_OBJCODE_BASE (objcode); | |
265 | size = SCM_OBJCODE_SIZE (objcode); | |
266 | prog = scm_c_make_program (base + 10, size - 10, objcode); | |
ac99cb0c KN |
267 | p = SCM_PROGRAM_DATA (prog); |
268 | p->nlocs = base[8]; | |
269 | p->nexts = base[9]; | |
8f5cfc81 KN |
270 | return prog; |
271 | } | |
272 | #undef FUNC_NAME | |
273 | ||
274 | \f | |
275 | void | |
276 | scm_init_objcodes (void) | |
277 | { | |
278 | scm_tc16_objcode = scm_make_smob_type ("objcode", 0); | |
279 | scm_set_smob_free (scm_tc16_objcode, objcode_free); | |
280 | ||
281 | #ifndef SCM_MAGIC_SNARFER | |
282 | #include "objcodes.x" | |
283 | #endif | |
284 | } | |
285 | ||
286 | /* | |
287 | Local Variables: | |
288 | c-file-style: "gnu" | |
289 | End: | |
290 | */ |