1 /*
2 * Part of Scheme 48 1.9. See file COPYING for notices and license.
3 *
4 * Authors: Richard Kelsey, Jonathan Rees, Martin Gasbichler, Mike Sperber
5 */
6
7 #include <stdio.h>
8 #include "scheme48.h"
9
10 static s48_value s48_provide_asm_values(s48_value asm_vector);
11 static s48_value s48_malloc_byte_vector(s48_value length);
12 static s48_value s48_stob_start_address(s48_value stob);
13 static s48_value s48_free_byte_vector(s48_value byte_vector);
14
15 void
s48_init_asm_glue(void)16 s48_init_asm_glue(void)
17 {
18 S48_EXPORT_FUNCTION(s48_provide_asm_values);
19 S48_EXPORT_FUNCTION(s48_malloc_byte_vector);
20 S48_EXPORT_FUNCTION(s48_stob_start_address);
21 S48_EXPORT_FUNCTION(s48_free_byte_vector);
22 }
23
24 static s48_value
s48_provide_asm_values(s48_value asm_vector)25 s48_provide_asm_values(s48_value asm_vector)
26 {
27 extern long s48_unknown_call();
28 extern long s48_unknown_return();
29 extern long s48_unknown_return_values();
30 extern long s48_unknown_apply();
31 extern long s48_interrupt_handler();
32 extern long s48_restart_vm();
33 extern long s48_ensure_space_for_native_code();
34 extern long s48_native_add();
35 extern long s48_native_sub();
36 extern long s48_native_mul();
37 extern long s48_native_E();
38 extern long s48_native_L();
39 extern long s48_native_G();
40 extern long s48_native_LE();
41 extern long s48_native_GE();
42 extern long s48_native_remainder();
43 extern long s48_native_quotient();
44 extern long s48_native_divide();
45 extern long s48_native_bitwise_not;
46 extern long s48_native_bit_count;
47 extern long s48_native_bitwise_and;
48 extern long s48_native_bitwise_ior;
49 extern long s48_native_bitwise_xor;
50 extern long s48_restart_vm3_pop_0;
51 extern long s48_restart_vm3_pop_1;
52 extern long s48_restart_vm3_pop_2;
53 extern long s48_restart_vm3_pop_3;
54 extern long s48_gcSallocate_for_native_code;
55 extern long s48_Sstack_limitS;
56 extern long s48_ShpS;
57 extern long s48_SlimitS;
58 extern char* ScontS;
59 /* The order of the vector has to match the enumatation asm-external in
60 s48-compiler/assembler/asm-externals.scm */
61 /* 0 *val* */
62 S48_VECTOR_SET(asm_vector, 1, s48_enter_fixnum((long) &ScontS));
63 /* 2 *stack* */
64 S48_VECTOR_SET(asm_vector, 3, s48_enter_fixnum((long) &s48_Sstack_limitS));
65 S48_VECTOR_SET(asm_vector, 4, s48_enter_fixnum((long) &s48_ShpS));
66 S48_VECTOR_SET(asm_vector, 5, s48_enter_fixnum((long) &s48_SlimitS));
67 S48_VECTOR_SET(asm_vector, 6, s48_enter_fixnum((long) &s48_unknown_call));
68 S48_VECTOR_SET(asm_vector, 7, s48_enter_fixnum((long) &s48_unknown_return));
69 S48_VECTOR_SET(asm_vector, 8, s48_enter_fixnum((long) &s48_unknown_return_values));
70 S48_VECTOR_SET(asm_vector, 9, s48_enter_fixnum((long) &s48_interrupt_handler));
71 S48_VECTOR_SET(asm_vector, 10, s48_enter_fixnum((long) &s48_restart_vm));
72 S48_VECTOR_SET(asm_vector, 11, s48_enter_fixnum((long) &s48_ensure_space_for_native_code));
73 S48_VECTOR_SET(asm_vector, 12, s48_enter_fixnum((long) &s48_native_add));
74 S48_VECTOR_SET(asm_vector, 13, s48_enter_fixnum((long) &s48_native_sub));
75 S48_VECTOR_SET(asm_vector, 14, s48_enter_fixnum((long) &s48_native_mul));
76 S48_VECTOR_SET(asm_vector, 15, s48_enter_fixnum((long) &s48_native_E));
77 S48_VECTOR_SET(asm_vector, 16, s48_enter_fixnum((long) &s48_native_L));
78 S48_VECTOR_SET(asm_vector, 17, s48_enter_fixnum((long) &s48_native_G));
79 S48_VECTOR_SET(asm_vector, 18, s48_enter_fixnum((long) &s48_native_LE));
80 S48_VECTOR_SET(asm_vector, 19, s48_enter_fixnum((long) &s48_native_GE));
81 S48_VECTOR_SET(asm_vector, 20, s48_enter_fixnum((long) &s48_native_remainder));
82 S48_VECTOR_SET(asm_vector, 21, s48_enter_fixnum((long) &s48_native_quotient));
83 S48_VECTOR_SET(asm_vector, 22, s48_enter_fixnum((long) &s48_native_divide));
84 S48_VECTOR_SET(asm_vector, 23, s48_enter_fixnum((long) &s48_native_bitwise_not));
85 S48_VECTOR_SET(asm_vector, 24, s48_enter_fixnum((long) &s48_native_bit_count));
86 S48_VECTOR_SET(asm_vector, 25, s48_enter_fixnum((long) &s48_native_bitwise_and));
87 S48_VECTOR_SET(asm_vector, 26, s48_enter_fixnum((long) &s48_native_bitwise_ior));
88 S48_VECTOR_SET(asm_vector, 27, s48_enter_fixnum((long) &s48_native_bitwise_xor));
89 S48_VECTOR_SET(asm_vector, 28, s48_enter_fixnum((long) &s48_restart_vm3_pop_0));
90 S48_VECTOR_SET(asm_vector, 29, s48_enter_fixnum((long) &s48_restart_vm3_pop_1));
91 S48_VECTOR_SET(asm_vector, 30, s48_enter_fixnum((long) &s48_restart_vm3_pop_2));
92 S48_VECTOR_SET(asm_vector, 31, s48_enter_fixnum((long) &s48_restart_vm3_pop_3));
93 S48_VECTOR_SET(asm_vector, 32, s48_enter_fixnum((long) &s48_gcSallocate_for_native_code));
94 /* 34 current thread */
95 S48_VECTOR_SET(asm_vector, 33, s48_enter_fixnum((long) &s48_unknown_apply));
96 return S48_UNSPECIFIC;
97 }
98
99 int
s48_is_integer_or_flonum(s48_value thing)100 s48_is_integer_or_flonum(s48_value thing)
101 {
102 return (S48_FIXNUM_P (thing) || S48_BIGNUM_P (thing) || S48_DOUBLE_P (thing));
103 }
104
105 /*
106 * Make a byte-vector that is outside the heap (and thus won't be moved (or
107 * freed) by the GC).
108 */
109
110 static s48_value
s48_malloc_byte_vector(s48_value length)111 s48_malloc_byte_vector(s48_value length)
112 {
113 int c_length = s48_extract_fixnum(length);
114 int bytes = (c_length + 4 + 3) & -4; /* space for header + round up */
115 char *bv = (char *)malloc(bytes);
116
117 if (bv == NULL)
118 s48_out_of_memory_error();
119
120 *((long *) bv) = (c_length << 8)
121 | (S48_STOBTYPE_BYTE_VECTOR << 2)
122 | S48_HEADER_TAG;
123
124 return (s48_value) ((((long) bv) + 4) | S48_STOB_TAG);
125 }
126
127 /*
128 * Free up a malloc'ed byte vector.
129 */
130
131 static s48_value
s48_free_byte_vector(s48_value byte_vector)132 s48_free_byte_vector(s48_value byte_vector)
133 {
134 if (!S48_BYTE_VECTOR_P(byte_vector))
135 s48_assertion_violation("s48_free_byte_vector", "not a byte vector", 1, byte_vector);
136
137 free((void *) ((byte_vector & -4)- 4));
138
139 return S48_UNSPECIFIC;
140 }
141
142 /*
143 * The assembler needs to be able to get the start address of a stored
144 * object.
145 */
146
147 static s48_value
s48_stob_start_address(s48_value stob)148 s48_stob_start_address(s48_value stob)
149 {
150 if (!S48_STOB_P(stob))
151 s48_assertion_violation("s48_stob_start_address", "not a stob", 1, stob);
152
153 return s48_enter_integer((long) S48_ADDRESS_AFTER_HEADER(stob, void));
154 }
155
156 s48_value
s48_is_integer_or_floanum(s48_value value)157 s48_is_integer_or_floanum(s48_value value)
158 {
159 return (S48_FIXNUM_P (value) || S48_BIGNUM_P (value) || S48_DOUBLE_P (value));
160 }
161
162 s48_value
s48_are_integers_or_floanums(s48_value value1,s48_value value2)163 s48_are_integers_or_floanums(s48_value value1, s48_value value2)
164 {
165 return (((S48_FIXNUM_P (value1) || S48_BIGNUM_P (value1)) &&
166 (S48_FIXNUM_P (value2) || S48_BIGNUM_P (value2))) ||
167 ((S48_DOUBLE_P (value1) && S48_DOUBLE_P (value2))));
168 }
169
170 s48_value
s48_is_integer(s48_value value)171 s48_is_integer(s48_value value)
172 {
173 return (S48_FIXNUM_P (value) || S48_BIGNUM_P (value));
174 }
175
176 s48_value
s48_are_integers(s48_value value1,s48_value value2)177 s48_are_integers(s48_value value1, s48_value value2)
178 {
179 return (((S48_FIXNUM_P (value1) || S48_BIGNUM_P (value1)) &&
180 (S48_FIXNUM_P (value2) || S48_BIGNUM_P (value2))));
181 }
182
183 s48_value
s48_integer_divide_help(s48_value value1,s48_value value2)184 s48_integer_divide_help(s48_value value1, s48_value value2)
185 {
186 s48_value quot,rem;
187 s48_value div_by_zeroP;
188 div_by_zeroP = s48_integer_divide (value1, value2, ", &rem);
189 /* native code should check div_by_zeroP */
190 if (rem == s48_enter_fixnum (0))
191 return quot;
192 else return S48_FALSE;
193 }
194
195 long ignore_values_native_protocol = 194; /* ignore-values-native-protocol */
196 long jmp_count = 7; /* movl continue %ebx; jmp *ebx */
197 long first_opcode_index = 15; /* from vm/package-defs.scm */
198 extern long Snative_exception_contS;
199
200 void
s48_make_native_return_code(int n_stack_args)201 s48_make_native_return_code(int n_stack_args)
202 {
203 long return_code, i,target;
204 char frame_size;
205 extern char* ScontS;
206 extern char* SstackS;
207 target = Snative_exception_contS;
208 frame_size = ScontS - SstackS;
209 frame_size = frame_size >> 2; /* bytes -> cells */
210 frame_size -= n_stack_args;
211 return_code = s48_make_blank_return_code(ignore_values_native_protocol, 0xffff, frame_size, jmp_count);
212 S48_BYTE_VECTOR_SET(return_code,first_opcode_index,0xbb); /* movl %ebx */
213 S48_BYTE_VECTOR_SET(return_code,first_opcode_index+1,target & 0xff);
214 S48_BYTE_VECTOR_SET(return_code,first_opcode_index+2,(target >> 8) & 0xff);
215 S48_BYTE_VECTOR_SET(return_code,first_opcode_index+3,(target >> 16) & 0xff);
216 S48_BYTE_VECTOR_SET(return_code,first_opcode_index+4,(target >> 24) & 0xff);
217 S48_BYTE_VECTOR_SET(return_code,first_opcode_index+5,0xff); /* jmp */
218 S48_BYTE_VECTOR_SET(return_code,first_opcode_index+6,0xe3); /* ebx */
219
220
221 Snative_exception_contS =
222 (return_code - 3) /* remove stob tag */
223 + first_opcode_index
224 - 2; /* pointer to protocol instruction */
225
226 }
227
228 void
s48_write_fatal_message(char * msg,int size,int bc_pc)229 s48_write_fatal_message(char* msg, int size, int bc_pc){
230 fprintf(stderr, "s48_write_fatal_message called with bc-pc %d\n", bc_pc);
231 write(2, msg, size);
232 fprintf(stderr, "s48_write_fatal_message put out\n");
233 exit(1);
234 return;
235 }
236