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); | |
62082959 LC |
85 | if ((ret < 0) || (st.st_size <= strlen (OBJCODE_COOKIE))) |
86 | SCM_SYSERROR; | |
8f5cfc81 KN |
87 | |
88 | addr = mmap (0, st.st_size, PROT_READ, MAP_SHARED, fd, 0); | |
62082959 LC |
89 | if (addr == MAP_FAILED) |
90 | SCM_SYSERROR; | |
91 | ||
92 | if (memcmp (addr, OBJCODE_COOKIE, strlen (OBJCODE_COOKIE))) | |
93 | SCM_SYSERROR; | |
8f5cfc81 | 94 | |
d8eeb67c | 95 | p = scm_gc_malloc (sizeof (struct scm_objcode), "objcode"); |
8f5cfc81 KN |
96 | p->size = st.st_size; |
97 | p->base = addr; | |
98 | p->fd = fd; | |
99 | SCM_RETURN_NEWSMOB (scm_tc16_objcode, p); | |
100 | } | |
101 | #undef FUNC_NAME | |
102 | ||
103 | static scm_sizet | |
104 | objcode_free (SCM obj) | |
105 | #define FUNC_NAME "objcode_free" | |
106 | { | |
d8eeb67c | 107 | size_t size = sizeof (struct scm_objcode); |
8f5cfc81 KN |
108 | struct scm_objcode *p = SCM_OBJCODE_DATA (obj); |
109 | ||
110 | if (p->fd >= 0) | |
111 | { | |
112 | int rv; | |
113 | rv = munmap (p->base, p->size); | |
114 | if (rv < 0) SCM_SYSERROR; | |
115 | rv = close (p->fd); | |
116 | if (rv < 0) SCM_SYSERROR; | |
117 | } | |
118 | else | |
d8eeb67c LC |
119 | scm_gc_free (p->base, p->size, "objcode-base"); |
120 | ||
121 | scm_gc_free (p, size, "objcode"); | |
8f5cfc81 | 122 | |
d8eeb67c | 123 | return 0; |
8f5cfc81 KN |
124 | } |
125 | #undef FUNC_NAME | |
126 | ||
127 | \f | |
128 | /* | |
129 | * Scheme interface | |
130 | */ | |
131 | ||
135b32ee LC |
132 | #if 0 |
133 | SCM_DEFINE (scm_do_pair, "do-pair", 2, 0, 0, | |
134 | (SCM car, SCM cdr), | |
135 | "This is a stupid test to see how cells work. (Ludo)") | |
136 | { | |
137 | static SCM room[512]; | |
138 | static SCM *where = &room[0]; | |
139 | SCM the_pair; | |
140 | size_t incr; | |
141 | ||
142 | if ((scm_t_bits)where & 6) | |
143 | { | |
144 | /* Align the cell pointer so that Guile considers it as a | |
145 | non-immediate object (see tags.h). */ | |
146 | incr = (scm_t_bits)where & 6; | |
147 | incr = (~incr) & 7; | |
148 | where += incr; | |
149 | } | |
150 | ||
151 | printf ("do-pair: pool @ %p, pair @ %p\n", &room[0], where); | |
152 | where[0] = car; | |
153 | where[1] = cdr; | |
154 | ||
155 | the_pair = PTR2SCM (where); | |
156 | /* This doesn't work because SCM_SET_GC_MARK will look for some sort of a | |
157 | "mark bitmap" at the end of a supposed cell segment which doesn't | |
158 | exist. */ | |
159 | ||
160 | return (the_pair); | |
161 | } | |
162 | #endif | |
163 | ||
8f5cfc81 KN |
164 | SCM_DEFINE (scm_objcode_p, "objcode?", 1, 0, 0, |
165 | (SCM obj), | |
166 | "") | |
167 | #define FUNC_NAME s_scm_objcode_p | |
168 | { | |
169 | return SCM_BOOL (SCM_OBJCODE_P (obj)); | |
170 | } | |
171 | #undef FUNC_NAME | |
172 | ||
173 | SCM_DEFINE (scm_bytecode_to_objcode, "bytecode->objcode", 3, 0, 0, | |
174 | (SCM bytecode, SCM nlocs, SCM nexts), | |
175 | "") | |
176 | #define FUNC_NAME s_scm_bytecode_to_objcode | |
177 | { | |
178 | size_t size; | |
054599f1 LC |
179 | ssize_t increment; |
180 | scm_t_array_handle handle; | |
181 | char *base; | |
182 | const char *c_bytecode; | |
8f5cfc81 KN |
183 | SCM objcode; |
184 | ||
054599f1 LC |
185 | if (scm_u8vector_p (bytecode) != SCM_BOOL_T) |
186 | scm_wrong_type_arg (FUNC_NAME, 1, bytecode); | |
62082959 LC |
187 | SCM_VALIDATE_NUMBER (2, nlocs); |
188 | SCM_VALIDATE_NUMBER (3, nexts); | |
8f5cfc81 | 189 | |
054599f1 LC |
190 | c_bytecode = scm_u8vector_elements (bytecode, &handle, &size, &increment); |
191 | assert (increment == 1); | |
192 | ||
fa19602c LC |
193 | /* Account for the 10 byte-long header. */ |
194 | size += 10; | |
8f5cfc81 KN |
195 | objcode = make_objcode (size); |
196 | base = SCM_OBJCODE_BASE (objcode); | |
197 | ||
198 | memcpy (base, OBJCODE_COOKIE, 8); | |
62082959 LC |
199 | base[8] = scm_to_uint8 (nlocs); |
200 | base[9] = scm_to_uint8 (nexts); | |
d8eeb67c | 201 | |
d8eeb67c | 202 | memcpy (base + 10, c_bytecode, size - 10); |
054599f1 LC |
203 | |
204 | scm_array_handle_release (&handle); | |
d8eeb67c | 205 | |
8f5cfc81 KN |
206 | return objcode; |
207 | } | |
208 | #undef FUNC_NAME | |
209 | ||
210 | SCM_DEFINE (scm_load_objcode, "load-objcode", 1, 0, 0, | |
211 | (SCM file), | |
212 | "") | |
213 | #define FUNC_NAME s_scm_load_objcode | |
214 | { | |
215 | int fd; | |
2d80426a | 216 | char *c_file; |
8f5cfc81 KN |
217 | |
218 | SCM_VALIDATE_STRING (1, file); | |
219 | ||
2d80426a LC |
220 | c_file = scm_to_locale_string (file); |
221 | fd = open (c_file, O_RDONLY); | |
222 | free (c_file); | |
8f5cfc81 KN |
223 | if (fd < 0) SCM_SYSERROR; |
224 | ||
225 | return make_objcode_by_mmap (fd); | |
226 | } | |
227 | #undef FUNC_NAME | |
228 | ||
054599f1 | 229 | SCM_DEFINE (scm_objcode_to_u8vector, "objcode->u8vector", 1, 0, 0, |
8f5cfc81 KN |
230 | (SCM objcode), |
231 | "") | |
054599f1 | 232 | #define FUNC_NAME s_scm_objcode_to_u8vector |
8f5cfc81 | 233 | { |
054599f1 LC |
234 | char *u8vector; |
235 | size_t size; | |
236 | ||
8f5cfc81 | 237 | SCM_VALIDATE_OBJCODE (1, objcode); |
054599f1 LC |
238 | |
239 | size = SCM_OBJCODE_SIZE (objcode); | |
240 | /* FIXME: Is `gc_malloc' ok here? */ | |
241 | u8vector = scm_gc_malloc (size, "objcode-u8vector"); | |
242 | memcpy (u8vector, SCM_OBJCODE_BASE (objcode), size); | |
243 | ||
244 | return scm_take_u8vector (u8vector, size); | |
8f5cfc81 KN |
245 | } |
246 | #undef FUNC_NAME | |
247 | ||
248 | SCM_DEFINE (scm_objcode_to_program, "objcode->program", 1, 0, 0, | |
249 | (SCM objcode), | |
250 | "") | |
251 | #define FUNC_NAME s_scm_objcode_to_program | |
252 | { | |
253 | SCM prog; | |
254 | size_t size; | |
255 | char *base; | |
ac99cb0c | 256 | struct scm_program *p; |
8f5cfc81 KN |
257 | |
258 | SCM_VALIDATE_OBJCODE (1, objcode); | |
259 | ||
260 | base = SCM_OBJCODE_BASE (objcode); | |
261 | size = SCM_OBJCODE_SIZE (objcode); | |
262 | prog = scm_c_make_program (base + 10, size - 10, objcode); | |
ac99cb0c KN |
263 | p = SCM_PROGRAM_DATA (prog); |
264 | p->nlocs = base[8]; | |
265 | p->nexts = base[9]; | |
8f5cfc81 KN |
266 | return prog; |
267 | } | |
268 | #undef FUNC_NAME | |
269 | ||
270 | \f | |
271 | void | |
272 | scm_init_objcodes (void) | |
273 | { | |
274 | scm_tc16_objcode = scm_make_smob_type ("objcode", 0); | |
275 | scm_set_smob_free (scm_tc16_objcode, objcode_free); | |
276 | ||
277 | #ifndef SCM_MAGIC_SNARFER | |
278 | #include "objcodes.x" | |
279 | #endif | |
280 | } | |
281 | ||
282 | /* | |
283 | Local Variables: | |
284 | c-file-style: "gnu" | |
285 | End: | |
286 | */ |