1 /* prim.c
2 * Copyright 1984-2017 Cisco Systems, Inc.
3 *
4 * Licensed under the Apache License, Version 2.0 (the "License");
5 * you may not use this file except in compliance with the License.
6 * You may obtain a copy of the License at
7 *
8 * http://www.apache.org/licenses/LICENSE-2.0
9 *
10 * Unless required by applicable law or agreed to in writing, software
11 * distributed under the License is distributed on an "AS IS" BASIS,
12 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
13 * See the License for the specific language governing permissions and
14 * limitations under the License.
15 */
16
17 #include "system.h"
18
19 /* locally defined functions */
20 static void install_library_entry PROTO((ptr n, ptr x));
21 static void scheme_install_library_entry PROTO((void));
22 static void create_library_entry_vector PROTO((void));
23 static void create_c_entry_vector PROTO((void));
24 static void s_instantiate_code_object PROTO((void));
25 static void s_link_code_object PROTO((ptr co, ptr objs));
26 static IBOOL s_check_heap_enabledp PROTO((void));
27 static void s_enable_check_heap PROTO((IBOOL b));
28 static uptr s_check_heap_errors PROTO((void));
29
install_library_entry(n,x)30 static void install_library_entry(n, x) ptr n, x; {
31 if (!Sfixnump(n) || UNFIX(n) < 0 || UNFIX(n) >= library_entry_vector_size)
32 S_error1("$install-library-entry", "invalid index ~s", n);
33 if (!Sprocedurep(x) && !Scodep(x))
34 S_error2("$install-library-entry", "invalid entry ~s for ~s", x, n);
35 if (Svector_ref(S_G.library_entry_vector, UNFIX(n)) != Sfalse) {
36 printf("$install-library-entry: overwriting entry for %ld\n", (long)UNFIX(n));
37 fflush(stdout);
38 }
39 SETVECTIT(S_G.library_entry_vector, UNFIX(n), x);
40 if (n == FIX(library_nonprocedure_code)) {
41 S_G.nonprocedure_code = x;
42 S_retrofit_nonprocedure_code();
43 }
44 #ifdef X86_64
45 if (n == FIX(library_cpu_features))
46 x86_64_set_popcount_present(x);
47 #endif
48 #ifdef PORTABLE_BYTECODE_BIGENDIAN
49 if (n == FIX(library_dounderflow))
50 S_swap_dounderflow_header_endian(CLOSCODE(x));
51 #endif
52 }
53
S_lookup_library_entry(n,errorp)54 ptr S_lookup_library_entry(n, errorp) iptr n; IBOOL errorp; {
55 ptr p;
56
57 if (n < 0 || n >= library_entry_vector_size)
58 S_error1("$lookup-library-entry", "invalid index ~s", FIX(n));
59 p = Svector_ref(S_G.library_entry_vector, n);
60 if (p == Sfalse && errorp)
61 S_error1("$lookup-library-entry", "entry ~s uninitialized", FIX(n));
62 return p;
63 }
64
scheme_install_library_entry()65 static void scheme_install_library_entry() {
66 ptr tc = get_thread_context();
67 install_library_entry(S_get_scheme_arg(tc, 1), S_get_scheme_arg(tc, 2));
68 }
69
create_library_entry_vector()70 static void create_library_entry_vector() {
71 iptr i;
72
73 S_protect(&S_G.library_entry_vector);
74 S_G.library_entry_vector = S_vector(library_entry_vector_size);
75 for (i = 0; i < library_entry_vector_size; i++)
76 INITVECTIT(S_G.library_entry_vector, i) = Sfalse;
77 }
78
79 #ifdef HPUX
80 #define proc2ptr(x) int2ptr((iptr)(x))
int2ptr(iptr f)81 ptr int2ptr(iptr f)
82 {
83 if ((f & 2) == 0)
84 S_error("proc2ptr", "invalid C procedure");
85 return (ptr)(f & ~0x3);
86 }
87 #else /* HPUX */
88 #define proc2ptr(x) TO_PTR(x)
89 #endif /* HPUX */
90
S_install_c_entry(i,x)91 void S_install_c_entry(i, x) iptr i; ptr x; {
92 if (i < 0 || i >= c_entry_vector_size)
93 S_error1("install_c_entry", "invalid index ~s", FIX(i));
94 if (Svector_ref(S_G.c_entry_vector, i) != Sfalse)
95 S_error1("install_c_entry", "duplicate entry for ~s", FIX(i));
96 SETVECTIT(S_G.c_entry_vector, i, x);
97 }
98
S_lookup_c_entry(i)99 ptr S_lookup_c_entry(i) iptr i; {
100 ptr x;
101
102 if (i < 0 || i >= c_entry_vector_size)
103 S_error1("lookup_c_entry", "invalid index ~s", FIX(i));
104 if ((x = Svector_ref(S_G.c_entry_vector, i)) == Sfalse)
105 S_error1("lookup_c_entry", "uninitialized entry ~s", FIX(i));
106 return x;
107 }
108
s_get_thread_context()109 static ptr s_get_thread_context() {
110 return get_thread_context();
111 }
112
create_c_entry_vector()113 static void create_c_entry_vector() {
114 INT i;
115
116 S_protect(&S_G.c_entry_vector);
117 S_G.c_entry_vector = S_vector(c_entry_vector_size);
118
119 for (i = 0; i < c_entry_vector_size; i++)
120 INITVECTIT(S_G.c_entry_vector, i) = Sfalse;
121
122 S_install_c_entry(CENTRY_thread_context, proc2ptr(S_G.thread_context));
123 S_install_c_entry(CENTRY_get_thread_context, proc2ptr(s_get_thread_context));
124 S_install_c_entry(CENTRY_handle_apply_overflood, proc2ptr(S_handle_apply_overflood));
125 S_install_c_entry(CENTRY_handle_docall_error, proc2ptr(S_handle_docall_error));
126 S_install_c_entry(CENTRY_handle_overflow, proc2ptr(S_handle_overflow));
127 S_install_c_entry(CENTRY_handle_overflood, proc2ptr(S_handle_overflood));
128 S_install_c_entry(CENTRY_handle_nonprocedure_symbol, proc2ptr(S_handle_nonprocedure_symbol));
129 S_install_c_entry(CENTRY_thread_list, TO_PTR(&S_threads));
130 S_install_c_entry(CENTRY_split_and_resize, proc2ptr(S_split_and_resize));
131 #ifdef PTHREADS
132 S_install_c_entry(CENTRY_raw_collect_cond, TO_PTR(&S_collect_cond));
133 S_install_c_entry(CENTRY_raw_collect_thread0_cond, TO_PTR(&S_collect_thread0_cond));
134 S_install_c_entry(CENTRY_raw_tc_mutex, TO_PTR(&S_tc_mutex));
135 S_install_c_entry(CENTRY_raw_terminated_cond, TO_PTR(&S_terminated_cond));
136 S_install_c_entry(CENTRY_activate_thread, proc2ptr(S_activate_thread));
137 S_install_c_entry(CENTRY_deactivate_thread, proc2ptr(Sdeactivate_thread));
138 S_install_c_entry(CENTRY_unactivate_thread, proc2ptr(S_unactivate_thread));
139 #endif /* PTHREADS */
140 S_install_c_entry(CENTRY_handle_values_error, proc2ptr(S_handle_values_error));
141 S_install_c_entry(CENTRY_handle_mvlet_error, proc2ptr(S_handle_mvlet_error));
142 S_install_c_entry(CENTRY_handle_arg_error, proc2ptr(S_handle_arg_error));
143 S_install_c_entry(CENTRY_handle_event_detour, proc2ptr(S_handle_event_detour));
144 S_install_c_entry(CENTRY_foreign_entry, proc2ptr(S_foreign_entry));
145 S_install_c_entry(CENTRY_install_library_entry, proc2ptr(scheme_install_library_entry));
146 S_install_c_entry(CENTRY_get_more_room, proc2ptr(S_get_more_room));
147 S_install_c_entry(CENTRY_scan_remembered_set, proc2ptr(S_scan_remembered_set));
148 S_install_c_entry(CENTRY_instantiate_code_object, proc2ptr(s_instantiate_code_object));
149 S_install_c_entry(CENTRY_Sreturn, proc2ptr(S_return));
150 S_install_c_entry(CENTRY_Scall_one_result, proc2ptr(S_call_one_result));
151 S_install_c_entry(CENTRY_Scall_any_results, proc2ptr(S_call_any_results));
152 S_install_c_entry(CENTRY_segment_info, proc2ptr(S_segment_info));
153 S_install_c_entry(CENTRY_bignum_mask_test, proc2ptr(S_bignum_mask_test));
154 S_install_c_entry(CENTRY_null_immutable_vector, TO_PTR(S_G.null_immutable_vector));
155 S_install_c_entry(CENTRY_null_immutable_bytevector, TO_PTR(S_G.null_immutable_bytevector));
156 S_install_c_entry(CENTRY_null_immutable_string, TO_PTR(S_G.null_immutable_string));
157 }
158
S_check_c_entry_vector()159 void S_check_c_entry_vector() {
160 INT i;
161
162 for (i = 0; i < c_entry_vector_size; i++) {
163 #ifndef PTHREADS
164 if (i == CENTRY_raw_collect_cond || i == CENTRY_raw_collect_thread0_cond
165 || i == CENTRY_raw_tc_mutex || i == CENTRY_raw_terminated_cond
166 || i == CENTRY_activate_thread || i == CENTRY_deactivate_thread
167 || i == CENTRY_unactivate_thread)
168 continue;
169 #endif /* NOT PTHREADS */
170 if (Svector_ref(S_G.c_entry_vector, i) == Sfalse) {
171 fprintf(stderr, "c_entry_vector entry %d is uninitialized\n", i);
172 S_abnormal_exit();
173 }
174 }
175 }
176
S_prim_init()177 void S_prim_init() {
178 if (!S_boot_time) return;
179
180 create_library_entry_vector();
181 create_c_entry_vector();
182
183 Sforeign_symbol("(cs)fixedpathp", (void *)S_fixedpathp);
184 Sforeign_symbol("(cs)bytes_allocated", (void *)S_compute_bytes_allocated);
185 Sforeign_symbol("(cs)bytes_finalized", (void *)S_bytes_finalized);
186 Sforeign_symbol("(cs)curmembytes", (void *)S_curmembytes);
187 Sforeign_symbol("(cs)maxmembytes", (void *)S_maxmembytes);
188 Sforeign_symbol("(cs)resetmaxmembytes", (void *)S_resetmaxmembytes);
189 Sforeign_symbol("(cs)do_gc", (void *)S_do_gc);
190 Sforeign_symbol("(cs)check_heap_enabledp", (void *)s_check_heap_enabledp);
191 Sforeign_symbol("(cs)enable_check_heap", (void *)s_enable_check_heap);
192 Sforeign_symbol("(cs)check_heap_errors", (void *)s_check_heap_errors);
193 Sforeign_symbol("(cs)count_size_increments", (void *)S_count_size_increments);
194 Sforeign_symbol("(cs)lookup_library_entry", (void *)S_lookup_library_entry);
195 Sforeign_symbol("(cs)link_code_object", (void *)s_link_code_object);
196 Sforeign_symbol("(cs)lookup_c_entry", (void *)S_lookup_c_entry);
197 Sforeign_symbol("(cs)lock_object", (void *)Slock_object);
198 Sforeign_symbol("(cs)unlock_object", (void *)Sunlock_object);
199 Sforeign_symbol("(cs)locked_objectp", (void *)Slocked_objectp);
200 Sforeign_symbol("(cs)locked_objects", (void *)S_locked_objects);
201 Sforeign_symbol("(cs)maxgen", (void *)S_maxgen);
202 Sforeign_symbol("(cs)set_maxgen", (void *)S_set_maxgen);
203 Sforeign_symbol("(cs)minfreegen", (void *)S_minfreegen);
204 Sforeign_symbol("(cs)set_minmarkgen", (void *)S_set_minmarkgen);
205 Sforeign_symbol("(cs)minmarkgen", (void *)S_minmarkgen);
206 Sforeign_symbol("(cs)set_minfreegen", (void *)S_set_minfreegen);
207 Sforeign_symbol("(cs)enable_object_counts", (void *)S_enable_object_counts);
208 Sforeign_symbol("(cs)set_enable_object_counts", (void *)S_set_enable_object_counts);
209 Sforeign_symbol("(cs)object_counts", (void *)S_object_counts);
210 Sforeign_symbol("(cs)unregister_guardian", (void *)S_unregister_guardian);
211 Sforeign_symbol("(cs)fire_collector", (void *)S_fire_collector);
212 Sforeign_symbol("(cs)enable_object_backreferences", (void *)S_enable_object_backreferences);
213 Sforeign_symbol("(cs)set_enable_object_backreferences", (void *)S_set_enable_object_backreferences);
214 Sforeign_symbol("(cs)object_backreferences", (void *)S_object_backreferences);
215 Sforeign_symbol("(cs)list_bits_ref", (void *)S_list_bits_ref);
216 Sforeign_symbol("(cs)list_bits_set", (void *)S_list_bits_set);
217 }
218
s_instantiate_code_object()219 static void s_instantiate_code_object() {
220 ptr tc = get_thread_context();
221 ptr old, cookie, proc;
222 ptr new, oldreloc, newreloc;
223 ptr pinfos;
224 uptr a, m, n;
225 iptr i, size;
226
227 old = S_get_scheme_arg(tc, 1);
228 cookie = S_get_scheme_arg(tc, 2);
229 proc = S_get_scheme_arg(tc, 3);
230
231 S_thread_start_code_write(tc, 0, 0, NULL, 0);
232
233 new = S_code(tc, CODETYPE(old), CODELEN(old));
234
235 S_immobilize_object(new);
236
237 oldreloc = CODERELOC(old);
238 size = RELOCSIZE(oldreloc);
239 newreloc = S_relocation_table(size);
240 RELOCCODE(newreloc) = new;
241 for (i = 0; i < size; i += 1) RELOCIT(newreloc, i) = RELOCIT(oldreloc, i);
242
243 CODERELOC(new) = newreloc;
244 CODENAME(new) = CODENAME(old);
245 CODEARITYMASK(new) = CODEARITYMASK(old);
246 CODEFREE(new) = CODEFREE(old);
247 CODEINFO(new) = CODEINFO(old);
248 CODEPINFOS(new) = pinfos = CODEPINFOS(old);
249 if (pinfos != Snil) {
250 S_G.profile_counters = Scons(S_weak_cons(new, pinfos), S_G.profile_counters);
251 }
252
253 for (i = 0; i < CODELEN(old); i++) CODEIT(new,i) = CODEIT(old,i);
254
255 m = RELOCSIZE(newreloc);
256 a = 0;
257 n = 0;
258 while (n < m) {
259 uptr entry, item_off, code_off; ptr obj;
260 entry = RELOCIT(newreloc, n); n += 1;
261 if (RELOC_EXTENDED_FORMAT(entry)) {
262 item_off = RELOCIT(newreloc, n); n += 1;
263 code_off = RELOCIT(newreloc, n); n += 1;
264 } else {
265 item_off = RELOC_ITEM_OFFSET(entry);
266 code_off = RELOC_CODE_OFFSET(entry);
267 }
268 a += code_off;
269 obj = S_get_code_obj(RELOC_TYPE(entry), old, a, item_off);
270
271 /* we've seen the enemy, and he is us */
272 if (obj == old) obj = new;
273
274 /* if we find our cookie, insert proc; otherwise, insert the object
275 into new to get proper adjustment of relative addresses */
276 if (obj == cookie)
277 S_set_code_obj("fcallable", RELOC_TYPE(entry), new, a, proc, item_off);
278 else
279 S_set_code_obj("fcallable", RELOC_TYPE(entry), new, a, obj, item_off);
280 }
281 S_flush_instruction_cache(tc);
282
283 S_thread_end_code_write(tc, 0, 0, NULL, 0);
284
285 AC0(tc) = new;
286 }
287
s_link_code_object(co,objs)288 static void s_link_code_object(co, objs) ptr co, objs; {
289 ptr t, tc = get_thread_context();
290 uptr a, m, n;
291
292 S_thread_start_code_write(tc, 0, 0, NULL, 0);
293 t = CODERELOC(co);
294 m = RELOCSIZE(t);
295 a = 0;
296 n = 0;
297 while (n < m) {
298 uptr entry, item_off, code_off;
299 entry = RELOCIT(t, n); n += 1;
300 if (RELOC_EXTENDED_FORMAT(entry)) {
301 item_off = RELOCIT(t, n); n += 1;
302 code_off = RELOCIT(t, n); n += 1;
303 } else {
304 item_off = RELOC_ITEM_OFFSET(entry);
305 code_off = RELOC_CODE_OFFSET(entry);
306 }
307 a += code_off;
308 S_set_code_obj("gc", RELOC_TYPE(entry), co, a, Scar(objs), item_off);
309 objs = Scdr(objs);
310 }
311 S_thread_end_code_write(tc, 0, 0, NULL, 0);
312 }
313
s_check_heap_enabledp(void)314 static INT s_check_heap_enabledp(void) {
315 return S_checkheap;
316 }
317
s_enable_check_heap(IBOOL b)318 static void s_enable_check_heap(IBOOL b) {
319 S_checkheap = b;
320 }
321
s_check_heap_errors(void)322 static uptr s_check_heap_errors(void) {
323 return S_checkheap_errors;
324 }
325