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, &quot, &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