1 /* schlib.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 ptr S_call PROTO((ptr tc, ptr cp, iptr argcnt));
21
22 /* Sinteger_value is in number.c */
23
24 /* Sinteger32_value is in number.c */
25
26 /* Sinteger64_value is in number.c */
27
Sset_box(x,y)28 void Sset_box(x, y) ptr x, y; {
29 SETBOXREF(x, y);
30 }
31
Sset_car(x,y)32 void Sset_car(x, y) ptr x, y; {
33 SETCAR(x, y);
34 }
35
Sset_cdr(x,y)36 void Sset_cdr(x, y) ptr x, y; {
37 SETCDR(x, y);
38 }
39
Svector_set(x,i,y)40 void Svector_set(x, i, y) ptr x; iptr i; ptr y; {
41 SETVECTIT(x, i, y);
42 }
43
44 /* Scons is in alloc.c */
45
Sstring_to_symbol(s)46 ptr Sstring_to_symbol(s) const char *s; {
47 return S_intern((const unsigned char *)s);
48 }
49
Ssymbol_to_string(x)50 ptr Ssymbol_to_string(x) ptr x; {
51 ptr name = SYMNAME(x);
52 if (Sstringp(name))
53 return name;
54 else if (Spairp(name))
55 return Scdr(name);
56 else
57 /* don't have access to prefix or count, and can't handle arbitrary
58 prefixes anyway, so always punt */
59 return S_string("gensym", -1);
60 }
61
62 /* Sflonum is in alloc.c */
63
Smake_vector(n,x)64 ptr Smake_vector(n, x) iptr n; ptr x; {
65 ptr p; iptr i;
66
67 p = S_vector(n);
68 for (i = 0; i < n; i += 1) INITVECTIT(p, i) = x;
69 return p;
70 }
71
Smake_fxvector(n,x)72 ptr Smake_fxvector(n, x) iptr n; ptr x; {
73 ptr p; iptr i;
74
75 p = S_fxvector(n);
76 for (i = 0; i < n; i += 1) Sfxvector_set(p, i, x);
77 return p;
78 }
79
Smake_bytevector(n,x)80 ptr Smake_bytevector(n, x) iptr n; int x; {
81 ptr p; iptr i;
82
83 p = S_bytevector(n);
84 for (i = 0; i < n; i += 1) Sbytevector_u8_set(p, i, (octet)x);
85 return p;
86 }
87
Smake_string(n,c)88 ptr Smake_string(n, c) iptr n; int c; {
89 ptr p; iptr i;
90
91 p = S_string((char *)NULL, n);
92 for (i = 0; i < n; i += 1) Sstring_set(p, i, c);
93 return p;
94 }
95
Smake_uninitialized_string(n)96 ptr Smake_uninitialized_string(n) iptr n; {
97 return S_string((char *)NULL, n);
98 }
99
Sstring(s)100 ptr Sstring(s) const char *s; {
101 return S_string(s, -1);
102 }
103
Sstring_of_length(s,n)104 ptr Sstring_of_length(s, n) const char *s; iptr n; {
105 return S_string(s, n);
106 }
107
108 /* Sstring_utf8 is in alloc.c */
109
110 /* Sbox is in alloc.c */
111
112 /* Sinteger is in number.c */
113
114 /* Sunsigned is in number.c */
115
116 /* Sunsigned32 is in number.c */
117
118 /* Sunsigned64 is in number.c */
119
Stop_level_value(x)120 ptr Stop_level_value(x) ptr x; {
121 ptr tc = get_thread_context();
122 IBOOL enabled = (DISABLECOUNT(tc) == 0);
123 if (enabled) DISABLECOUNT(tc) = FIX(UNFIX(DISABLECOUNT(tc)) + 1);
124 x = Scall1(S_symbol_value(Sstring_to_symbol("$c-tlv")), x);
125 if (enabled) DISABLECOUNT(tc) = FIX(UNFIX(DISABLECOUNT(tc)) - 1);
126 return x;
127 }
128
Sset_top_level_value(x,y)129 void Sset_top_level_value(x, y) ptr x, y; {
130 ptr tc = get_thread_context();
131 IBOOL enabled = (DISABLECOUNT(tc) == 0);
132 if (enabled) DISABLECOUNT(tc) = FIX(UNFIX(DISABLECOUNT(tc)) + 1);
133 Scall2(S_symbol_value(Sstring_to_symbol("$c-stlv!")), x, y);
134 if (enabled) DISABLECOUNT(tc) = FIX(UNFIX(DISABLECOUNT(tc)) - 1);
135 }
136
137 #include <setjmp.h>
138
139 /* consider rewriting these to avoid multiple calls to get_thread_context */
Scall0(cp)140 ptr Scall0(cp) ptr cp; {
141 ptr tc = get_thread_context();
142 S_initframe(tc,0);
143 return S_call(tc, cp, 0);
144 }
145
Scall1(cp,x1)146 ptr Scall1(cp, x1) ptr cp, x1; {
147 ptr tc = get_thread_context();
148 S_initframe(tc, 1);
149 S_put_arg(tc, 1, x1);
150 return S_call(tc, cp, 1);
151 }
152
Scall2(cp,x1,x2)153 ptr Scall2(cp, x1, x2) ptr cp, x1, x2; {
154 ptr tc = get_thread_context();
155 S_initframe(tc, 2);
156 S_put_arg(tc, 1, x1);
157 S_put_arg(tc, 2, x2);
158 return S_call(tc, cp, 2);
159 }
160
Scall3(cp,x1,x2,x3)161 ptr Scall3(cp, x1, x2, x3) ptr cp, x1, x2, x3; {
162 ptr tc = get_thread_context();
163 S_initframe(tc, 3);
164 S_put_arg(tc, 1, x1);
165 S_put_arg(tc, 2, x2);
166 S_put_arg(tc, 3, x3);
167 return S_call(tc, cp, 3);
168 }
169
Sinitframe(n)170 void Sinitframe(n) iptr n; {
171 ptr tc = get_thread_context();
172 S_initframe(tc, n);
173 }
174
S_initframe(tc,n)175 void S_initframe(tc, n) ptr tc; iptr n; {
176 /* check for and handle stack overflow */
177 if ((ptr *)TO_VOIDP(SFP(tc)) + n + 2 > (ptr *)TO_VOIDP(ESP(tc)))
178 S_overflow(tc, (n+2)*sizeof(ptr));
179
180 /* intermediate frame contains old RA + cchain */;
181 SFP(tc) = TO_PTR((ptr *)TO_VOIDP(SFP(tc)) + 2);
182 }
183
Sput_arg(i,x)184 void Sput_arg(i, x) iptr i; ptr x; {
185 ptr tc = get_thread_context();
186 S_put_arg(tc, i, x);
187 }
188
S_put_arg(tc,i,x)189 void S_put_arg(tc, i, x) ptr tc; iptr i; ptr x; {
190 if (i <= asm_arg_reg_cnt)
191 REGARG(tc, i) = x;
192 else
193 FRAME(tc, i - asm_arg_reg_cnt) = x;
194 }
195
Scall(cp,argcnt)196 ptr Scall(cp, argcnt) ptr cp; iptr argcnt; {
197 ptr tc = get_thread_context();
198 return S_call(tc, cp, argcnt);
199 }
200
S_call(tc,cp,argcnt)201 static ptr S_call(tc, cp, argcnt) ptr tc; ptr cp; iptr argcnt; {
202 AC0(tc) = (ptr)argcnt;
203 AC1(tc) = cp;
204 S_call_help(tc, 1, 0);
205 return AC0(tc);
206 }
207
208 /* args are set up, argcnt in ac0, closure in ac1 */
S_call_help(tc_in,singlep,lock_ts)209 void S_call_help(tc_in, singlep, lock_ts) ptr tc_in; IBOOL singlep; IBOOL lock_ts; {
210 /* declaring code and tc volatile should be unnecessary, but it quiets gcc
211 and avoids occasional invalid memory violations on Windows */
212 void *jb; volatile ptr code;
213 volatile ptr tc = tc_in;
214
215 /* lock caller's code object, since his return address is sitting in
216 the C stack and we may end up in a garbage collection */
217 code = CP(tc);
218 if (Sprocedurep(code)) code = CLOSCODE(code);
219 if (!FIXMEDIATE(code) && !Scodep(code))
220 S_error_abort("S_call_help: invalid code pointer");
221 S_immobilize_object(code);
222
223 CP(tc) = AC1(tc);
224
225 jb = CREATEJMPBUF();
226 if (jb == NULL)
227 S_error_abort("unable to allocate memory for jump buffer");
228 if (lock_ts) {
229 /* Lock a code object passed in TS, which is a more immediate
230 caller whose return address is on the C stack */
231 S_immobilize_object(TS(tc));
232 CCHAIN(tc) = Scons(Scons(TO_PTR(jb), Scons(code,TS(tc))), CCHAIN(tc));
233 } else {
234 CCHAIN(tc) = Scons(Scons(TO_PTR(jb), Scons(code,Sfalse)), CCHAIN(tc));
235 }
236
237 FRAME(tc, -1) = CCHAIN(tc);
238
239 switch (SETJMP(jb)) {
240 case 0: /* first time */
241 S_generic_invoke(tc, S_G.invoke_code_object);
242 S_error_abort("S_generic_invoke return");
243 break;
244 case -1: /* error */
245 S_generic_invoke(tc, S_G.error_invoke_code_object);
246 S_error_abort("S_generic_invoke return");
247 break;
248 case 1: { /* normal return */
249 ptr yp = CCHAIN(tc);
250 FREEJMPBUF(TO_VOIDP(CAAR(yp)));
251 CCHAIN(tc) = Scdr(yp);
252 break;
253 }
254 default:
255 S_error_abort("unexpected SETJMP return value");
256 break;
257 }
258
259 /* verify single return value */
260 if (singlep && (iptr)AC1(tc) != 1)
261 S_error1("", "returned ~s values to single value return context",
262 FIX((iptr)AC1(tc)));
263
264 /* restore caller to cp so that we can lock it again another day. we
265 restore the code object rather than the original closure, as the
266 closure may have been relocated or reclaimed by now */
267 CP(tc) = code;
268 }
269
S_call_one_result()270 void S_call_one_result() {
271 ptr tc = get_thread_context();
272 S_call_help(tc, 1, 1);
273 }
274
S_call_any_results()275 void S_call_any_results() {
276 ptr tc = get_thread_context();
277 S_call_help(tc, 0, 1);
278 }
279
280 /* cchain = ((jb . (co . maybe-co)) ...) */
S_return()281 void S_return() {
282 ptr tc = get_thread_context();
283 ptr xp, yp;
284
285 SFP(tc) = TO_PTR((ptr *)TO_VOIDP(SFP(tc)) - 2);
286
287 /* grab saved cchain */
288 yp = FRAME(tc, 1);
289
290 /* verify saved cchain is sublist of current cchain */
291 for (xp = CCHAIN(tc); xp != yp; xp = Scdr(xp))
292 if (xp == Snil)
293 S_error("", "attempt to return to stale foreign context");
294
295 /* error checks are done; now unlock affected code objects */
296 for (xp = CCHAIN(tc); ; xp = Scdr(xp)) {
297 ptr p = CDAR(xp);
298 S_mobilize_object(Scar(p));
299 if (Scdr(p) != Sfalse) S_mobilize_object(Scdr(p));
300 if (xp == yp) break;
301 FREEJMPBUF(TO_VOIDP(CAAR(xp)));
302 }
303
304 /* reset cchain and return via longjmp */
305 CCHAIN(tc) = yp;
306 LONGJMP(TO_VOIDP(CAAR(yp)), 1);
307 }
308