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 interface for SVM v1. */
28
29 #include "cmpint.h"
30 #include "extern.h"
31 #include "errors.h"
32 #include "svm1-defns.h"
33
34 static void write_u16 (unsigned int, insn_t *);
35
36 bool
read_cc_entry_type(cc_entry_type_t * cet,insn_t * address)37 read_cc_entry_type (cc_entry_type_t * cet, insn_t * address)
38 {
39 unsigned int n;
40
41 if ((*address) == SVM1_INST_ENTER_CLOSURE)
42 {
43 n = read_u16 (address - 2);
44 make_compiled_procedure_type
45 (cet, (n & 0x007F), ((n & 0x3F80) >> 7), ((n & 0x4000) != 0));
46 return (false);
47 }
48 n = (read_u16 (address - 4));
49 if (n < 0x8000)
50 make_compiled_procedure_type
51 (cet,
52 (n & 0x007F),
53 ((n & 0x3F80) >> 7),
54 ((n & 0x4000) != 0));
55 else if (n < 0xFFF8)
56 make_compiled_continuation_type (cet, (n - 0x8000));
57 else
58 switch (n - 0xFFF8)
59 {
60 case 6:
61 make_cc_entry_type (cet, CET_EXPRESSION);
62 break;
63
64 case 5:
65 make_cc_entry_type (cet, CET_INTERNAL_PROCEDURE);
66 break;
67
68 case 4:
69 make_cc_entry_type (cet, CET_INTERNAL_CONTINUATION);
70 break;
71
72 case 3:
73 make_cc_entry_type (cet, CET_TRAMPOLINE);
74 break;
75
76 case 2:
77 make_cc_entry_type (cet, CET_RETURN_TO_INTERPRETER);
78 break;
79
80 default:
81 return (true);
82 }
83 return (false);
84 }
85
86 /* This is used only for creating trampolines. */
87
88 bool
write_cc_entry_type(cc_entry_type_t * cet,insn_t * address)89 write_cc_entry_type (cc_entry_type_t * cet, insn_t * address)
90 {
91 unsigned int n;
92
93 switch (cet->marker)
94 {
95 case CET_PROCEDURE:
96 if (! (((cet->args.for_procedure.n_required) < 0x80)
97 && ((cet->args.for_procedure.n_optional) < 0x80)))
98 return (true);
99 n = ((cet->args.for_procedure.n_required)
100 | ((cet->args.for_procedure.n_optional) << 7)
101 | ((cet->args.for_procedure.rest_p) ? 0x4000 : 0));
102 break;
103
104 case CET_CONTINUATION:
105 if (! ((cet->args.for_continuation.offset) < 0x7FF8))
106 return (true);
107 n = ((cet->args.for_continuation.offset) + 0x8000);
108 break;
109
110 case CET_EXPRESSION:
111 n = (0xFFF8 + 6);
112 break;
113
114 case CET_INTERNAL_PROCEDURE:
115 n = (0xFFF8 + 5);
116 break;
117
118 case CET_INTERNAL_CONTINUATION:
119 n = (0xFFF8 + 4);
120 break;
121
122 case CET_TRAMPOLINE:
123 n = (0xFFF8 + 3);
124 break;
125
126 case CET_RETURN_TO_INTERPRETER:
127 n = (0xFFF8 + 2);
128 break;
129
130 default:
131 return (true);
132 }
133 write_u16 (n, (address - 4));
134 return (false);
135 }
136
137 bool
read_cc_entry_offset(cc_entry_offset_t * ceo,insn_t * address)138 read_cc_entry_offset (cc_entry_offset_t * ceo, insn_t * address)
139 {
140 if ((*address) == SVM1_INST_ENTER_CLOSURE)
141 {
142 unsigned int index = (read_u16 (address + 1));
143 (ceo->offset)
144 = ((sizeof (SCHEME_OBJECT))
145 + CLOSURE_ENTRY_OFFSET + (index * CLOSURE_ENTRY_SIZE));
146 (ceo->continued_p) = false;
147 }
148 else
149 {
150 unsigned int n = (read_u16 (address - 2));
151 ceo->offset = (n >> 1);
152 ceo->continued_p = ((n & 1) != 0);
153 }
154 return (false);
155 }
156
157 /* This is used only for creating trampolines. */
158
159 bool
write_cc_entry_offset(cc_entry_offset_t * ceo,insn_t * address)160 write_cc_entry_offset (cc_entry_offset_t * ceo, insn_t * address)
161 {
162 unsigned int code = (ceo->offset) << 1;
163 write_u16 (code + (ceo->continued_p ? 1 : 0), address - 2);
164 return (false);
165 }
166
167 unsigned int
read_u16(insn_t * address)168 read_u16 (insn_t * address)
169 {
170 return
171 ((((unsigned int) (address[1])) << 8)
172 | ((unsigned int) (address[0])));
173 }
174
175 static void
write_u16(unsigned int n,insn_t * address)176 write_u16 (unsigned int n, insn_t * address)
177 {
178 (address[0]) = (n & 0x00FF);
179 (address[1]) = (n >> 8);
180 }
181
182 /* Compiled closures
183
184 A compiled-closure block starts with a single GC header
185 (TC_MANIFEST_CLOSURE), followed by a 2-byte count, followed by the
186 closure entries (as specified by the count). The closure entries
187 refer to their targets indirectly: the targets appear in sequence
188 after all of the entries and are stored as Scheme objects.
189
190 For example, on a 32-bit machine with count == 3 and 4 value cells:
191
192 0x00 TC_MANIFEST_CLOSURE | n_words == 12
193
194 0x04 count == 3
195 0x06 2 cc-entry type bytes (next address must be word-aligned)
196
197 0x08 SVM1_INST_ENTER_CLOSURE
198 0x09 index == 0
199
200 0x0B 2 cc-entry type (arity) bytes
201 0x0D SVM1_INST_ENTER_CLOSURE
202 0x0E index == 1
203
204 0x10 2 cc-entry type (arity) bytes
205 0x12 SVM1_INST_ENTER_CLOSURE
206 0x13 index == 2
207
208 0x15 3 padding bytes (next address must be word-aligned)
209
210 0x18 target 0
211 0x1C target 1
212 0x20 target 2
213
214 0x24 value cell 0
215 0x28 value cell 1
216 0x2C value cell 2
217 0x30 value cell 3
218
219 On a 64-bit machine:
220
221 0x00 TC_MANIFEST_CLOSURE | n_words == 10
222
223 0x08 count == 3
224 0x0A 4 unused bytes
225 0x0E 2 cc-entry type (arity) bytes
226
227 0x10 SVM1_INST_ENTER_CLOSURE (this first entry must be word aligned)
228 0x11 index == 0
229 0x13 2 cc-entry type (arity) bytes
230 0x15 SVM1_INST_ENTER_CLOSURE
231 0x16 index == 1
232
233 0x18 2 cc-entry type (arity) bytes
234 0x1A SVM1_INST_ENTER_CLOSURE
235 0x1B index == 2
236 0x1D 3 padding bytes
237
238 0x20 target 0
239 0x28 target 1
240 0x30 target 2
241
242 0x38 value cell 0
243 0x40 value cell 1
244 0x48 value cell 2
245 0x50 value cell 3
246
247 */
248
249 unsigned long
compiled_closure_count(SCHEME_OBJECT * block)250 compiled_closure_count (SCHEME_OBJECT * block)
251 {
252 return (read_u16 ((insn_t *) block));
253 }
254
255 insn_t *
compiled_closure_start(SCHEME_OBJECT * block)256 compiled_closure_start (SCHEME_OBJECT * block)
257 {
258 return (((insn_t *) block) + CLOSURE_ENTRY_START);
259 }
260
261 insn_t *
compiled_closure_next(insn_t * start)262 compiled_closure_next (insn_t * start)
263 {
264 return (start + CLOSURE_ENTRY_SIZE);
265 }
266
267 SCHEME_OBJECT *
skip_compiled_closure_padding(insn_t * start)268 skip_compiled_closure_padding (insn_t * start)
269 {
270 return
271 ((SCHEME_OBJECT *)
272 ((((unsigned long) start) + ((sizeof (SCHEME_OBJECT)) - 1))
273 &~ ((sizeof (SCHEME_OBJECT)) - 1)));
274 }
275
276 SCHEME_OBJECT
compiled_closure_entry_to_target(insn_t * entry)277 compiled_closure_entry_to_target (insn_t * entry)
278 {
279 unsigned int index = (read_u16 (entry + 1));
280 insn_t * block
281 = (entry - (CLOSURE_ENTRY_OFFSET + (index * CLOSURE_ENTRY_SIZE)));
282 unsigned int count = (read_u16 (block));
283 SCHEME_OBJECT * targets
284 = (skip_compiled_closure_padding
285 (block + (CLOSURE_ENTRY_START + (count * CLOSURE_ENTRY_SIZE))));
286 return (targets[index]);
287 }
288
289 /* Execution caches (UUO links)
290
291 An execution cache is a region of memory that lives in the
292 constants section of a compiled-code block. It is an indirection
293 for calling external procedures that allows the linker to control
294 the calling process without having to find and change all the
295 places in the compiled code that refer to it.
296
297 Prior to linking, the execution cache has two pieces of
298 information: (1) the name of the procedure being called (a symbol),
299 and (2) the number of arguments that will be passed to the
300 procedure. It is laid out in memory like this (on a 32-bit
301 machine):
302
303 0x00 frame-size (fixnum)
304 0x04 name encoded as symbol
305
306 After linking, the cache is changed as follows:
307
308 0x00 frame-size (u16)
309 0x02 SVM1_INST_IJUMP_U8
310 0x03 offset = 0
311 0x04 32-bit address
312
313 On a 64-bit machine, the post-linking layout is:
314
315 0x00 frame-size (u16)
316 0x02 4 padding bytes
317 0x06 SVM1_INST_IJUMP_U8
318 0x07 offset = 0
319 0x08 64-bit address
320
321 */
322
323 unsigned int
read_uuo_frame_size(SCHEME_OBJECT * saddr)324 read_uuo_frame_size (SCHEME_OBJECT * saddr)
325 {
326 return (read_u16 ((insn_t *) saddr));
327 }
328
329 SCHEME_OBJECT
read_uuo_symbol(SCHEME_OBJECT * saddr)330 read_uuo_symbol (SCHEME_OBJECT * saddr)
331 {
332 return (saddr[1]);
333 }
334
335 insn_t *
read_uuo_target(SCHEME_OBJECT * saddr)336 read_uuo_target (SCHEME_OBJECT * saddr)
337 {
338 insn_t * addr = ((insn_t *) (saddr + 2));
339 insn_t * end = ((insn_t *) (saddr + 1));
340 unsigned long eaddr = 0;
341
342 while (true)
343 {
344 eaddr |= (*--addr);
345 if (addr == end)
346 return ((insn_t *) eaddr);
347 eaddr <<= 8;
348 }
349 }
350
351 insn_t *
read_uuo_target_no_reloc(SCHEME_OBJECT * saddr)352 read_uuo_target_no_reloc (SCHEME_OBJECT * saddr)
353 {
354 return (read_uuo_target (saddr));
355 }
356
357 void
write_uuo_target(insn_t * target,SCHEME_OBJECT * saddr)358 write_uuo_target (insn_t * target, SCHEME_OBJECT * saddr)
359 {
360 unsigned long eaddr = ((unsigned long) target);
361 unsigned long frame_size = (OBJECT_DATUM (saddr[0]));
362 insn_t * addr = ((insn_t *) saddr);
363 insn_t * end = ((insn_t *) (saddr + 1));
364
365 (*addr++) = (frame_size & 0x00FF);
366 (*addr++) = ((frame_size & 0xFF00) >> 8);
367 while (addr < (end - 2))
368 (*addr++) = 0;
369 (*addr++) = SVM1_INST_IJUMP_U8;
370 (*addr++) = 0;
371
372 end = ((insn_t *) (saddr + 2));
373 while (true)
374 {
375 (*addr++) = (eaddr & 0xFF);
376 if (addr == end)
377 break;
378 eaddr >>= 8;
379 }
380 }
381
382 unsigned long
trampoline_entry_size(unsigned long n_entries)383 trampoline_entry_size (unsigned long n_entries)
384 {
385 return (BYTES_TO_WORDS (n_entries * (CC_ENTRY_HEADER_SIZE + 2)));
386 }
387
388 insn_t *
trampoline_entry_addr(SCHEME_OBJECT * block,unsigned long index)389 trampoline_entry_addr (SCHEME_OBJECT * block, unsigned long index)
390 {
391 return (((insn_t *) (block + 2))
392 + (index * (CC_ENTRY_HEADER_SIZE + 2))
393 + CC_ENTRY_HEADER_SIZE);
394 }
395
396 bool
store_trampoline_insns(insn_t * entry,byte_t code)397 store_trampoline_insns (insn_t * entry, byte_t code)
398 {
399 (entry[0]) = SVM1_INST_TRAP_TRAP_0;
400 switch (code)
401 {
402 case TRAMPOLINE_K_RETURN_TO_INTERPRETER:
403 entry[1] = SVM1_TRAP_0_RETURN_TO_INTERPRETER; break;
404 case TRAMPOLINE_K_APPLY:
405 entry[1] = SVM1_TRAP_0_OPERATOR_APPLY; break;
406 case TRAMPOLINE_K_LEXPR_PRIMITIVE:
407 entry[1] = SVM1_TRAP_0_OPERATOR_LEXPR; break;
408 case TRAMPOLINE_K_PRIMITIVE:
409 entry[1] = SVM1_TRAP_0_OPERATOR_PRIMITIVE; break;
410 case TRAMPOLINE_K_LOOKUP:
411 entry[1] = SVM1_TRAP_0_OPERATOR_LOOKUP; break;
412 case TRAMPOLINE_K_1_0:
413 entry[1] = SVM1_TRAP_0_OPERATOR_1_0; break;
414 case TRAMPOLINE_K_2_1:
415 entry[1] = SVM1_TRAP_0_OPERATOR_2_1; break;
416 case TRAMPOLINE_K_2_0:
417 entry[1] = SVM1_TRAP_0_OPERATOR_2_0; break;
418 case TRAMPOLINE_K_3_2:
419 entry[1] = SVM1_TRAP_0_OPERATOR_3_2; break;
420 case TRAMPOLINE_K_3_1:
421 entry[1] = SVM1_TRAP_0_OPERATOR_3_1; break;
422 case TRAMPOLINE_K_3_0:
423 entry[1] = SVM1_TRAP_0_OPERATOR_3_0; break;
424 case TRAMPOLINE_K_4_3:
425 entry[1] = SVM1_TRAP_0_OPERATOR_4_3; break;
426 case TRAMPOLINE_K_4_2:
427 entry[1] = SVM1_TRAP_0_OPERATOR_4_2; break;
428 case TRAMPOLINE_K_4_1:
429 entry[1] = SVM1_TRAP_0_OPERATOR_4_1; break;
430 case TRAMPOLINE_K_4_0:
431 entry[1] = SVM1_TRAP_0_OPERATOR_4_0; break;
432 case TRAMPOLINE_K_REFLECT_TO_INTERFACE:
433 entry[1] = SVM1_TRAP_0_REFLECT_TO_INTERFACE; break;
434 default:
435 return (true);
436 }
437 return (false);
438 }
439