1 /* fasl.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 /* The fasl writer is in "fasl.ss".
18    There's a second fasl reader and writer in "strip.ss", so it has
19    to be kept in sync with this one. */
20 
21 /* fasl representation:
22  *
23  * <fasl-file> -> <fasl-group>*
24  *
25  * <fasl-group> -> <fasl-header><fasl-object>*
26  *
27  * <fasl-header> -> {header}\0\0\0chez<uptr version><uptr machine-type>(<bootfile-name> ...)
28  *
29  * <bootfile-name> -> <octet char>*
30  *
31  * <fasl-object> -> <situation><uptr size><pcfasl> # size is the size in bytes of <pcfasl>
32  *
33  * <situation> -> {visit} | {revisit} | {visit-revisit}
34  *
35  * <pcfasl> -> <compressed><uptr uncompressed-size><compressed fasl> | {uncompressed}<fasl>
36  *
37  * <compressed> -> {gzip} | {lz4}
38  *
39  * <fasl> -> {pair}<uptr n><fasl elt1>...<fasl eltn><fasl last-cdr>
40  *
41  *        -> {weak-pair}<fasl><fasl>
42  *
43  *        -> {box}<fasl>
44  *
45  *        -> {symbol}<faslstring>
46  *
47  *        -> {gensym}<faslstring name><faslstring uname>
48  *
49  *        -> {string}<faslstring>
50  *
51  *        -> {vector}<uptr n><fasl elt1>...<fasl eltn>
52  *
53  *        -> {fxvector}<uptr n><iptr elt1>...<iptr eltn>
54  *
55  *        -> {flvector}<uptr n><uptr elthi1><uptr eltlo1>...<uptr elthin><uptr eltlon>
56  *
57  *        -> {bytevector}<uptr n><octet elt1>...<octet eltn>
58  *
59  *        -> {stencil-vector}<uptr mask><octet elt1>...<octet eltn>
60  *
61  *        -> {immediate}<uptr>
62  *
63  *        -> {small-integer}<iptr>
64  *
65  *        -> {large-integer}<byte sign><uptr n><uptr bigit1>...<uptr bigitn>
66  *
67  *        -> {ratum}<fasl numerator><fasl denominator>
68  *
69  *        -> {inexactnum}<fasl real-part><fasl imag-part>
70  *
71  *        -> {exactnum}<fasl real-part><fasl imag-part>
72  *
73  *        -> {flonum}<uptr high><uptr low>
74  *
75  *        -> {entry}<uptr index>
76  *
77  *        -> {library}<uptr index>
78  *
79  *        -> {library-code}<uptr index>
80  *
81  *        -> {graph}<uptr graph-length><fasl object>
82  *
83  *        -> {graph-def}<uptr index><fasl object>
84  *
85  *        -> {graph-ref}<uptr index>
86  *
87  *        -> {base-rtd}
88  *
89  *        -> {rtd}<fasl uid><faslrecord>
90  *
91  *        -> {record}<faslrecord>
92  *
93  *        -> {eq-hashtable}<byte mutable?>
94  *                         <byte weak?>
95  *                         <uptr minlen>
96  *                         <uptr veclen>
97  *                         <uptr n>
98  *                         <keyval1>...<keyvaln>
99  *           <keyval> -> <fasl key><fasl val>
100  *
101  *        -> {symbol-hashtable}<byte mutable?>
102  *                             <uptr minlen>
103  *                             <byte equiv>     ; 0: eq?, 1: eqv?, 2: equal?, 3: symbol=?
104  *                             <uptr veclen>
105  *                             <uptr n>
106  *                         <keyval1>...<keyvaln>
107  *           <keyval> -> <fasl key><fasl val>
108  *
109  *        -> {closure}<uptr offset><fasl code>
110  *
111  *        -> {code}<byte flags>
112  *                 <uptr free>       # number of free variables
113  *                 <uptr n>          # length in bytes of code
114  *                 <fasl name>
115  *                 <fasl arity-mask> # two's complement encoding of accepted argument counts
116  *                 <fasl info>       # inspector info
117  *                 <fasl pinfo*>     # profiling info
118  *                 <byte code1>...<byte coden>
119  *                 <uptr m>          # length in uptrs of relocation table
120  *                 <faslreloc>       # first relocation entry
121  *                 ...
122  *                 <faslreloc>       # last relocation entry
123  *
124  *        -> {begin}<va>...<val>     # all but last is intended to be a {graph-def}
125  *
126  * <faslreloc> -> <byte type-etc>    # bit 0: extended entry, bit 1: expect item offset, bit 2+: type
127  *                <uptr code-offset>
128  *                <uptr item-offset> # omitted if bit 1 of type-etc is 0
129  *                <fasl object>
130  *
131  * <faslstring> -> <uptr n><uptr char1>...<uptr charn>
132  *
133  * <faslrecord> -> <uptr size>       # size in bytes, not necessarily ptr-aligned
134  *                 <uptr n>          # number of flds
135  *                 <fasl rtd>
136  *                 <field elt1>
137  *                 ...
138  *                 <field eltn>
139  * <field> -> <padty fld-type-ptr><fasl object>
140  *            <padty fld-type-u8><octet>
141  *            <padty fld-type-i16><iptr>
142  *            <padty fld-type-i24><iptr>
143  *            <padty fld-type-i32><iptr>
144  *            <padty fld-type-i40><iptr high><uptr low>      # 32-bit target
145  *            <padty fld-type-i40><iptr>                     # 64-bit target
146  *            <padty fld-type-i48><iptr high><uptr low>      # 32-bit target
147  *            <padty fld-type-i48><iptr>                     # 64-bit target
148  *            <padty fld-type-i56><iptr high><uptr low>      # 32-bit target
149  *            <padty fld-type-i56><iptr>                     # 64-bit target
150  *            <padty fld-type-i64><iptr high><uptr low>      # 32-bit target
151  *            <padty fld-type-i64><iptr>                     # 64-bit target
152  *            <padty fld-type-single><uptr>
153  *            <padty fld-type-double><uptr high><uptr low>
154  * <padty fld-type> -> <byte pad << 5 | fld-type>
155  *
156  * <uptr n> -> <ubyte1>*<ubyte0>
157  * <ubyte1> -> k << 1 | 1, 0 <= k <= 127
158  * <ubyte0> -> k << 1 | 0, 0 <= k <= 127
159  *         each ubyte represents 7 bits of the uptr, least-significant first
160  *         low-order bit is continuation bit: 1 iff more bytes are present
161  *
162  * <iptr n> -> <ibyte0> | <ibyte1><ubyte1>*<ubyte0>
163  * <ibyte1> -> sign << 7 | k << 1 | 1, 0 <= k <= 63
164  * <ibyte0> -> sign << 7 | k << 1 | 0, 0 <= k <= 63
165  *         leading ibyte represents least-significant 6 bits and sign
166  *         each ubyte represents 7 of the remaining bits of the iptr,
167  *         least-significant first
168  *
169  * Notes:
170  *  * a list of length n will appear to be shorter in the fasl
171  *    representation when the tail of the list is shared, since the
172  *    shared tail will be a {graph-def} or {graph-ref}.
173  *
174  *  * the length of a relocation table is the number of uptrs in the
175  *    table, not the number of relocation entries.
176  *
177  *  * closure offset is the amount added to the code object before
178  *    storing it in the code field of the closure.
179  *
180  *  * {graph} defines the size of the graph used to commonize shared
181  *    structure, including cycles.  It must appear before {graph-def}
182  *    or {graph-ref}.  A {graph-def} at index i must appear before
183  *    a {graph-ref} at index i.
184  *
185  *  * after an rtd is read: if its uname is unbound, the rtd is placed
186  *    into the symbol value slot of the uname; otherwise, the rtd is
187  *    discarded and the existing symbol value of uname is returned
188  *    instead.  Note that when many records appear within the same
189  *    aggregrate structure, the full rtd will appear only in the
190  *    first occurrence; the remainder will simply be graph references.
191  *
192  *  * at present, the fasl representation supports only records
193  *    containing only scheme-object fields.
194  */
195 
196 #include "system.h"
197 #include "zlib.h"
198 #include "popcount.h"
199 
200 #ifdef WIN32
201 #include <io.h>
202 #endif /* WIN32 */
203 
204 #ifdef NAN_INCLUDE
205 #include NAN_INCLUDE
206 #endif
207 
208 #define UFFO_TYPE_FD 2
209 #define UFFO_TYPE_BV 3
210 
211 #define PREPARE_BYTEVECTOR(bv,n) {if (bv == Sfalse || Sbytevector_length(bv) < (n)) bv = S_bytevector(n);}
212 
213 typedef struct unbufFaslFileObj {
214   ptr path;
215   INT type;
216   INT fd;
217 } *unbufFaslFile;
218 
219 typedef struct faslFileObj {
220   unbufFaslFile uf;
221   iptr size;
222   octet *next;
223   octet *end;
224   octet *buf;
225 } *faslFile;
226 
227 /* locally defined functions */
228 static INT uf_read PROTO((unbufFaslFile uf, octet *s, iptr n));
229 static octet uf_bytein PROTO((unbufFaslFile uf));
230 static uptr uf_uptrin PROTO((unbufFaslFile uf, INT *bytes_consumed));
231 static ptr fasl_entry PROTO((ptr tc, IFASLCODE situation, unbufFaslFile uf, ptr externals));
232 static ptr bv_fasl_entry PROTO((ptr tc, ptr bv, IFASLCODE ty, uptr offset, uptr len, unbufFaslFile uf, ptr externals));
233 static void fillFaslFile PROTO((faslFile f));
234 static void bytesin PROTO((octet *s, iptr n, faslFile f));
235 static void toolarge PROTO((ptr path));
236 static iptr iptrin PROTO((faslFile f));
237 static uptr uptrin PROTO((faslFile f));
238 static float singlein PROTO((faslFile f));
239 static double doublein PROTO((faslFile f));
240 static iptr stringin PROTO((ptr *pstrbuf, iptr start, faslFile f));
241 static void faslin PROTO((ptr tc, ptr *x, ptr t, ptr *pstrbuf, faslFile f));
242 static void fasl_record PROTO((ptr tc, ptr *x, ptr t, ptr *pstrbuf, faslFile f, uptr size));
243 static IBOOL rtd_equiv PROTO((ptr x, ptr y));
244 static IBOOL equalp PROTO((ptr x, ptr y));
245 #ifdef PORTABLE_BYTECODE
246 static void pb_set_abs PROTO((void *address, uptr item));
247 static uptr pb_get_abs PROTO((void *address));
248 #endif /* AARCH64 */
249 #ifdef ARMV6
250 static void arm32_set_abs PROTO((void *address, uptr item));
251 static uptr arm32_get_abs PROTO((void *address));
252 static void arm32_set_jump PROTO((void *address, uptr item, IBOOL callp));
253 static uptr arm32_get_jump PROTO((void *address));
254 #endif /* ARMV6 */
255 #ifdef AARCH64
256 static void arm64_set_abs PROTO((void *address, uptr item));
257 static uptr arm64_get_abs PROTO((void *address));
258 #endif /* AARCH64 */
259 #ifdef PPC32
260 static void ppc32_set_abs PROTO((void *address, uptr item));
261 static uptr ppc32_get_abs PROTO((void *address));
262 static void ppc32_set_jump PROTO((void *address, uptr item, IBOOL callp));
263 static uptr ppc32_get_jump PROTO((void *address));
264 #endif /* PPC32 */
265 #ifdef X86_64
266 static void x86_64_set_jump PROTO((void *address, uptr item, IBOOL callp));
267 static uptr x86_64_get_jump PROTO((void *address));
268 static void x86_64_set_popcount PROTO((void *address, uptr item));
269 #endif /* X86_64 */
270 #ifdef SPARC64
271 static INT extract_reg_from_sethi PROTO((void *address));
272 static void emit_sethi_lo PROTO((U32 item, INT destreg, void *address));
273 static uptr sparc64_get_literal PROTO((void *address));
274 static void sparc64_set_call PROTO((void *address, U32 *call_addr, uptr item));
275 static U32 adjust_delay_inst PROTO((U32 delay_inst, U32 *old_call_addr, U32 *new_call_addr));
276 static INT sparc64_set_lit_only PROTO((void *address, uptr item, I32 destreg));
277 static void sparc64_set_literal PROTO((void *address, uptr item));
278 #endif /* SPARC64 */
279 #ifdef PORTABLE_BYTECODE_BIGENDIAN
280 static void swap_code_endian(octet *code, uptr len);
281 #endif
282 
283 static double s_nan;
284 
S_fasl_init()285 void S_fasl_init() {
286     if (S_boot_time) {
287         S_protect(&S_G.base_rtd);
288         S_G.base_rtd = Sfalse;
289         S_protect(&S_G.rtd_key);
290         S_G.rtd_key = S_intern((const unsigned char *)"*rtd*");
291         S_protect(&S_G.eq_symbol);
292         S_G.eq_symbol = S_intern((const unsigned char *)"eq");
293         S_protect(&S_G.eq_ht_rtd);
294         S_G.eq_ht_rtd = Sfalse;
295         S_protect(&S_G.symbol_symbol);
296         S_G.symbol_symbol = S_intern((const unsigned char *)"symbol");
297         S_protect(&S_G.symbol_ht_rtd);
298         S_G.symbol_ht_rtd = Sfalse;
299         S_protect(&S_G.eqp);
300         S_G.eqp = Sfalse;
301         S_protect(&S_G.eqvp);
302         S_G.eqvp = Sfalse;
303         S_protect(&S_G.equalp);
304         S_G.equalp = Sfalse;
305         S_protect(&S_G.symboleqp);
306         S_G.symboleqp = Sfalse;
307     }
308 
309     MAKE_NAN(s_nan)
310 #ifndef WIN32 /* msvc returns true for s_nan==s_nan! */
311     if (s_nan == s_nan) {
312         fprintf(stderr, "s_nan == s_nan\n");
313         S_abnormal_exit();
314     }
315 #endif
316 }
317 
S_fasl_read(INT fd,IFASLCODE situation,ptr path,ptr externals)318 ptr S_fasl_read(INT fd, IFASLCODE situation, ptr path, ptr externals) {
319   ptr tc = get_thread_context();
320   ptr x; struct unbufFaslFileObj uffo;
321 
322   uffo.path = path;
323   uffo.type = UFFO_TYPE_FD;
324   uffo.fd = fd;
325   x = fasl_entry(tc, situation, &uffo, externals);
326   return x;
327 }
328 
S_bv_fasl_read(ptr bv,int ty,uptr offset,uptr len,ptr path,ptr externals)329 ptr S_bv_fasl_read(ptr bv, int ty, uptr offset, uptr len, ptr path, ptr externals) {
330   ptr tc = get_thread_context();
331   ptr x; struct unbufFaslFileObj uffo;
332 
333   uffo.path = path;
334   uffo.type = UFFO_TYPE_BV;
335   x = bv_fasl_entry(tc, bv, ty, offset, len, &uffo, externals);
336   return x;
337 }
338 
S_boot_read(INT fd,const char * path)339 ptr S_boot_read(INT fd, const char *path) {
340   ptr tc = get_thread_context();
341   struct unbufFaslFileObj uffo;
342 
343   uffo.path = Sstring_utf8(path, -1);
344   uffo.type = UFFO_TYPE_FD;
345   uffo.fd = fd;
346   return fasl_entry(tc, fasl_type_visit_revisit, &uffo, S_G.null_vector);
347 }
348 
349 #ifdef WIN32
350 #define IO_SIZE_T unsigned int
351 #else /* WIN32 */
352 #define IO_SIZE_T size_t
353 #endif /* WIN32 */
354 
uf_read(unbufFaslFile uf,octet * s,iptr n)355 static INT uf_read(unbufFaslFile uf, octet *s, iptr n) {
356   iptr k;
357   while (n > 0) {
358     uptr nx = n;
359 
360 #if (iptr_bits > 32)
361   if (WIN32 && (unsigned int)nx != nx) nx = 0xffffffff;
362 #endif
363 
364     switch (uf->type) {
365       case UFFO_TYPE_FD:
366         k = READ(uf->fd, s, (IO_SIZE_T)nx);
367         if (k > 0)
368           n -= k;
369         else if (k == 0)
370           return -1;
371         else if (errno != EINTR)
372          S_error1("", "error reading from ~a", uf->path);
373         break;
374       default:
375         return -1;
376     }
377 
378     s += k;
379   }
380   return 0;
381 }
382 
383 
S_fasl_stream_read(void * stream,octet * dest,iptr n)384 int S_fasl_stream_read(void *stream, octet *dest, iptr n)
385 {
386   return uf_read((unbufFaslFile)stream, dest, n);
387 }
388 
uf_skipbytes(unbufFaslFile uf,iptr n)389 static void uf_skipbytes(unbufFaslFile uf, iptr n) {
390   switch (uf->type) {
391     case UFFO_TYPE_FD:
392        if (LSEEK(uf->fd, n, SEEK_CUR) == -1) {
393          S_error1("", "error seeking ~a", uf->path);
394        }
395        break;
396   }
397 }
398 
uf_bytein(unbufFaslFile uf)399 static octet uf_bytein(unbufFaslFile uf) {
400   octet buf[1];
401   if (uf_read(uf, buf, 1) < 0)
402     S_error1("", "unexpected eof in fasl file ~a", uf->path);
403   return buf[0];
404 }
405 
uf_uptrin(unbufFaslFile uf,INT * bytes_consumed)406 static uptr uf_uptrin(unbufFaslFile uf, INT *bytes_consumed) {
407   uptr n, m; octet k;
408 
409   if (bytes_consumed) *bytes_consumed = 1;
410   k = uf_bytein(uf);
411   n = k & 0x7F;
412   while (k & 0x80) {
413     if (bytes_consumed) *bytes_consumed += 1;
414     k = uf_bytein(uf);
415     m = n << 7;
416     if (m >> 7 != n) toolarge(uf->path);
417     n = m | (k & 0x7F);
418   }
419 
420   return n;
421 }
422 
S_format_scheme_version(uptr n)423 char *S_format_scheme_version(uptr n) {
424   static char buf[20]; INT len;
425   if ((n >> 24) != ((n >> 24) & 0xffff)) return "unknown";
426   if ((n & 0xff) == 0) {
427     if ((n & 0xff) == 0)
428       len = snprintf(buf, 20, "%d.%d", (int) n >> 24, (int) (n >> 16) & 0xff);
429     else
430       len = snprintf(buf, 20, "%d.%d.%d", (int) n >> 24, (int) (n >> 16) & 0xff,
431                      (int) (n >> 8) & 0xff);
432   } else
433     len = snprintf(buf, 20, "%d.%d.%d.%d", (int) n >> 24, (int) (n >> 16) & 0xff,
434                    (int) (n >> 8) & 0xff, (int) n & 0xff);
435   return len > 0 ? buf : "unknown";
436 }
437 
S_lookup_machine_type(uptr n)438 char *S_lookup_machine_type(uptr n) {
439   static char *machine_type_table[] = machine_type_names;
440   if (n < machine_type_limit)
441     return machine_type_table[n];
442   else
443     return "unknown";
444 }
445 
fasl_entry(ptr tc,IFASLCODE situation,unbufFaslFile uf,ptr externals)446 static ptr fasl_entry(ptr tc, IFASLCODE situation, unbufFaslFile uf, ptr externals) {
447   ptr x; ptr strbuf = S_G.null_string;
448   octet tybuf[1]; IFASLCODE ty; iptr size;
449   /* gcc (GCC) 4.8.5 20150623 (Red Hat 4.8.5-28) co-locates buf and x if we put the declaration of buf down where we use it */
450   octet buf[SBUFSIZ];
451 
452   for (;;) {
453     if (uf_read(uf, tybuf, 1) < 0) return Seof_object;
454     ty = tybuf[0];
455 
456     while (ty == fasl_type_header) {
457       uptr n; ICHAR c;
458 
459      /* check for remainder of magic number */
460       if (uf_bytein(uf) != 0 ||
461           uf_bytein(uf) != 0 ||
462           uf_bytein(uf) != 0 ||
463           uf_bytein(uf) != 'c' ||
464           uf_bytein(uf) != 'h' ||
465           uf_bytein(uf) != 'e' ||
466           uf_bytein(uf) != 'z')
467         S_error1("", "malformed fasl-object header (missing magic word) found in ~a", uf->path);
468 
469       if ((n = uf_uptrin(uf, (INT *)0)) != scheme_version)
470         S_error2("", "incompatible fasl-object version ~a found in ~a", S_string(S_format_scheme_version(n), -1), uf->path);
471 
472       if ((n = uf_uptrin(uf, (INT *)0)) != machine_type_any && n != machine_type)
473         S_error2("", "incompatible fasl-object machine-type ~a found in ~a", S_string(S_lookup_machine_type(n), -1), uf->path);
474 
475       if (uf_bytein(uf) != '(')
476         S_error1("", "malformed fasl-object header (missing open paren) found in ~a", uf->path);
477 
478       while ((c = uf_bytein(uf)) != ')')
479         if (c < 0) S_error1("", "malformed fasl-object header (missing close paren) found in ~a", uf->path);
480 
481       ty = uf_bytein(uf);
482     }
483 
484     switch (ty) {
485       case fasl_type_visit:
486       case fasl_type_revisit:
487       case fasl_type_visit_revisit:
488         break;
489       case fasl_type_terminator:
490         return Seof_object;
491       default:
492         S_error2("", "malformed fasl-object header (missing situation, got ~s) found in ~a", FIX(ty), uf->path);
493         return (ptr)0;
494     }
495 
496     size = uf_uptrin(uf, (INT *)0);
497 
498     if (ty == situation || situation == fasl_type_visit_revisit || ty == fasl_type_visit_revisit) {
499       struct faslFileObj ffo;
500       ptr bv; IFASLCODE kind;
501 
502       ty = uf_bytein(uf);
503       kind = uf_bytein(uf); /* fasl or vfasl */
504 
505       if ((kind == fasl_type_vfasl) && S_vfasl_boot_mode) {
506         /* compact every time, because running previously loaded
507            boot code may have interned symbols, for example */
508         Scompact_heap();
509       }
510 
511       S_thread_start_code_write(tc, S_vfasl_boot_mode ? static_generation : 0, 1, NULL, 0);
512 
513       switch (ty) {
514         case fasl_type_gzip:
515         case fasl_type_lz4: {
516           ptr result; INT bytes_consumed;
517           iptr dest_size = uf_uptrin(uf, &bytes_consumed);
518           iptr src_size = size - (2 + bytes_consumed); /* adjust for u8 compression type, u8 fasl type, and uptr dest_size */
519 
520           PREPARE_BYTEVECTOR(SRCBV(tc), src_size);
521           PREPARE_BYTEVECTOR(DSTBV(tc), dest_size);
522           if (uf_read(uf, &BVIT(SRCBV(tc),0), src_size) < 0)
523             S_error1("", "unexpected eof in fasl file ~a", uf->path);
524           result = S_bytevector_uncompress(DSTBV(tc), 0, dest_size, SRCBV(tc), 0, src_size,
525                       (ty == fasl_type_gzip ? COMPRESS_GZIP : COMPRESS_LZ4));
526           if (result != FIX(dest_size)) {
527             if (Sstringp(result)) S_error2("fasl-read", "~@?", result, SRCBV(tc));
528             S_error3("fasl-read", "uncompressed size ~s for ~s is smaller than expected size ~s", result, SRCBV(tc), FIX(dest_size));
529           }
530           ffo.size = dest_size;
531           ffo.next = ffo.buf = &BVIT(DSTBV(tc),0);
532           ffo.end = &BVIT(DSTBV(tc),dest_size);
533           ffo.uf = uf;
534           bv = DSTBV(tc);
535           break;
536         }
537         case fasl_type_uncompressed: {
538           ffo.size = size - 2; /* adjust for u8 compression type and u8 fasl type */
539           ffo.next = ffo.end = ffo.buf = buf;
540           bv = (ptr)0;
541           ffo.uf = uf;
542           break;
543         }
544         default:
545           S_error2("", "malformed fasl-object header (missing possibly-compressed, got ~s) found in ~a", FIX(ty), uf->path);
546           return (ptr)0;
547       }
548       switch (kind) {
549         case fasl_type_fasl:
550           faslin(tc, &x, externals, &strbuf, &ffo);
551           break;
552         case fasl_type_vfasl:
553           x = S_vfasl(bv, uf, 0, ffo.size);
554           break;
555         default:
556           S_error2("", "malformed fasl-object header (got ~s) found in ~a", FIX(ty), uf->path);
557           return (ptr)0;
558       }
559       S_flush_instruction_cache(tc);
560       S_thread_end_code_write(tc, S_vfasl_boot_mode ? static_generation : 0, 1, NULL, 0);
561       return x;
562     } else {
563       uf_skipbytes(uf, size);
564     }
565   }
566 }
567 
bv_fasl_entry(ptr tc,ptr bv,int ty,uptr offset,uptr len,unbufFaslFile uf,ptr externals)568 static ptr bv_fasl_entry(ptr tc, ptr bv, int ty, uptr offset, uptr len, unbufFaslFile uf, ptr externals) {
569   ptr x; ptr strbuf = S_G.null_string;
570   struct faslFileObj ffo;
571 
572   S_thread_start_code_write(tc, S_vfasl_boot_mode ? static_generation : 0, 1, NULL, 0);
573 
574   if (ty == fasl_type_vfasl) {
575     x = S_vfasl(bv, NULL, offset, len);
576   } else if (ty == fasl_type_fasl) {
577     ffo.size = len;
578     ffo.next = ffo.buf = &BVIT(bv, offset);
579     ffo.end = &BVIT(bv, offset + len);
580     ffo.uf = uf;
581 
582     faslin(tc, &x, externals, &strbuf, &ffo);
583   } else {
584     S_error1("", "bad entry type (got ~s)", FIX(ty));
585   }
586 
587   S_flush_instruction_cache(tc);
588   S_thread_end_code_write(tc, S_vfasl_boot_mode ? static_generation : 0, 1, NULL, 0);
589 
590   return x;
591 }
592 
fillFaslFile(faslFile f)593 static void fillFaslFile(faslFile f) {
594   iptr n = f->size < SBUFSIZ ? f->size : SBUFSIZ;
595   if (uf_read(f->uf, f->buf, n) < 0)
596     S_error1("", "unexpected eof in fasl file ~a", f->uf->path);
597   f->end = (f->next = f->buf) + n;
598   f->size -= n;
599 }
600 
601 #define bytein(f) ((((f)->next == (f)->end) ? fillFaslFile(f) : (void)0), *((f)->next++))
602 
bytesin(octet * s,iptr n,faslFile f)603 static void bytesin(octet *s, iptr n, faslFile f) {
604   iptr avail = f->end - f->next;
605   if (avail < n) {
606     if (avail != 0) {
607       memcpy(s, f->next, avail);
608       f->next = f->end;
609       n -= avail;
610       s += avail;
611     }
612     if (uf_read(f->uf, s, n) < 0)
613       S_error1("", "unexpected eof in fasl file ~a", f->uf->path);
614     f->size -= n;
615   } else {
616     memcpy(s, f->next, n);
617     f->next += n;
618   }
619 }
620 
code_bytesin(octet * s,iptr n,faslFile f)621 static void code_bytesin(octet *s, iptr n, faslFile f) {
622 #ifdef CANNOT_READ_DIRECTLY_INTO_CODE
623   while (1) {
624     iptr avail = f->end - f->next;
625     if (avail < n) {
626       bytesin(s, avail, f);
627       n -= avail;
628       s += avail;
629       fillFaslFile(f);
630     } else {
631       bytesin(s, n, f);
632       break;
633     }
634   }
635 #else
636   bytesin(s, n, f);
637 #endif
638 }
639 
toolarge(ptr path)640 static void toolarge(ptr path) {
641   S_error1("", "fasl value too large for this machine type in ~a", path);
642 }
643 
iptrin(faslFile f)644 static iptr iptrin(faslFile f) {
645   uptr n, m; octet k, k0;
646 
647   k0 = k = bytein(f);
648   n = (k & 0x7f) >> 1;
649   while (k & 1) {
650     k = bytein(f);
651     m = n << 7;
652     if (m >> 7 != n) toolarge(f->uf->path);
653     n = m | (k >> 1);
654   }
655 
656   if (k0 & 0x80) {
657     if (n < ((uptr)1 << (ptr_bits - 1))) {
658       return -(iptr)n;
659     } else if (n > ((uptr)1 << (ptr_bits - 1))) {
660       toolarge(f->uf->path);
661     }
662 #if (fixnum_bits > 32)
663     return (iptr)0x8000000000000000;
664 #else
665     return (iptr)0x80000000;
666 #endif
667   } else {
668     if (n >= ((uptr)1 << (ptr_bits - 1))) toolarge(f->uf->path);
669     return (iptr)n;
670   }
671 }
672 
uptrin(faslFile f)673 static uptr uptrin(faslFile f) {
674   uptr n, m; octet k;
675 
676   k = bytein(f);
677   n = (k & 0x7F);
678   while (k & 0x80) {
679     k = bytein(f);
680     m = n << 7;
681     if (m >> 7 != n) toolarge(f->uf->path);
682     n = m | (k & 0x7F);
683   }
684 
685   return n;
686 }
687 
singlein(faslFile f)688 static float singlein(faslFile f) {
689   union { float f; U32 u; } val;
690 
691   val.u = (U32)uptrin(f);
692 
693   return val.f;
694 }
695 
doublein(faslFile f)696 static double doublein(faslFile f) {
697 #ifdef LITTLE_ENDIAN_IEEE_DOUBLE
698   union { double d; struct { U32 l; U32 h; } u; } val;
699 #else
700   union { double d; struct { U32 h; U32 l; } u; } val;
701 #endif
702 
703   val.u.h = (U32)uptrin(f);
704   val.u.l = (U32)uptrin(f);
705 
706   return val.d;
707 }
708 
stringin(ptr * pstrbuf,iptr start,faslFile f)709 static iptr stringin(ptr *pstrbuf, iptr start, faslFile f) {
710   iptr end, n, i; ptr p = *pstrbuf;
711 
712   end = start + (n = uptrin(f));
713   if (Sstring_length(*pstrbuf) < end) {
714      ptr newp = S_string((char *)0, end);
715      for (i = 0; i != start; i += 1) Sstring_set(newp, i, Sstring_ref(p, i));
716      *pstrbuf = p = newp;
717   }
718   for (i = start; i != end; i += 1) Sstring_set(p, i, uptrin(f));
719   return n;
720 }
721 
faslin(ptr tc,ptr * x,ptr t,ptr * pstrbuf,faslFile f)722 static void faslin(ptr tc, ptr *x, ptr t, ptr *pstrbuf, faslFile f) {
723     IFASLCODE ty = bytein(f);
724     switch (ty) {
725         case fasl_type_pair: {
726             iptr n; ptr p;
727             n = uptrin(f);
728             *x = p = Scons(FIX(0), FIX(0));
729             faslin(tc, &INITCAR(p), t, pstrbuf, f);
730             while (--n) {
731                 INITCDR(p) = Scons(FIX(0), FIX(0));
732                 p = INITCDR(p);
733                 faslin(tc, &INITCAR(p), t, pstrbuf, f);
734             }
735             faslin(tc, &INITCDR(p), t, pstrbuf, f);
736             return;
737         }
738         case fasl_type_box:
739         case fasl_type_immutable_box:
740             *x = Sbox(FIX(0));
741             faslin(tc, &INITBOXREF(*x), t, pstrbuf, f);
742             if (ty == fasl_type_immutable_box)
743               BOXTYPE(*x) = type_immutable_box;
744             return;
745         case fasl_type_symbol: {
746             iptr n;
747             n = stringin(pstrbuf, 0, f);
748             *x = S_intern_sc(&STRIT(*pstrbuf, 0), n, Sfalse);
749             return;
750         }
751         case fasl_type_gensym: {
752             iptr pn, un;
753             pn = stringin(pstrbuf, 0, f);
754             un = stringin(pstrbuf, pn, f);
755             *x = S_intern3(&STRIT(*pstrbuf, 0), pn, &STRIT(*pstrbuf, pn), un, Sfalse, Sfalse);
756             return;
757         }
758         case fasl_type_uninterned_symbol: {
759             iptr i, n;
760             ptr str;
761             n = uptrin(f);
762             str = S_string((char *)0, n);
763             for (i = 0; i != n; i += 1) Sstring_set(str, i, uptrin(f));
764             STRTYPE(str) |= string_immutable_flag;
765             *x = S_uninterned(str);
766             return;
767         }
768         case fasl_type_ratnum:
769             *x = S_rational(FIX(0), FIX(0));
770             faslin(tc, &RATNUM(*x), t, pstrbuf, f);
771             faslin(tc, &RATDEN(*x), t, pstrbuf, f);
772             return;
773         case fasl_type_exactnum:
774             *x = S_exactnum(FIX(0), FIX(0));
775             faslin(tc, &EXACTNUM_REAL_PART(*x), t, pstrbuf, f);
776             faslin(tc, &EXACTNUM_IMAG_PART(*x), t, pstrbuf, f);
777             return;
778         case fasl_type_vector:
779         case fasl_type_immutable_vector: {
780             iptr n; ptr *p;
781             n = uptrin(f);
782             *x = S_vector(n);
783             p = &INITVECTIT(*x, 0);
784             while (n--) faslin(tc, p++, t, pstrbuf, f);
785             if (ty == fasl_type_immutable_vector) {
786               if (Svector_length(*x) == 0)
787                 *x = S_G.null_immutable_vector;
788               else
789                 VECTTYPE(*x) |= vector_immutable_flag;
790             }
791             return;
792         }
793         case fasl_type_fxvector: {
794             iptr n; ptr *p;
795             n = uptrin(f);
796             *x = S_fxvector(n);
797             p = &FXVECTIT(*x, 0);
798             while (n--) {
799               iptr t = iptrin(f);
800               if (!FIXRANGE(t)) toolarge(f->uf->path);
801               *p++ = FIX(t);
802             }
803             return;
804         }
805         case fasl_type_flvector: {
806             iptr n; double *p;
807             n = uptrin(f);
808             *x = S_flvector(n);
809             p = &FLVECTIT(*x, 0);
810             while (n--) {
811               ptr fl;
812               faslin(tc, &fl, t, pstrbuf, f);
813               if (!Sflonump(fl))
814                 S_error1("", "not a flonum in flvector ~a", f->uf->path);
815               *p++ = Sflonum_value(fl);
816             }
817             return;
818         }
819         case fasl_type_bytevector:
820         case fasl_type_immutable_bytevector: {
821             iptr n;
822             n = uptrin(f);
823             *x = S_bytevector(n);
824             bytesin(&BVIT(*x,0), n, f);
825             if (ty == fasl_type_immutable_bytevector) {
826               if (Sbytevector_length(*x) == 0)
827                 *x = S_G.null_immutable_bytevector;
828               else
829                 BYTEVECTOR_TYPE(*x) |= bytevector_immutable_flag;
830             }
831             return;
832         }
833         case fasl_type_stencil_vector: {
834             uptr mask; iptr n; ptr *p;
835             mask = uptrin(f);
836             *x = S_stencil_vector(mask);
837             p = &INITSTENVECTIT(*x, 0);
838             n = Spopcount(mask);
839             while (n--) faslin(tc, p++, t, pstrbuf, f);
840             return;
841         }
842         case fasl_type_base_rtd: {
843             ptr rtd;
844             if ((rtd = S_G.base_rtd) == Sfalse) {
845               if (!Srecordp(rtd)) S_error_abort("S_G.base-rtd has not been set");
846             }
847             *x = rtd;
848             return;
849         } case fasl_type_rtd: {
850             ptr rtd, rtd_uid, plist, ls; uptr size;
851 
852             faslin(tc, &rtd_uid, t, pstrbuf, f);
853 
854             tc_mutex_acquire();
855 
856            /* look for rtd on uid's property list */
857             plist = SYMSPLIST(rtd_uid);
858             for (ls = plist; ls != Snil; ls = Scdr(Scdr(ls))) {
859               if (Scar(ls) == S_G.rtd_key) {
860                 ptr tmp;
861                 *x = rtd = Scar(Scdr(ls));
862 
863                 size = uptrin(f);
864                 if (size != 0) {
865                   fasl_record(tc, &tmp, t, pstrbuf, f, size);
866                   if (!rtd_equiv(tmp, rtd))
867                     S_error2("", "incompatible record type ~s in ~a", RECORDDESCNAME(tmp), f->uf->path);
868                 }
869                 tc_mutex_release();
870                 return;
871               }
872             }
873 
874             size = uptrin(f);
875             if (size == 0)
876               S_error2("", "unregistered record type ~s in ~a", rtd_uid, f->uf->path);
877             fasl_record(tc, x, t, pstrbuf, f, size);
878             rtd = *x;
879 
880            /* register rtd on uid's property list */
881             SETSYMSPLIST(rtd_uid, Scons(S_G.rtd_key, Scons(rtd, plist)));
882 
883             tc_mutex_release();
884 
885             return;
886         }
887         case fasl_type_record: {
888             uptr size = uptrin(f);
889             fasl_record(tc, x, t, pstrbuf, f, size);
890             return;
891         }
892         case fasl_type_eq_hashtable: {
893             ptr rtd, ht, v; uptr subtype; uptr veclen, i, n;
894             if ((rtd = S_G.eq_ht_rtd) == Sfalse) {
895               S_G.eq_ht_rtd = rtd = SYMVAL(S_intern((const unsigned char *)"$eq-ht-rtd"));
896               if (!Srecordp(rtd)) S_error_abort("$eq-ht-rtd has not been set");
897             }
898             *x = ht = S_record(size_record_inst(UNFIX(RECORDDESCSIZE(rtd))));
899             RECORDINSTTYPE(ht) = rtd;
900             INITPTRFIELD(ht,eq_hashtable_type_disp) = S_G.eq_symbol;
901             INITPTRFIELD(ht,eq_hashtable_mutablep_disp) = bytein(f) ? Strue : Sfalse;
902             switch ((subtype = bytein(f))) {
903             case eq_hashtable_subtype_normal:
904             case eq_hashtable_subtype_weak:
905             case eq_hashtable_subtype_ephemeron:
906               INITPTRFIELD(ht,eq_hashtable_subtype_disp) = FIX(subtype);
907               break;
908             default:
909               S_error2("", "invalid eq-hashtable subtype code", FIX(subtype), f->uf->path);
910             }
911             INITPTRFIELD(ht,eq_hashtable_minlen_disp) = FIX(uptrin(f));
912             veclen = uptrin(f);
913             INITPTRFIELD(ht,eq_hashtable_vec_disp) = v = S_vector(veclen);
914             n = uptrin(f);
915             INITPTRFIELD(ht,eq_hashtable_size_disp) = FIX(n);
916             for (i = 0; i < veclen ; i += 1) { INITVECTIT(v, i) = FIX(i); }
917             while (n > 0) {
918               ptr keyval;
919               switch (subtype) {
920               case eq_hashtable_subtype_normal:
921                 keyval = Scons(FIX(0), FIX(0));
922                 break;
923               case eq_hashtable_subtype_weak:
924                 keyval = S_cons_in(tc, space_weakpair, 0, FIX(0), FIX(0));
925                 break;
926               case eq_hashtable_subtype_ephemeron:
927               default:
928                 keyval = S_ephemeron_cons_in(0, FIX(0), FIX(0));
929                 break;
930               }
931               faslin(tc, &INITCAR(keyval), t, pstrbuf, f);
932               faslin(tc, &INITCDR(keyval), t, pstrbuf, f);
933               i = eq_hash(Scar(keyval)) & (veclen - 1);
934               INITVECTIT(v, i) = S_tlc(keyval, ht, Svector_ref(v, i));
935               n -= 1;
936             }
937             return;
938         }
939         case fasl_type_symbol_hashtable: {
940             ptr rtd, ht, equiv, v; uptr equiv_code, veclen, i, n;
941             if ((rtd = S_G.symbol_ht_rtd) == Sfalse) {
942               S_G.symbol_ht_rtd = rtd = SYMVAL(S_intern((const unsigned char *)"$symbol-ht-rtd"));
943               if (!Srecordp(rtd)) S_error_abort("$symbol-ht-rtd has not been set");
944             }
945             *x = ht = S_record(size_record_inst(UNFIX(RECORDDESCSIZE(rtd))));
946             RECORDINSTTYPE(ht) = rtd;
947             INITPTRFIELD(ht,symbol_hashtable_type_disp) = S_G.symbol_symbol;
948             INITPTRFIELD(ht,symbol_hashtable_mutablep_disp) = bytein(f) ? Strue : Sfalse;
949             INITPTRFIELD(ht,symbol_hashtable_minlen_disp) = FIX(uptrin(f));
950             equiv_code = bytein(f);
951             switch (equiv_code) {
952               case 0:
953                 if ((equiv = S_G.eqp) == Sfalse) {
954                   S_G.eqp = equiv = SYMVAL(S_intern((const unsigned char *)"eq?"));
955                   if (!Sprocedurep(equiv)) S_error_abort("fasl: eq? has not been set");
956                 }
957                 break;
958               case 1:
959                 if ((equiv = S_G.eqvp) == Sfalse) {
960                   S_G.eqvp = equiv = SYMVAL(S_intern((const unsigned char *)"eqv?"));
961                   if (!Sprocedurep(equiv)) S_error_abort("fasl: eqv? has not been set");
962                 }
963                 break;
964               case 2:
965                 if ((equiv = S_G.equalp) == Sfalse) {
966                   S_G.equalp = equiv = SYMVAL(S_intern((const unsigned char *)"equal?"));
967                   if (!Sprocedurep(equiv)) S_error_abort("fasl: equal? has not been set");
968                 }
969                 break;
970               case 3:
971                 if ((equiv = S_G.symboleqp) == Sfalse) {
972                   S_G.symboleqp = equiv = SYMVAL(S_intern((const unsigned char *)"symbol=?"));
973                   if (!Sprocedurep(equiv)) S_error_abort("fasl: symbol=? has not been set");
974                 }
975                 break;
976               default:
977                 S_error2("", "invalid symbol-hashtable equiv code", FIX(equiv_code), f->uf->path);
978                 /* make compiler happy */
979                 equiv = Sfalse;
980             }
981             INITPTRFIELD(ht,symbol_hashtable_equivp_disp) = equiv;
982             veclen = uptrin(f);
983             INITPTRFIELD(ht,symbol_hashtable_vec_disp) = v = S_vector(veclen);
984             n = uptrin(f);
985             INITPTRFIELD(ht,symbol_hashtable_size_disp) = FIX(n);
986             for (i = 0; i < veclen ; i += 1) { INITVECTIT(v, i) = Snil; }
987             while (n > 0) {
988               ptr keyval;
989               keyval = Scons(FIX(0), FIX(0));
990               faslin(tc, &INITCAR(keyval), t, pstrbuf, f);
991               faslin(tc, &INITCDR(keyval), t, pstrbuf, f);
992               i = UNFIX(SYMHASH(Scar(keyval))) & (veclen - 1);
993               INITVECTIT(v, i) = Scons(keyval, Svector_ref(v, i));
994               n -= 1;
995             }
996             return;
997         }
998         case fasl_type_closure: {
999             ptr cod; iptr offset;
1000             offset = uptrin(f);
1001             *x = S_closure((ptr)0, 0);
1002             faslin(tc, &cod, t, pstrbuf, f);
1003             CLOSENTRY(*x) = (ptr)((uptr)cod + offset);
1004             return;
1005         }
1006         case fasl_type_flonum: {
1007             *x = Sflonum(doublein(f));
1008             return;
1009         }
1010         case fasl_type_inexactnum: {
1011             ptr rp, ip;
1012             faslin(tc, &rp, t, pstrbuf, f);
1013             faslin(tc, &ip, t, pstrbuf, f);
1014             *x = S_inexactnum(FLODAT(rp), FLODAT(ip));
1015             return;
1016         }
1017         case fasl_type_string:
1018         case fasl_type_immutable_string: {
1019             iptr i, n; ptr str;
1020             n = uptrin(f);
1021             str = S_string((char *)0, n);
1022             for (i = 0; i != n; i += 1) Sstring_set(str, i, uptrin(f));
1023             if (ty == fasl_type_immutable_string) {
1024               if (n == 0)
1025                 str = S_G.null_immutable_string;
1026               else
1027                 STRTYPE(str) |= string_immutable_flag;
1028             }
1029             *x = str;
1030             return;
1031         }
1032         case fasl_type_small_integer:
1033             *x = Sinteger(iptrin(f));
1034             return;
1035         case fasl_type_large_integer: {
1036             IBOOL sign; iptr n; ptr t; bigit *p;
1037             sign = bytein(f);
1038             n = uptrin(f);
1039             t = S_bignum(tc, n, sign);
1040             p = &BIGIT(t, 0);
1041             while (n--) *p++ = (bigit)uptrin(f);
1042             *x = S_normalize_bignum(t);
1043             return;
1044         }
1045         case fasl_type_weak_pair:
1046             *x = S_cons_in(tc, space_weakpair, 0, FIX(0), FIX(0));
1047             faslin(tc, &INITCAR(*x), t, pstrbuf, f);
1048             faslin(tc, &INITCDR(*x), t, pstrbuf, f);
1049             return;
1050         case fasl_type_ephemeron:
1051             *x = S_ephemeron_cons_in(0, FIX(0), FIX(0));
1052             faslin(tc, &INITCAR(*x), t, pstrbuf, f);
1053             faslin(tc, &INITCDR(*x), t, pstrbuf, f);
1054             return;
1055         case fasl_type_code: {
1056             iptr n, m, a; INT flags; iptr free;
1057             ptr co, reloc, name, pinfos;
1058             flags = bytein(f);
1059             free = uptrin(f);
1060             n = uptrin(f) /* length in bytes of code */;
1061             *x = co = S_code(tc, type_code | (flags << code_flags_offset), n);
1062             CODEFREE(co) = free;
1063             faslin(tc, &name, t, pstrbuf, f);
1064             if (Sstringp(name)) name = SYMNAME(S_intern_sc(&STRIT(name, 0), Sstring_length(name), name));
1065             CODENAME(co) = name;
1066             faslin(tc, &CODEARITYMASK(co), t, pstrbuf, f);
1067             faslin(tc, &CODEINFO(co), t, pstrbuf, f);
1068             faslin(tc, &pinfos, t, pstrbuf, f);
1069             CODEPINFOS(co) = pinfos;
1070             if (pinfos != Snil) {
1071               S_G.profile_counters = Scons(S_weak_cons(co, pinfos), S_G.profile_counters);
1072             }
1073             code_bytesin((octet *)&CODEIT(co, 0), n, f);
1074 #ifdef PORTABLE_BYTECODE_BIGENDIAN
1075             swap_code_endian((octet *)&CODEIT(co, 0), n);
1076 #endif
1077             m = uptrin(f);
1078             CODERELOC(co) = reloc = S_relocation_table(m);
1079             RELOCCODE(reloc) = co;
1080             a = 0;
1081             n = 0;
1082             while (n < m) {
1083               INT type_etc, type; uptr item_off, code_off;
1084               ptr obj;
1085               type_etc = bytein(f);
1086               type = type_etc >> 2;
1087               code_off = uptrin(f);
1088               item_off = (type_etc & 2) ? uptrin(f) : 0;
1089               if (type_etc & 1) {
1090                 RELOCIT(reloc,n) = (type << reloc_type_offset)|reloc_extended_format ;    n += 1;
1091                 RELOCIT(reloc,n) = item_off; n += 1;
1092                 RELOCIT(reloc,n) = code_off; n += 1;
1093               } else {
1094                 RELOCIT(reloc,n) = MAKE_SHORT_RELOC(type,code_off,item_off); n += 1;
1095               }
1096               a += code_off;
1097               faslin(tc, &obj, t, pstrbuf, f);
1098               S_set_code_obj("read", type, co, a, obj, item_off);
1099             }
1100             return;
1101         }
1102         case fasl_type_immediate:
1103             *x = (ptr)uptrin(f);
1104             return;
1105         case fasl_type_entry:
1106             *x = (ptr)S_lookup_c_entry(uptrin(f));
1107             return;
1108         case fasl_type_library:
1109             *x = S_lookup_library_entry(uptrin(f), 1);
1110             return;
1111         case fasl_type_library_code:
1112             *x = CLOSCODE(S_lookup_library_entry(uptrin(f), 1));
1113             return;
1114         case fasl_type_phantom:
1115             *x = S_phantom_bytevector(uptrin(f));
1116             return;
1117         case fasl_type_graph: {
1118             uptr len = uptrin(f), len2, i;
1119             ptr new_t = S_vector(len);
1120             len2 = Svector_length(t);
1121             if (len2 > len) len2 = len;
1122             for (i = 0; i < len2; i++)
1123               INITVECTIT(new_t, i+(len-len2)) = Svector_ref(t, i);
1124             faslin(tc, x, new_t, pstrbuf, f);
1125             return;
1126         }
1127         case fasl_type_graph_def: {
1128             ptr *p;
1129             p = &INITVECTIT(t, uptrin(f));
1130             faslin(tc, p, t, pstrbuf, f);
1131             *x = *p;
1132             return;
1133         }
1134         case fasl_type_graph_ref:
1135             *x = Svector_ref(t, uptrin(f));
1136             return;
1137         case fasl_type_begin: {
1138             uptr n = uptrin(f) - 1; ptr v;
1139             while (n--)
1140               faslin(tc, &v, t, pstrbuf, f);
1141             faslin(tc, x, t, pstrbuf, f);
1142             return;
1143         }
1144         default:
1145             S_error2("", "invalid object type ~d in fasl file ~a", FIX(ty), f->uf->path);
1146     }
1147 }
1148 
1149 #define big 0
1150 #define little 1
1151 #ifdef PORTABLE_BYTECODE
1152 # ifdef PORTABLE_BYTECODE_BIGENDIAN
1153 #  define unknown big
1154 # else
1155 #  define unknown little
1156 # endif
1157 #else
1158 # define unknown 3
1159 #endif
fasl_record(ptr tc,ptr * x,ptr t,ptr * pstrbuf,faslFile f,uptr size)1160 static void fasl_record(ptr tc, ptr *x, ptr t, ptr *pstrbuf, faslFile f, uptr size) {
1161   uptr n, addr; ptr p; UINT padty;
1162 
1163   n = uptrin(f);
1164   *x = p = S_record(size_record_inst(size));
1165   faslin(tc, &RECORDINSTTYPE(p), t, pstrbuf, f);
1166   addr = (uptr)TO_PTR(&RECORDINSTIT(p, 0));
1167   for (; n != 0; n -= 1) {
1168     padty = bytein(f);
1169     addr += padty >> 4;
1170     switch (padty & 0xf) {
1171       case fasl_fld_ptr:
1172         faslin(tc, TO_VOIDP(addr), t, pstrbuf, f);
1173         addr += sizeof(ptr);
1174         break;
1175       case fasl_fld_u8:
1176         *(U8 *)TO_VOIDP(addr) = (U8)bytein(f);
1177         addr += 1;
1178         break;
1179       case fasl_fld_i16:
1180         *(I16 *)TO_VOIDP(addr) = (I16)iptrin(f);
1181         addr += 2;
1182         break;
1183       case fasl_fld_i24: {
1184         iptr q = iptrin(f);
1185 #if (native_endianness == little)
1186         *(U16 *)TO_VOIDP(addr) = (U16)q;
1187         *(U8 *)TO_VOIDP(addr + 2) = (U8)(q >> 16);
1188 #elif (native_endianness == big)
1189         *(U16 *)TO_VOIDP(addr) = (U16)(q >> 8);
1190         *(U8 *)TO_VOIDP(addr + 2) = (U8)q;
1191 #else
1192         unexpected_endianness();
1193 #endif
1194         addr += 3;
1195         break;
1196       }
1197       case fasl_fld_i32:
1198         *(I32 *)TO_VOIDP(addr) = (I32)iptrin(f);
1199         addr += 4;
1200         break;
1201       case fasl_fld_i40: {
1202         I64 q;
1203 #if (ptr_bits == 32)
1204         q = (I64)iptrin(f) << 32;
1205         q |= (U32)uptrin(f);
1206 #elif (ptr_bits == 64)
1207         q = (I64)iptrin(f);
1208 #else
1209         unexpected_ptr_bits();
1210 #endif
1211 #if (native_endianness == little)
1212         *(U32 *)TO_VOIDP(addr) = (U32)q;
1213         *(U8 *)TO_VOIDP(addr + 4) = (U8)(q >> 32);
1214 #elif (native_endianness == big)
1215         *(U32 *)TO_VOIDP(addr) = (U32)(q >> 8);
1216         *(U8 *)TO_VOIDP(addr + 4) = (U8)q;
1217 #else
1218         unexpected_endianness();
1219 #endif
1220         addr += 5;
1221         break;
1222       }
1223       case fasl_fld_i48: {
1224         I64 q;
1225 #if (ptr_bits == 32)
1226         q = (I64)iptrin(f) << 32;
1227         q |= (U32)uptrin(f);
1228 #elif (ptr_bits == 64)
1229         q = (I64)iptrin(f);
1230 #else
1231         unexpected_ptr_bits();
1232 #endif
1233 #if (native_endianness == little)
1234         *(U32 *)TO_VOIDP(addr) = (U32)q;
1235         *(U16 *)TO_VOIDP(addr + 4) = (U16)(q >> 32);
1236 #elif (native_endianness == big)
1237         *(U32 *)TO_VOIDP(addr) = (U32)(q >> 16);
1238         *(U16 *)TO_VOIDP(addr + 4) = (U16)q;
1239 #else
1240         unexpected_endianness();
1241 #endif
1242         addr += 6;
1243         break;
1244       }
1245       case fasl_fld_i56: {
1246         I64 q;
1247 #if (ptr_bits == 32)
1248         q = (I64)iptrin(f) << 32;
1249         q |= (U32)uptrin(f);
1250 #elif (ptr_bits == 64)
1251         q = (I64)iptrin(f);
1252 #else
1253         unexpected_ptr_bits();
1254 #endif
1255 #if (native_endianness == little)
1256         *(U32 *)TO_VOIDP(addr) = (U32)q;
1257         *(U16 *)TO_VOIDP(addr + 4) = (U16)(q >> 32);
1258         *(U8 *)TO_VOIDP(addr + 6) = (U8)(q >> 48);
1259 #elif (native_endianness == big)
1260         *(U32 *)TO_VOIDP(addr) = (U32)(q >> 24);
1261         *(U32 *)TO_VOIDP(addr + 3) = (U32)q;
1262 #else
1263         unexpected_endianness();
1264 #endif
1265         addr += 7;
1266         break;
1267       }
1268       case fasl_fld_i64: {
1269         I64 q;
1270 #if (ptr_bits == 32)
1271         q = (I64)iptrin(f) << 32;
1272         q |= (U32)uptrin(f);
1273 #elif (ptr_bits == 64)
1274         q = (I64)iptrin(f);
1275 #else
1276         unexpected_ptr_bits();
1277 #endif
1278         *(I64 *)TO_VOIDP(addr) = q;
1279         addr += 8;
1280         break;
1281       }
1282       case fasl_fld_single:
1283         *(float *)TO_VOIDP(addr) = (float)singlein(f);
1284         addr += sizeof(float);
1285         break;
1286       case fasl_fld_double:
1287         *(double *)TO_VOIDP(addr) = (double)doublein(f);
1288         addr += sizeof(double);
1289         break;
1290       default:
1291         S_error1("", "unrecognized record fld type ~d", FIX(padty & 0xf));
1292         break;
1293     }
1294   }
1295 }
1296 
1297 /* Call with tc mutex.
1298    Result: 0 => interned; 1 => replaced; -1 => inconsistent */
S_fasl_intern_rtd(ptr * x)1299 int S_fasl_intern_rtd(ptr *x)
1300 {
1301   ptr rtd, rtd_uid, plist, ls;
1302 
1303   rtd = *x;
1304   rtd_uid = RECORDDESCUID(rtd);
1305 
1306   /* see if uid's property list already registers an rtd */
1307   plist = SYMSPLIST(rtd_uid);
1308   for (ls = plist; ls != Snil; ls = Scdr(Scdr(ls))) {
1309     if (Scar(ls) == S_G.rtd_key) {
1310       ptr old_rtd = Scar(Scdr(ls));
1311       /* if so, check new rtd against old rtd and return old rtd */
1312       if (!rtd_equiv(rtd, old_rtd))
1313         return -1;
1314       else
1315         *x = old_rtd;
1316       return 1;
1317     }
1318   }
1319 
1320   /* if not, register it */
1321   SETSYMSPLIST(rtd_uid, Scons(S_G.rtd_key, Scons(rtd, plist)));
1322   return 0;
1323 }
1324 
1325 /* limited version for checking rtd fields */
equalp(x,y)1326 static IBOOL equalp(x, y) ptr x, y; {
1327   if (x == y) return 1;
1328   if (Spairp(x)) return Spairp(y) && equalp(Scar(x), Scar(y)) && equalp(Scdr(x), Scdr(y));
1329   if (Svectorp(x)) {
1330     iptr n;
1331     if (!Svectorp(y)) return 0;
1332     if ((n = Svector_length(x)) != Svector_length(y)) return 0;
1333     while (--n >= 0) if (!equalp(Svector_ref(x, n), Svector_ref(y, n))) return 0;
1334     return 1;
1335   }
1336   return Sbignump(x) && Sbignump(y) && S_big_eq(x, y);
1337 }
1338 
rtd_equiv(x,y)1339 static IBOOL rtd_equiv(x, y) ptr x, y; {
1340   return ((RECORDINSTTYPE(x) == RECORDINSTTYPE(y))
1341           /* recognize `base-rtd` shape: */
1342           || ((RECORDINSTTYPE(x) == x)
1343               && (RECORDINSTTYPE(y) == y))) &&
1344          rtd_parent(x) == rtd_parent(y) &&
1345          equalp(RECORDDESCPM(x), RECORDDESCPM(y)) &&
1346          equalp(RECORDDESCMPM(x), RECORDDESCMPM(y)) &&
1347          equalp(RECORDDESCFLDS(x), RECORDDESCFLDS(y)) &&
1348          RECORDDESCSIZE(x) == RECORDDESCSIZE(y) &&
1349          RECORDDESCFLAGS(x) == RECORDDESCFLAGS(y);
1350 }
1351 
1352 #ifdef HPUX
pax_decode21(INT x)1353 INT pax_decode21(INT x)
1354 {
1355   INT x0_4, x5_6, x7_8, x9_19, x20;
1356 
1357   x20   = x & 0x1; x >>= 1;
1358   x9_19 = x & 0x7ff; x >>= 11;
1359   x7_8  = x & 0x3; x >>= 2;
1360   x5_6  = x & 0x3;
1361   x0_4  = x >> 2;
1362 
1363   return (((x20<<11 | x9_19)<<2 | x5_6)<<5 | x0_4)<<2 | x7_8;
1364 }
1365 
pax_encode21(INT n)1366 INT pax_encode21(INT n)
1367 {
1368   INT x0_4, x5_6, x7_8, x9_19, x20;
1369 
1370   x7_8  = n & 0x3; n >>= 2;
1371   x0_4  = n & 0x1f; n >>= 5;
1372   x5_6  = n & 0x3; n >>= 2;
1373   x9_19 = n & 0x7ff;
1374   x20   = n >> 11;
1375 
1376   return (((x0_4<<2 | x5_6)<<2 | x7_8)<<11 | x9_19)<<1 | x20;
1377 }
1378 #endif /* HPUX */
1379 
1380 /* used here, in S_gc(), and in compile.ss */
S_set_code_obj(who,typ,p,n,x,o)1381 void S_set_code_obj(who, typ, p, n, x, o) char *who; IFASLCODE typ; iptr n, o; ptr p, x; {
1382     void *address; uptr item;
1383 
1384     address = TO_VOIDP((uptr)p + n);
1385     item = (uptr)x + o;
1386     switch (typ) {
1387         case reloc_abs:
1388             *(uptr *)address = item;
1389             break;
1390 #ifdef PORTABLE_BYTECODE
1391         case reloc_pb_abs:
1392         case reloc_pb_proc:
1393             pb_set_abs(address, item);
1394             break;
1395 #endif /* AARCH64 */
1396 #ifdef ARMV6
1397         case reloc_arm32_abs:
1398             arm32_set_abs(address, item);
1399             break;
1400         case reloc_arm32_jump:
1401             arm32_set_jump(address, item, 0);
1402             break;
1403         case reloc_arm32_call:
1404             arm32_set_jump(address, item, 1);
1405             break;
1406 #endif /* ARMV6 */
1407 #ifdef AARCH64
1408         case reloc_arm64_abs:
1409         case reloc_arm64_jump:
1410         case reloc_arm64_call:
1411             arm64_set_abs(address, item);
1412             break;
1413 #endif /* AARCH64 */
1414 #ifdef PPC32
1415         case reloc_ppc32_abs:
1416             ppc32_set_abs(address, item);
1417             break;
1418         case reloc_ppc32_jump:
1419             ppc32_set_jump(address, item, 0);
1420             break;
1421         case reloc_ppc32_call:
1422             ppc32_set_jump(address, item, 1);
1423             break;
1424 #endif /* PPC32 */
1425 #ifdef I386
1426         case reloc_rel:
1427             item = item - ((uptr)address + sizeof(uptr));
1428             *(uptr *)address = item;
1429             break;
1430 #endif /* I386 */
1431 #ifdef X86_64
1432         case reloc_x86_64_jump:
1433             x86_64_set_jump(address, item, 0);
1434             break;
1435         case reloc_x86_64_call:
1436             x86_64_set_jump(address, item, 1);
1437             break;
1438         case reloc_x86_64_popcount:
1439             x86_64_set_popcount(address, item);
1440             break;
1441 #endif /* X86_64 */
1442 #ifdef SPARC64
1443         case reloc_sparc64abs:
1444             sparc64_set_literal(address, item);
1445             break;
1446       /* we don't use this presently since it can't handle out-of-range
1447          relocations */
1448         case reloc_sparc64rel:
1449            /* later: make the damn thing local by copying it an
1450               every other code object we can reach into a single
1451               close area of memory */
1452             item = item - (uptr)address;
1453             if ((iptr)item < -0x20000000 || (iptr)item > 0x1FFFFFFF)
1454               S_error1("", "sparc64rel address out of range ~x",
1455                        Sunsigned((uptr)address));
1456             *(U32 *)address = *(U32 *)address & ~0x3fffffff | item >> 2 & 0x3fffffff;
1457             break;
1458 #endif /* SPARC64 */
1459 #ifdef SPARC
1460         case reloc_sparcabs:
1461             *(U32 *)address = *(U32 *)address & ~0x3fffff | item >> 10 & 0x3fffff;
1462             *((U32 *)address + 1) = *((U32 *)address + 1) & ~0x3ff | item & 0x3ff;
1463             break;
1464         case reloc_sparcrel:
1465             item = item - (uptr)address;
1466             *(U32 *)address = *(U32 *)address & ~0x3fffffff | item >> 2 & 0x3fffffff;
1467             break;
1468 #endif /* SPARC */
1469         default:
1470             S_error1(who, "invalid relocation type ~s", FIX(typ));
1471     }
1472 }
1473 
1474 /* used in S_gc() */
S_get_code_obj(typ,p,n,o)1475 ptr S_get_code_obj(typ, p, n, o) IFASLCODE typ; iptr n, o; ptr p; {
1476     void *address; uptr item;
1477 
1478     address = TO_VOIDP((uptr)p + n);
1479     switch (typ) {
1480         case reloc_abs:
1481             item = *(uptr *)address;
1482             break;
1483 #ifdef PORTABLE_BYTECODE
1484         case reloc_pb_abs:
1485         case reloc_pb_proc:
1486             item = pb_get_abs(address);
1487             break;
1488 #endif /* AARCH64 */
1489 #ifdef ARMV6
1490         case reloc_arm32_abs:
1491             item = arm32_get_abs(address);
1492             break;
1493         case reloc_arm32_jump:
1494         case reloc_arm32_call:
1495             item = arm32_get_jump(address);
1496             break;
1497 #endif /* ARMV6 */
1498 #ifdef AARCH64
1499         case reloc_arm64_abs:
1500         case reloc_arm64_jump:
1501         case reloc_arm64_call:
1502             item = arm64_get_abs(address);
1503             break;
1504 #endif /* AARCH64 */
1505 #ifdef PPC32
1506         case reloc_ppc32_abs:
1507             item = ppc32_get_abs(address);
1508             break;
1509         case reloc_ppc32_jump:
1510         case reloc_ppc32_call:
1511             item = ppc32_get_jump(address);
1512             break;
1513 #endif /* PPC32 */
1514 #ifdef I386
1515         case reloc_rel:
1516             item = *(uptr *)address;
1517             item = item + ((uptr)address + sizeof(uptr));
1518             break;
1519 #endif /* I386 */
1520 #ifdef X86_64
1521         case reloc_x86_64_jump:
1522         case reloc_x86_64_call:
1523             item = x86_64_get_jump(address);
1524             break;
1525         case reloc_x86_64_popcount:
1526             item = (uptr)Svector_ref(S_G.library_entry_vector, library_popcount_slow) + o;
1527             break;
1528 #endif /* X86_64 */
1529 #ifdef SPARC64
1530         case reloc_sparc64abs:
1531             item = sparc64_get_literal(address);
1532             break;
1533         case reloc_sparc64rel:
1534             item = (*(U32 *)address & 0x3fffffff) << 2;
1535             if (item & 0x80000000) /* sign bit set */
1536               item = item | 0xffffffff00000000;
1537             item = (uptr)address + (iptr)item;
1538             break;
1539 #endif /* SPARC64 */
1540 #ifdef SPARC
1541         case reloc_sparcabs:
1542             item = (*(U32 *)address & 0x3fffff) << 10 | *((U32 *)address + 1) & 0x3ff;
1543             break;
1544         case reloc_sparcrel:
1545             item = (*(U32 *)address & 0x3fffffff) << 2;
1546             item += (uptr)address;
1547             break;
1548 #endif /* SPARC */
1549         default:
1550             S_error1("", "invalid relocation type ~s", FIX(typ));
1551             return (ptr)0 /* not reached */;
1552     }
1553     return (ptr)(item - o);
1554 }
1555 
1556 #ifdef PORTABLE_BYTECODE
1557 
1558 /* Address pieces in a movz,movk,movk,movk sequence are upper 16 bits */
1559 #define ADDRESS_BITS_SHIFT 16
1560 #define ADDRESS_BITS_MASK  ((U32)0xFFFF0000)
1561 #define DEST_REG_MASK      0xF00
1562 
pb_set_abs(void * address,uptr item)1563 static void pb_set_abs(void *address, uptr item) {
1564   /* First word can have an arbitrary value due to vfasl offset
1565      storage, so get the target register from the end: */
1566 #if ptr_bytes == 8
1567   int dest_reg = ((U32 *)address)[3] & DEST_REG_MASK;
1568 #else
1569   int dest_reg = ((U32 *)address)[1] & DEST_REG_MASK;
1570 #endif
1571 
1572   /* pb_link is the same as pb_mov16_pb_zero_bits_pb_shift0, but with
1573      a promise of the subsequent instructions to load a full word */
1574 
1575   ((U32 *)address)[0] = (pb_link | dest_reg | ((item & 0xFFFF) << ADDRESS_BITS_SHIFT));
1576   ((U32 *)address)[1] = (pb_mov16_pb_keep_bits_pb_shift1 | dest_reg | (((item >> 16) & 0xFFFF) << ADDRESS_BITS_SHIFT));
1577 #if ptr_bytes == 8
1578   ((U32 *)address)[2] = (pb_mov16_pb_keep_bits_pb_shift2 | dest_reg | (((item >> 32) & 0xFFFF) << ADDRESS_BITS_SHIFT));
1579   ((U32 *)address)[3] = (pb_mov16_pb_keep_bits_pb_shift3 | dest_reg | (((item >> 48) & 0xFFFF) << ADDRESS_BITS_SHIFT));
1580 #endif
1581 }
1582 
pb_get_abs(void * address)1583 static uptr pb_get_abs(void *address) {
1584   return ((uptr)((((U32 *)address)[0] & ADDRESS_BITS_MASK) >> ADDRESS_BITS_SHIFT)
1585           | ((uptr)((((U32 *)address)[1] & ADDRESS_BITS_MASK) >> ADDRESS_BITS_SHIFT) << 16)
1586 #if ptr_bytes == 8
1587           | ((uptr)((((U32 *)address)[2] & ADDRESS_BITS_MASK) >> ADDRESS_BITS_SHIFT) << 32)
1588           | ((uptr)((((U32 *)address)[3] & ADDRESS_BITS_MASK) >> ADDRESS_BITS_SHIFT) << 48)
1589 #endif
1590           );
1591 }
1592 
1593 #endif /* PORTABLE_BYTECODE */
1594 
1595 #ifdef ARMV6
arm32_set_abs(void * address,uptr item)1596 static void arm32_set_abs(void *address, uptr item) {
1597   /* code generator produces ldrlit destreg, 0; brai 0; long 0 */
1598   /* given address is at long 0, which we change to `item` */
1599   *((U32 *)address) = item;
1600 }
1601 
arm32_get_abs(void * address)1602 static uptr arm32_get_abs(void *address) {
1603   return *((U32 *)address);
1604 }
1605 
1606 #define MAKE_B(n) (0xEA000000 | (n))
1607 #define MAKE_BL(n) (0xEB000000 | (n))
1608 #define B_OR_BL_DISP(x) ((x) & 0xFFFFFF)
1609 #define MAKE_BX(reg) (0xE12FFF10 | (reg))
1610 #define MAKE_BLX(reg) (0xE12FFF30 | (reg))
1611 #define MAKE_LDRLIT(dst,n) (0xE59F0000 | ((dst) << 12) | (n))
1612 #define LDRLITP(x) (((x) & 0xFFFF0000) == 0xE59F0000)
1613 #define LDRLIT_DST(x) (((x) >> 12) & 0xf)
1614 #define MAKE_MOV(dst,src) (0xE1A00000 | ((dst) << 12) | (src))
1615 #define MOV_SRC(x) ((x) & 0xf)
1616 /* nop instruction is not supported by all ARMv6 chips, so use recommended mov r0, r0 */
1617 #define NOP MAKE_MOV(0,0)
1618 
arm32_set_jump(void * address,uptr item,IBOOL callp)1619 static void arm32_set_jump(void *address, uptr item, IBOOL callp) {
1620   /* code generator produces ldrlit %ip, 0; brai 0; long 0; bx or blx %ip */
1621   U32 inst = *((U32 *)address + 0);
1622   INT reg = LDRLITP(inst) ? LDRLIT_DST(inst) : MOV_SRC(*((U32 *)address + 1));
1623   I32 worddisp = (U32 *)item - ((U32 *)address + 2);
1624   if (worddisp >= -0x800000 && worddisp <= 0x7FFFFF) {
1625     worddisp &= 0xFFFFFF;
1626     *((U32 *)address + 0) = (callp ? MAKE_BL(worddisp) : MAKE_B(worddisp));
1627     *((U32 *)address + 1) = MAKE_MOV(reg,reg); /* effective NOP recording tmp reg for later use */
1628     *((U32 *)address + 2) = NOP;
1629     *((U32 *)address + 3) = NOP;
1630   } else {
1631     *((U32 *)address + 0) = MAKE_LDRLIT(reg,0);
1632     *((U32 *)address + 1) = MAKE_B(0);
1633     *((U32 *)address + 2) = item;
1634     *((U32 *)address + 3) = (callp ? MAKE_BLX(reg) : MAKE_BX(reg));
1635   }
1636 }
1637 
arm32_get_jump(void * address)1638 static uptr arm32_get_jump(void *address) {
1639   U32 inst = *((U32 *)address + 0);
1640   if (LDRLITP(inst)) {
1641     return *((U32 *)address + 2);
1642   } else {
1643     I32 worddisp = B_OR_BL_DISP(inst);
1644     if (worddisp >= 0x800000) worddisp -= 0x1000000;
1645     return (uptr)(((U32 *)address + 2) + worddisp);
1646   }
1647 }
1648 #endif /* ARMV6 */
1649 
1650 #ifdef AARCH64
1651 
1652 /* Address pieces in a movz,movk,movk,movk sequence are at its 5-20 */
1653 #define ADDRESS_BITS_SHIFT 5
1654 #define ADDRESS_BITS_MASK  ((U32)0x1fffe0)
1655 
1656 /* Dest register in either movz or movk: */
1657 #define DEST_REG_MASK 0x1F
1658 
1659 #define MOVZ_OPCODE    0xD2800000
1660 #define MOVK_OPCODE    0xF2800000
1661 #define SHIFT16_OPCODE 0x00200000
1662 #define SHIFT32_OPCODE 0x00400000
1663 #define SHIFT48_OPCODE 0x00600000
1664 
arm64_set_abs(void * address,uptr item)1665 static void arm64_set_abs(void *address, uptr item) {
1666   /* First word can have an arbitrary value due to vfasl offset
1667      storage, so get the target register from the end: */
1668   int dest_reg = ((U32 *)address)[3] & DEST_REG_MASK;
1669 
1670   ((U32 *)address)[0] = (MOVZ_OPCODE | dest_reg | ((item & 0xFFFF) << ADDRESS_BITS_SHIFT));
1671   ((U32 *)address)[1] = (MOVK_OPCODE | SHIFT16_OPCODE | dest_reg | (((item >> 16) & 0xFFFF) << ADDRESS_BITS_SHIFT));
1672   ((U32 *)address)[2] = (MOVK_OPCODE | SHIFT32_OPCODE | dest_reg | (((item >> 32) & 0xFFFF) << ADDRESS_BITS_SHIFT));
1673   ((U32 *)address)[3] = (MOVK_OPCODE | SHIFT48_OPCODE | dest_reg | (((item >> 48) & 0xFFFF) << ADDRESS_BITS_SHIFT));
1674 }
1675 
arm64_get_abs(void * address)1676 static uptr arm64_get_abs(void *address) {
1677   return ((uptr)((((U32 *)address)[0] & ADDRESS_BITS_MASK) >> ADDRESS_BITS_SHIFT)
1678           | ((uptr)((((U32 *)address)[1] & ADDRESS_BITS_MASK) >> ADDRESS_BITS_SHIFT) << 16)
1679           | ((uptr)((((U32 *)address)[2] & ADDRESS_BITS_MASK) >> ADDRESS_BITS_SHIFT) << 32)
1680           | ((uptr)((((U32 *)address)[3] & ADDRESS_BITS_MASK) >> ADDRESS_BITS_SHIFT) << 48));
1681 }
1682 
1683 #endif /* AARCH64 */
1684 
1685 #ifdef PPC32
1686 
1687 #define UPDATE_ADDIS(item, instr) (((instr) & ~0xFFFF) | (((item) >> 16) & 0xFFFF))
1688 #define UPDATE_ADDI(item, instr)  (((instr) & ~0xFFFF) | ((item) & 0xFFFF))
1689 
1690 #define MAKE_B(disp, callp)   ((18 << 26) | (((disp) & 0xFFFFFF) << 2) | (callp))
1691 #define MAKE_ADDIS(item)      ((15 << 26) | (((item) >> 16) & 0xFFFF))
1692 #define MAKE_ADDI(item)       ((14 << 26) | ((item) & 0xFFFF))
1693 #define MAKE_ORI(item)        ((24 << 26) | ((item) & 0xFFFF))
1694 #define MAKE_NOP              ((24 << 26))
1695 #define MAKE_MTCTR            ((31 << 26) | (9 << 16) | (467 << 1))
1696 #define MAKE_BCTR(callp)      ((19 << 26) | (20 << 21) | (528 << 1) | (callp))
1697 
1698 #define DEST_REG_MASK         (0x1F << 21)
1699 
ppc32_set_abs(void * address,uptr item)1700 static void ppc32_set_abs(void *address, uptr item) {
1701   /* code generator produces addis destreg, %r0, 0 (hi) ; addi destreg, destreg, 0 (lo) */
1702   /* we change 0 (hi) => upper 16 bits of address */
1703   /* we change 0 (lo) => lower 16 bits of address */
1704   /* low part is signed: if negative, increment high part */
1705   /* but the first word may have been overritten for vfasl */
1706   int dest_reg = (*((U32 *)address + 1)) & DEST_REG_MASK;
1707   item = item + (item << 1 & 0x10000);
1708   *((U32 *)address + 0) = dest_reg | MAKE_ADDIS(item);
1709   *((U32 *)address + 1) = dest_reg | dest_reg >> 5 | MAKE_ADDI(item);
1710 }
1711 
ppc32_get_abs(void * address)1712 static uptr ppc32_get_abs(void *address) {
1713   uptr item = ((*((U32 *)address + 0) & 0xFFFF) << 16) | (*((U32 *)address + 1) & 0xFFFF);
1714   return item - (item << 1 & 0x10000);
1715 }
1716 
ppc32_set_jump(void * address,uptr item,IBOOL callp)1717 static void ppc32_set_jump(void *address, uptr item, IBOOL callp) {
1718   iptr disp = (iptr *)item - (iptr *)address;
1719   if (-0x800000 <= disp && disp <= 0x7FFFFF) {
1720     *((U32 *)address + 0) = MAKE_B(disp, callp);
1721     *((U32 *)address + 1) = MAKE_NOP;
1722     *((U32 *)address + 2) = MAKE_NOP;
1723     *((U32 *)address + 3) = MAKE_NOP;
1724   } else {
1725     *((U32 *)address + 0) = MAKE_ADDIS(item);
1726     *((U32 *)address + 1) = MAKE_ORI(item);
1727     *((U32 *)address + 2) = MAKE_MTCTR;
1728     *((U32 *)address + 3) = MAKE_BCTR(callp);
1729   }
1730 }
1731 
ppc32_get_jump(void * address)1732 static uptr ppc32_get_jump(void *address) {
1733   uptr item, instr = *(U32 *)address;
1734 
1735   if ((instr >> 26) == 18) {
1736     /* bl disp */
1737     iptr disp = (instr >> 2) & 0xFFFFFF;
1738     if (disp & 0x800000) disp -= 0x1000000;
1739     item = (uptr)address + (disp << 2);
1740   } else {
1741     /* lis r0, high
1742        ori r0, r0, low */
1743     item = ((instr & 0xFFFF) << 16) | (*((U32 *)address + 1) & 0xFFFF);
1744   }
1745 
1746   return item;
1747 }
1748 #endif /* PPC32 */
1749 
1750 #ifdef X86_64
1751 
x86_64_set_jump(void * address,uptr item,IBOOL callp)1752 static void x86_64_set_jump(void *address, uptr item, IBOOL callp) {
1753   I64 disp = (I64)item - ((I64)address + 5); /* 5 = size of call instruction */
1754   if ((I32)disp == disp) {
1755     *(octet *)address = callp ? 0xE8 : 0xE9;  /* call or jmp disp32 opcode */
1756     *(I32 *)((uptr)address + 1) = (I32)disp;
1757     /* 7-byte nop: */
1758     *((octet *)address + 5) = 0x0F;
1759     *((octet *)address + 6) = 0x1F;
1760     *((octet *)address + 7) = 0x80;
1761     *((octet *)address + 8) = 0x00;
1762     *((octet *)address + 9) = 0x00;
1763     *((octet *)address + 10) = 0x00;
1764     *((octet *)address + 11) = 0x00;
1765   } else {
1766     *(octet *)address = 0x48; /* REX w/REX.w set */
1767     *((octet *)address + 1)= 0xB8;  /* MOV imm64 to RAX */
1768     *(uptr *)((uptr)address + 2) = item;
1769     *((octet *)address + 10) = 0xFF;  /* call/jmp reg/mem opcode */
1770     *((octet *)address + 11) = callp ? 0xD0 : 0xE0; /* mod=11, ttt=010 (call) or 100 (jmp), r/m = 0 (RAX) */
1771   }
1772 }
1773 
x86_64_get_jump(void * address)1774 static uptr x86_64_get_jump(void *address) {
1775   if (*(octet *)address == 0x48) /* REX w/REX.w set */
1776    /* must be long form: move followed by call/jmp */
1777     return *(uptr *)((uptr)address + 2);
1778   else
1779    /* must be short form: call/jmp */
1780     return ((uptr)address + 5) + *(I32 *)((uptr)address + 1);
1781 }
1782 
1783 static int popcount_present;
1784 
x86_64_set_popcount(void * address,uptr item)1785 static void x86_64_set_popcount(void *address, uptr item) {
1786   if (!popcount_present) {
1787     x86_64_set_jump(address, item, 1);
1788   } else {
1789     *((octet *)address + 0) = 0x48; /* REX */
1790     *((octet *)address + 1) = 0x31; /* XOR RAX, RAX - avoid false dependency */
1791     *((octet *)address + 2) = 0xc0;
1792     *((octet *)address + 3) = 0xF3;
1793     *((octet *)address + 4) = 0x48; /* REX */
1794     *((octet *)address + 5) = 0x0F; /* POPCNT */
1795     *((octet *)address + 6) = 0xB8;
1796     *((octet *)address + 7) = 0xC1; /* RCX -> RAX */
1797     /* 4-byte nop: */
1798     *((octet *)address + 8) = 0x0F;
1799     *((octet *)address + 9) = 0x1F;
1800     *((octet *)address + 10) = 0x40;
1801     *((octet *)address + 11) = 0x00;
1802   }
1803 }
1804 
x86_64_set_popcount_present(ptr code)1805 void x86_64_set_popcount_present(ptr code) {
1806   /* cpu_features returns ECX after CPUID for function 1 */
1807   int (*cpu_features)() = (int (*)())((uptr)code + code_data_disp);
1808   if (cpu_features() & (1 << 23))
1809     popcount_present = 1;
1810 }
1811 
1812 #endif /* X86_64 */
1813 
1814 #ifdef SPARC64
1815 #define ASMREG0 1
1816 /* TMPREG is asm-literal-tmp in sparc64macros.ss */
1817 #define TMPREG 5
1818 /* CRETREG is retreg in sparc64macros.ss */
1819 #define CRETREG 15
1820 /* SRETREG is ret in sparc64macros.ss */
1821 #define SRETREG 26
1822 
1823 #define OP_ADDI 0x80002000
1824 #define OP_CALL 0x40000000
1825 #define OP_JSR 0x81C00000
1826 #define OP_OR 0x80100000
1827 #define OP_ORI 0x80102000
1828 #define OP_SETHI 0x1000000
1829 /* SLLXI is the 64-bit version */
1830 #define OP_SLLXI 0x81283000
1831 #define OP_XORI 0x80182000
1832 /* NOP is sethi %g0,0 */
1833 #define NOP 0x1000000
1834 #define IMMMASK (U32)0x1fff
1835 #define IMMRANGE(x) ((U32)(x) + (U32)0x1000 <= IMMMASK)
1836 #define ADDI(src,imm,dst) (OP_ADDI | (dst) << 25 | (src) << 14 | (imm) & IMMMASK)
1837 #define JSR(src) (OP_JSR | CRETREG << 25 | (src) << 14)
1838 #define ORI(src,imm,dst) (OP_ORI | (dst) << 25 | (src) << 14 | (imm) & IMMMASK)
1839 #define SETHI(dst,high) (OP_SETHI | (dst) << 25 | (high) & 0x3fffff)
1840 #define CALL(disp) (OP_CALL | (disp) >> 2 & 0x3fffffff)
1841 
1842 
extract_reg_from_sethi(address)1843 static INT extract_reg_from_sethi(address) void *address; {
1844   return *(U32 *)address >> 25;
1845 }
1846 
emit_sethi_lo(U32 item,INT destreg,void * address)1847 static void emit_sethi_lo(U32 item, INT destreg, void *address) {
1848   U32 high = item >> 10;
1849   U32 low = item & 0x3ff;
1850 
1851  /* sethi destreg, high */
1852   *(U32 *)address = SETHI(destreg,high);
1853  /* setlo destreg, low */
1854   *((U32 *)address + 1) = ORI(destreg,low,destreg);
1855 }
1856 
sparc64_get_literal(address)1857 static uptr sparc64_get_literal(address) void *address; {
1858   uptr item;
1859 
1860  /* we may have "call disp" followed by delay instruction */
1861   item = *(U32 *)address;
1862   if (item >> 30 == OP_CALL >> 30) {
1863     item = (item & 0x3fffffff) << 2;
1864     if (item & 0x80000000) /* sign bit set */
1865       item = item | 0xffffffff00000000;
1866     item = (uptr)address + (iptr)item;
1867     return item;
1868   }
1869 
1870   item = (item & 0x3fffff) << 10 | *((U32 *)address + 1) & 0x3ff;
1871   if (*((U32 *)address + 2) != NOP) {
1872     item = item << 32 |
1873            (*((U32 *)address + 3) & 0x3fffff) << 10 |
1874             *((U32 *)address + 4) & 0x3ff;
1875   }
1876   return item;
1877 }
1878 
adjust_delay_inst(delay_inst,old_call_addr,new_call_addr)1879 static U32 adjust_delay_inst(delay_inst, old_call_addr, new_call_addr)
1880       U32 delay_inst; U32 *old_call_addr, *new_call_addr; {
1881   INT offset;
1882 
1883   offset = sizeof(U32) * (old_call_addr - new_call_addr);
1884   if (offset == 0) return delay_inst;
1885 
1886   if ((delay_inst & ~IMMMASK) == ADDI(CRETREG,0,SRETREG)) {
1887     INT k = delay_inst & IMMMASK;
1888     k = k - ((k << 1) & (IMMMASK+1));
1889     offset = k + offset;
1890     if (IMMRANGE(offset)) return ADDI(CRETREG,offset,SRETREG);
1891   } else if ((delay_inst & ~IMMMASK) == ADDI(CRETREG,0,CRETREG)) {
1892     INT k = delay_inst & IMMMASK;
1893     k = k - ((k << 1) & (IMMMASK+1));
1894     offset = k + offset;
1895     if (offset == 0) return NOP;
1896     if (IMMRANGE(offset)) return ADDI(CRETREG,offset,CRETREG);
1897   } else if (IMMRANGE(offset))
1898     return ADDI(CRETREG,offset,CRETREG);
1899 
1900   return 0; /* fortunately, not a valid instruction here */
1901 }
1902 
sparc64_set_call(address,call_addr,item)1903 static void sparc64_set_call(address, call_addr, item) void *address; U32 *call_addr; uptr item; {
1904   U32 delay_inst = *(call_addr + 1), new_delay_inst; iptr disp;
1905 
1906  /* later: make item local if it refers to Scheme code, i.e., is in the
1907     Scheme heap, by copying it and every other code object we can reach
1908     into a single close area of memory.  Or generate a close stub. */
1909   disp = item - (uptr)address;
1910   if (disp >= -0x20000000 && disp <= 0x1FFFFFFF &&
1911        (new_delay_inst = adjust_delay_inst(delay_inst, call_addr,
1912                                             (U32 *)address))) {
1913     *(U32 *)address = CALL(disp);
1914     *((U32 *)address + 1) = new_delay_inst;
1915   } else {
1916     INT n = sparc64_set_lit_only(address, item, ASMREG0);
1917     new_delay_inst = adjust_delay_inst(delay_inst, call_addr, (U32 *)address + n);
1918     *((U32 *)address + n) = JSR(ASMREG0);
1919     *((U32 *)address + n + 1) = new_delay_inst;
1920   }
1921 }
1922 
sparc64_set_lit_only(address,item,destreg)1923 static INT sparc64_set_lit_only(address, item, destreg) void *address; uptr item; I32 destreg; {
1924 
1925   if ((iptr)item >= -0xffffffff && item <= 0xffffffff) {
1926     uptr x, high, low;
1927 
1928     if ((iptr)item < 0) {
1929         x = 0x100000000 - item;
1930         high = x >> 10;
1931         low = x - (high << 10);
1932        /* sethi destreg, ~high */
1933         *(U32 *)address = OP_SETHI | destreg << 25 | ~high & 0x3fffff;
1934        /* xor.i destreg, low|0x1c00, destreg */
1935         *((U32 *)address + 1) = OP_XORI | destreg << 25 | destreg << 14 |
1936                    low | 0x1c00;
1937     } else {
1938         emit_sethi_lo(item, destreg, address);
1939     }
1940     *((U32 *)address + 2) = NOP;
1941     *((U32 *)address + 3) = NOP;
1942     *((U32 *)address + 4) = NOP;
1943     *((U32 *)address + 5) = NOP;
1944     return 2;
1945   } else {
1946     emit_sethi_lo(item >> 32, destreg, address);
1947    /* sll destreg, 32, destreg */
1948     *((U32 *)address + 2) = OP_SLLXI | destreg << 25 | destreg << 14 | 32;
1949     emit_sethi_lo(item & 0xffffffff, TMPREG, (void *)((U32 *)address+3));
1950    /* or destreg, tmpreg, destreg */
1951     *((U32 *)address + 5) = OP_OR | destreg << 25 | destreg << 14 | TMPREG;
1952     return 6;
1953   }
1954 }
1955 
sparc64_set_literal(address,item)1956 static void sparc64_set_literal(address, item) void *address; uptr item; {
1957   I32 destreg;
1958 
1959  /* case 1: we have call followed by delay inst */
1960   if (*(U32 *)address >> 30 == OP_CALL >> 30) {
1961     sparc64_set_call(address, (U32 *)address, item);
1962     return;
1963   }
1964 
1965   destreg = extract_reg_from_sethi(address);
1966 
1967  /* case 2: we have two-instr load-literal followed by jsr and delay inst */
1968   if (*((U32 *)address + 2) == JSR(destreg)) {
1969     sparc64_set_call(address, (U32 *)address + 2, item);
1970     return;
1971   }
1972 
1973  /* case 3: we have six-instr load-literal followed by jsr and a delay
1974     instruction we're willing to try to deal with */
1975   if (*((U32 *)address + 6) == JSR(destreg) &&
1976         (*((U32 *)address + 7) & ~IMMMASK == ADDI(CRETREG,0,SRETREG) ||
1977          *((U32 *)address + 7) == NOP)) {
1978     sparc64_set_call(address, (U32 *)address + 6, item);
1979     return;
1980   }
1981 
1982  /* case 4: we have a plain load-literal */
1983   sparc64_set_lit_only(address, item, destreg);
1984 }
1985 #endif /* SPARC64 */
1986 
1987 #ifdef PORTABLE_BYTECODE_BIGENDIAN
1988 typedef struct {
1989   octet *code;
1990   uptr size;
1991 } rpheader_t;
1992 static rpheader_t *rpheader_stack;
1993 static int rpheader_stack_size = 0, rpheader_stack_pos = 0;
1994 
swap_code_endian(octet * code,uptr len)1995 static void swap_code_endian(octet *code, uptr len)
1996 {
1997   while (len > 0) {
1998     if ((rpheader_stack_pos > 0)
1999 	&& (code == rpheader_stack[rpheader_stack_pos-1].code)) {
2000       /* swap 8-byte segments while we're in the header */
2001       uptr header_size = rpheader_stack[--rpheader_stack_pos].size;
2002 
2003       while (header_size > 0) {
2004         octet a = code[0];
2005         octet b = code[1];
2006         octet c = code[2];
2007         octet d = code[3];
2008         octet e = code[4];
2009         octet f = code[5];
2010         octet g = code[6];
2011         octet h = code[7];
2012         code[0] = h;
2013         code[1] = g;
2014         code[2] = f;
2015         code[3] = e;
2016         code[4] = d;
2017         code[5] = c;
2018         code[6] = b;
2019         code[7] = a;
2020 
2021         code += 8;
2022         len -= 8;
2023         header_size -= 8;
2024       }
2025     } else {
2026       /* swap a 4-byte instruction */
2027       octet a = code[0];
2028       octet b = code[1];
2029       octet c = code[2];
2030       octet d = code[3];
2031       code[0] = d;
2032       code[1] = c;
2033       code[2] = b;
2034       code[3] = a;
2035 
2036       code += 4;
2037       len -= 4;
2038 
2039       if (a == pb_adr) {
2040         /* delta can be negative for a mvlet-error reinstall of the return address */
2041         iptr delta = (((iptr)d << (ptr_bits - 8)) >> (ptr_bits - 20)) + ((iptr)c << 4) + (b >> 4);
2042         if (delta > 0) {
2043           /* after a few more instructions, we'll hit
2044              a header where 64-bit values needs to be
2045              swapped, instead of 32-bit values */
2046           octet *after_rpheader = code + delta, *rpheader;
2047 	  uptr header_size;
2048 	  int pos;
2049 
2050 	  if ((uptr)delta > len)
2051 	    S_error_abort("swap endian: delta goes past end");
2052 	  if (delta & 0x3)
2053 	    S_error_abort("swap endian: delta is not a multiple of 4");
2054 
2055           if (after_rpheader[-8] & 0x1)
2056             header_size = size_rp_compact_header;
2057           else
2058             header_size = size_rp_header;
2059           rpheader = after_rpheader - header_size;
2060 
2061 	  if (rpheader_stack_pos == rpheader_stack_size) {
2062 	    int new_size = (2 * rpheader_stack_size) + 16;
2063 	    rpheader_t *new_stack;
2064 	    new_stack = malloc(new_size * sizeof(rpheader_t));
2065 	    if (rpheader_stack != NULL) {
2066 	      memcpy(new_stack, rpheader_stack, rpheader_stack_pos * sizeof(rpheader_t));
2067 	      free(rpheader_stack);
2068 	    }
2069 	    rpheader_stack_size = new_size;
2070 	    rpheader_stack = new_stack;
2071 	  }
2072 
2073 	  rpheader_stack[rpheader_stack_pos].code = rpheader;
2074 	  rpheader_stack[rpheader_stack_pos].size = header_size;
2075 	  rpheader_stack_pos++;
2076 
2077 	  /* bubble down to keep sorted */
2078 	  for (pos = rpheader_stack_pos - 2; pos > 0; --pos) {
2079 	    if (rpheader_stack[pos].code < rpheader_stack[pos+1].code) {
2080 	      rpheader_t tmp = rpheader_stack[pos];
2081 	      rpheader_stack[pos] = rpheader_stack[pos+1];
2082 	      rpheader_stack[pos+1] = tmp;
2083 	    }
2084 	  }
2085         }
2086       }
2087     }
2088   }
2089 
2090   if (rpheader_stack_pos > 0)
2091     S_error_abort("swap endian: header stack ends non-empty");
2092 }
2093 
S_swap_dounderflow_header_endian(ptr co)2094 void S_swap_dounderflow_header_endian(ptr co)
2095 {
2096   /* The `dounderflow` library entry starts with a header, so
2097      it does not have a `pb_adr` instruction before. We need
2098      to finish swapping the header's `ptr`-sized values, but
2099      the mv-return address is already linked, so the only
2100      thing to fix turns out to be the first `ptr`. */
2101   uint32_t *code = (uint32_t *)&CODEIT(co, 0);
2102   uint32_t a = code[0];
2103   uint32_t b = code[1];
2104   code[0] = b;
2105   code[1] = a;
2106 }
2107 #endif
2108