1 /* -*-C-*-
2
3 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
4 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
5 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014 Massachusetts
6 Institute of Technology
7
8 This file is part of MIT/GNU Scheme.
9
10 MIT/GNU Scheme is free software; you can redistribute it and/or modify
11 it under the terms of the GNU General Public License as published by
12 the Free Software Foundation; either version 2 of the License, or (at
13 your option) any later version.
14
15 MIT/GNU Scheme is distributed in the hope that it will be useful, but
16 WITHOUT ANY WARRANTY; without even the implied warranty of
17 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
18 General Public License for more details.
19
20 You should have received a copy of the GNU General Public License
21 along with MIT/GNU Scheme; if not, write to the Free Software
22 Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
23 USA.
24
25 */
26
27 /* Compiled Code Utilities */
28
29 #include "scheme.h"
30 #include "osscheme.h"
31 #include "prims.h"
32
33 #ifdef CC_IS_C
34 extern unsigned long liarc_n_compiled_blocks (void);
35 extern void get_liarc_compiled_block_data
36 (unsigned long, const char **, void **, void **, void **);
37 #endif
38
39 DEFINE_PRIMITIVE ("COMPILED-CODE-ADDRESS->BLOCK", Prim_comp_code_address_block,
40 1, 1, "(ADDRESS)\n\
41 Given a compiled-code entry ADDRESS, return its block.")
42 {
43 PRIMITIVE_HEADER (1);
44 CHECK_ARG (1, CC_ENTRY_P);
45 PRIMITIVE_RETURN (cc_entry_to_block (ARG_REF (1)));
46 }
47
48 DEFINE_PRIMITIVE ("COMPILED-CODE-ADDRESS->OFFSET",
49 Prim_comp_code_address_offset, 1, 1, "(ADDRESS)\n\
50 Given a compiled-code entry ADDRESS, return its offset into its block.")
51 {
52 PRIMITIVE_HEADER (1);
53 CHECK_ARG (1, CC_ENTRY_P);
54 PRIMITIVE_RETURN (ULONG_TO_FIXNUM (cc_entry_to_block_offset (ARG_REF (1))));
55 }
56
57 DEFINE_PRIMITIVE ("STACK-TOP-ADDRESS", Prim_stack_top_address, 0, 0, 0)
58 {
59 PRIMITIVE_HEADER (0);
60 PRIMITIVE_RETURN (ulong_to_integer (ADDRESS_TO_DATUM (STACK_BOTTOM)));
61 }
62
63 DEFINE_PRIMITIVE ("STACK-ADDRESS-OFFSET", Prim_stack_address_offset, 1, 1, 0)
64 {
65 PRIMITIVE_HEADER (1);
66
67 CHECK_ARG (1, CC_STACK_ENV_P);
68 {
69 SCHEME_OBJECT * address = (OBJECT_ADDRESS (ARG_REF (1)));
70 if (!ADDRESS_IN_STACK_P (address))
71 error_bad_range_arg (1);
72 PRIMITIVE_RETURN
73 (ulong_to_integer (SP_TO_N_PUSHED (address, stack_start, stack_end)));
74 }
75 }
76
77 DEFINE_PRIMITIVE ("COMPILED-ENTRY-KIND", Prim_compiled_entry_kind, 1, 1, 0)
78 {
79 PRIMITIVE_HEADER (1);
80 CHECK_ARG (1, CC_ENTRY_P);
81 {
82 cc_entry_type_t cet;
83 unsigned long kind = 4;
84 unsigned long field1 = 0;
85 long field2 = 0;
86
87 if (!read_cc_entry_type ((&cet), (CC_ENTRY_ADDRESS (ARG_REF (1)))))
88 switch (cet.marker)
89 {
90 case CET_PROCEDURE:
91 kind = 0;
92 field1 = (1 + (cet.args.for_procedure.n_required));
93 field2 = (field1 + (cet.args.for_procedure.n_optional));
94 if (cet.args.for_procedure.rest_p)
95 field2 = (- (field2 + 1));
96 break;
97
98 case CET_CONTINUATION:
99 kind = 1;
100 field1 = 0;
101 field2 = (cet.args.for_continuation.offset);
102 break;
103
104 case CET_EXPRESSION:
105 kind = 2;
106 field1 = 0;
107 field2 = 0;
108 break;
109
110 case CET_INTERNAL_CONTINUATION:
111 kind = 1;
112 field1 = 1;
113 field2 = (-1);
114 break;
115
116 case CET_INTERNAL_PROCEDURE:
117 case CET_TRAMPOLINE:
118 kind = 3;
119 field1 = 1;
120 field2 = 0;
121 break;
122
123 case CET_RETURN_TO_INTERPRETER:
124 kind = 1;
125 field1 = 2;
126 field2 = ((ARG_REF (1)) != return_to_interpreter);
127 break;
128
129 case CET_CLOSURE:
130 kind = 3;
131 field1 = 0;
132 field2 = 0;
133 break;
134 }
135 PRIMITIVE_RETURN
136 (hunk3_cons ((ULONG_TO_FIXNUM (kind)),
137 (ULONG_TO_FIXNUM (field1)),
138 (LONG_TO_FIXNUM (field2))));
139 }
140 }
141
142 DEFINE_PRIMITIVE ("COERCE-TO-COMPILED-PROCEDURE", Prim_coerce_to_closure, 2, 2,
143 0)
144 {
145 PRIMITIVE_HEADER (2);
146 {
147 SCHEME_OBJECT temp;
148 long result
149 = (coerce_to_compiled ((ARG_REF (1)), (arg_ulong_integer (2)), (&temp)));
150 switch (result)
151 {
152 case PRIM_DONE:
153 break;
154
155 case PRIM_INTERRUPT:
156 Primitive_GC (10);
157 /*NOTREACHED*/
158 break;
159
160 default:
161 error_bad_range_arg (2);
162 /*NOTREACHED*/
163 break;
164 }
165 PRIMITIVE_RETURN (temp);
166 }
167 }
168
169 DEFINE_PRIMITIVE ("COMPILED-CLOSURE->ENTRY", Prim_cc_closure_to_entry, 1, 1,
170 "Given a compiled closure, return the entry point which it invokes.")
171 {
172 PRIMITIVE_HEADER (1);
173 CHECK_ARG (1, CC_ENTRY_P);
174 if (!cc_entry_closure_p (ARG_REF (1)))
175 error_bad_range_arg (1);
176 PRIMITIVE_RETURN (cc_closure_to_entry (ARG_REF (1)));
177 }
178
179 DEFINE_PRIMITIVE ("UTILITY-INDEX->NAME", Prim_utility_index_to_name, 1, 1, 0)
180 {
181 PRIMITIVE_HEADER (1);
182 {
183 const char * name = (utility_index_to_name (arg_ulong_integer (1)));
184 PRIMITIVE_RETURN ((name == 0) ? SHARP_F : (char_pointer_to_string (name)));
185 }
186 }
187
188 DEFINE_PRIMITIVE ("BUILTIN-INDEX->NAME", Prim_builtin_index_to_name, 1, 1, 0)
189 {
190 PRIMITIVE_HEADER (1);
191 {
192 const char * name = (builtin_index_to_name (arg_ulong_integer (1)));
193 PRIMITIVE_RETURN ((name == 0) ? SHARP_F : (char_pointer_to_string (name)));
194 }
195 }
196
197 DEFINE_PRIMITIVE ("INITIALIZE-C-COMPILED-BLOCK",
198 Prim_initialize_C_compiled_block, 1, 1,
199 "Given the tag of a compiled object, return the object.")
200 {
201 PRIMITIVE_HEADER (1);
202 #ifdef CC_IS_C
203 PRIMITIVE_RETURN (initialize_C_compiled_block (STRING_ARG (1)));
204 #else
205 PRIMITIVE_RETURN (SHARP_F);
206 #endif
207 }
208
209 typedef unsigned long thunk_t (void);
210 static const char * ilof_prefix = 0;
211
212 DEFINE_PRIMITIVE ("INITIALIZE-LIARC-OBJECT-FILE", Prim_initialize_liarc_object_file, 2, 2,
213 "(ADDRESS PREFIX)\n\
214 Run the object-file initialization thunk specified by ADDRESS,\n\
215 using PREFIX as the rewriting prefix for the subparts.")
216 {
217 PRIMITIVE_HEADER (2);
218 {
219 thunk_t * thunk = ((thunk_t *) (arg_ulong_integer (1)));
220 const char * prefix = (STRING_ARG (2));
221 void * p = dstack_position;
222 dstack_bind ((&ilof_prefix), ((void *) prefix));
223 {
224 unsigned long value = ((*thunk) ());
225 dstack_set_position (p);
226 PRIMITIVE_RETURN (ulong_to_integer (value));
227 }
228 }
229 }
230
231 const char *
liarc_object_file_prefix(void)232 liarc_object_file_prefix (void)
233 {
234 return (ilof_prefix);
235 }
236
237
238 DEFINE_PRIMITIVE ("DECLARE-COMPILED-CODE-BLOCK",
239 Prim_declare_compiled_code_block, 1, 1,
240 "Ensure cache coherence for a compiled-code block newly constructed.")
241 {
242 PRIMITIVE_HEADER (1);
243 {
244 SCHEME_OBJECT new_cc_block = (ARG_REF (1));
245 if (!CC_BLOCK_P (new_cc_block))
246 error_wrong_type_arg (1);
247 declare_compiled_code_block (new_cc_block);
248 PRIMITIVE_RETURN (SHARP_T);
249 }
250 }
251
252 DEFINE_PRIMITIVE ("LIARC-COMPILED-BLOCKS", Prim_liarc_compiled_code_blocks,
253 0, 0,
254 "Return a vector containing the names of registered compiled-code blocks.")
255 {
256 PRIMITIVE_HEADER (0);
257 #ifdef CC_IS_C
258 {
259 unsigned long n = (liarc_n_compiled_blocks ());
260 SCHEME_OBJECT v = (allocate_marked_vector (TC_VECTOR, n, true));
261 unsigned long i;
262 const char * name;
263 void * code_proc;
264 void * data_proc;
265 void * object_proc;
266
267 for (i = 0; (i < n); i += 1)
268 VECTOR_SET (v, i, (allocate_marked_vector (TC_VECTOR, 4, true)));
269
270 for (i = 0; (i < n); i += 1)
271 {
272 SCHEME_OBJECT vi = (VECTOR_REF (v, i));
273 get_liarc_compiled_block_data
274 (i, (&name), (&code_proc), (&data_proc), (&object_proc));
275 VECTOR_SET (vi, 0, (char_pointer_to_string (name)));
276 VECTOR_SET (vi, 1,
277 ((code_proc == 0)
278 ? SHARP_F
279 : (ulong_to_integer ((unsigned long) code_proc))));
280 VECTOR_SET (vi, 2,
281 ((data_proc == 0)
282 ? SHARP_F
283 : (ulong_to_integer ((unsigned long) data_proc))));
284 VECTOR_SET (vi, 3,
285 ((object_proc == 0)
286 ? SHARP_F
287 : (ulong_to_integer ((unsigned long) object_proc))));
288 }
289
290 PRIMITIVE_RETURN (v);
291 }
292 #else
293 error_unimplemented_primitive ();
294 PRIMITIVE_RETURN (UNSPECIFIC);
295 #endif
296 }
297
298 DEFINE_PRIMITIVE ("BKPT/INSTALL", Prim_install_bkpt, 1, 1,
299 "(compiled-entry-object)\n\
300 Install a breakpoint trap in a compiled code object.\n\
301 Returns false or a handled needed by REMOVE-BKPT and ONE-STEP-PROCEED.")
302 {
303 PRIMITIVE_HEADER (1);
304 CHECK_ARG (1, CC_ENTRY_P);
305
306 {
307 SCHEME_OBJECT * entry = (OBJECT_ADDRESS (ARG_REF (1)));
308 SCHEME_OBJECT * block;
309
310 if (bkpt_p ((void *) entry))
311 error_bad_range_arg (1);
312
313 block = (cc_entry_to_block_address (ARG_REF (1)));
314 if ((OBJECT_TYPE (block[0])) == TC_MANIFEST_CLOSURE)
315 PRIMITIVE_RETURN (bkpt_closure_install ((void *) entry));
316 else
317 PRIMITIVE_RETURN (bkpt_install ((void *) entry));
318 }
319 }
320
321 DEFINE_PRIMITIVE ("BKPT/REMOVE", Prim_remove_bkpt, 2, 2,
322 "(compiled-entry-object handle)\n\
323 Remove a breakpoint trap installed by INSTALL-BKPT.")
324 {
325 PRIMITIVE_HEADER (2);
326 CHECK_ARG (1, CC_ENTRY_P);
327 CHECK_ARG (2, NON_MARKED_VECTOR_P);
328
329 {
330 SCHEME_OBJECT * entry = (OBJECT_ADDRESS (ARG_REF (1)));
331 SCHEME_OBJECT handle = (ARG_REF (2));
332
333 if (! (bkpt_p ((void *) entry)))
334 error_bad_range_arg (1);
335 bkpt_remove (((void *) entry), handle);
336 PRIMITIVE_RETURN (UNSPECIFIC);
337 }
338 }
339
340 DEFINE_PRIMITIVE ("BKPT?", Prim_bkpt_p, 1, 1,
341 "(compiled-entry-object)\n\
342 True if there is a breakpoint trap in compiled-entry-object.")
343 {
344 PRIMITIVE_HEADER (1);
345 CHECK_ARG (1, CC_ENTRY_P);
346
347 PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT
348 (bkpt_p ((void *) (OBJECT_ADDRESS (ARG_REF (1))))));
349 }
350
351 DEFINE_PRIMITIVE ("BKPT/PROCEED", Prim_bkpt_proceed, 3, 3,
352 "(compiled-entry-object handle state)\n\
353 Proceed the computation from the current breakpoint.")
354 {
355 PRIMITIVE_HEADER (3);
356 CHECK_ARG (1, CC_ENTRY_P);
357 CHECK_ARG (2, NON_MARKED_VECTOR_P);
358
359 PRIMITIVE_RETURN (bkpt_proceed (((void *) (OBJECT_ADDRESS (ARG_REF (1)))),
360 (ARG_REF (2)),
361 (ARG_REF (3))));
362 }
363