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