1 /*
2     Ypsilon Scheme System
3     Copyright (c) 2004-2008 Y.FUJITA / LittleWing Company Limited.
4     See license.txt for terms and conditions of use
5 */
6 
7 #include "core.h"
8 #include "vm.h"
9 #include "fasl.h"
10 #include "arith.h"
11 #include "ucs4.h"
12 
fasl_printer_t(VM * vm,scm_port_t port)13 fasl_printer_t::fasl_printer_t(VM* vm, scm_port_t port) {
14     m_vm = vm;
15     m_port = port;
16     m_lites = make_hashtable(vm->m_heap, SCM_HASHTABLE_TYPE_EQ, lookup_mutable_hashtable_size(0));
17     int depth = 1024;
18     m_stack = (scm_obj_t*)malloc(sizeof(scm_obj_t) * depth);
19     m_stack_limit = m_stack + depth;
20     m_sp = m_stack;
21     m_bad = NULL;
22 }
23 
~fasl_printer_t()24 fasl_printer_t::~fasl_printer_t() {
25     free(m_stack);
26 }
27 
28 void
scan(scm_obj_t obj)29 fasl_printer_t::scan(scm_obj_t obj)
30 {
31 loop:
32     if (obj == scm_nil) return;
33     if (SYMBOLP(obj) || STRINGP(obj)) {
34         if (get_hashtable(m_lites, obj) != scm_undef) return;
35         int nsize = put_hashtable(m_lites, obj, MAKEFIXNUM(m_lites->datum->live));
36         if (nsize) rehash_hashtable(m_vm->m_heap, m_lites, nsize);
37         return;
38     }
39     if (PAIRP(obj)) {
40         scan(CAR(obj));
41         obj = CDR(obj);
42         goto loop;
43     }
44     if (VECTORP(obj)) {
45         scm_vector_t vector = (scm_vector_t)obj;
46         int count = vector->count;
47         if (count == 0) return;
48         scm_obj_t* elts = vector->elts;
49         for (int i = 0; i < count; i++) scan(elts[i]);
50         return;
51     }
52     if (CHARP(obj) || BVECTORP(obj) || BOOLP(obj) || FIXNUMP(obj) || FLONUMP(obj) || BIGNUMP(obj) || RATIONALP(obj) || COMPLEXP(obj)) return;
53     if (m_bad == NULL) m_bad = obj;
54 }
55 
56 void
put_list(scm_obj_t obj)57 fasl_printer_t::put_list(scm_obj_t obj)
58 {
59     int count = 0;
60     while (PAIRP(obj)) {
61         push(CAR(obj));
62         obj = CDR(obj);
63         count++;
64     }
65     if (obj == scm_nil) {
66         emit_u8(FASL_TAG_PLIST);
67         emit_u32(count);
68     } else {
69         emit_u8(FASL_TAG_DLIST);
70         emit_u32(count);
71         put_datum(obj);
72     }
73     while (count--) {
74         obj = pop();
75         assert(obj);
76         put_datum(obj);
77     }
78 }
79 
80 void
put_datum(scm_obj_t obj)81 fasl_printer_t::put_datum(scm_obj_t obj)
82 {
83     if (obj == scm_nil) {
84         emit_u8(FASL_TAG_NIL);
85         return;
86     }
87     if (obj == scm_true) {
88         emit_u8(FASL_TAG_T);
89         return;
90     }
91     if (obj == scm_false) {
92         emit_u8(FASL_TAG_F);
93         return;
94     }
95     if (SYMBOLP(obj) || STRINGP(obj)) {
96         scm_obj_t id = get_hashtable(m_lites, obj);
97         emit_u8(FASL_TAG_LOOKUP);
98         emit_u32((uint32_t)FIXNUM(id));
99         return;
100     }
101     if (FIXNUMP(obj)) {
102         if (obj == MAKEFIXNUM(0)) { emit_u8(FASL_TAG_INT0); return; }
103         if (obj == MAKEFIXNUM(1)) { emit_u8(FASL_TAG_INT1); return; }
104         if (obj == MAKEFIXNUM(2)) { emit_u8(FASL_TAG_INT2); return; }
105         if (obj == MAKEFIXNUM(3)) { emit_u8(FASL_TAG_INT3); return; }
106 #if ARCH_LP64
107         assert(sizeof(intptr_t) == sizeof(uint64_t));
108         emit_u8(FASL_TAG_FIXNUM64);
109         emit_u64((uint64_t)FIXNUM(obj));
110         return;
111 #else
112         assert(sizeof(intptr_t) == sizeof(uint32_t));
113         emit_u8(FASL_TAG_FIXNUM32);
114         emit_u32((uint32_t)FIXNUM(obj));
115         return;
116 #endif
117     }
118     if (PAIRP(obj)) {
119         put_list(obj);
120         return;
121     }
122     if (VECTORP(obj)) {
123         scm_vector_t vector = (scm_vector_t)obj;
124         int count = vector->count;
125         emit_u8(FASL_TAG_VECTOR);
126         emit_u32(count);
127         scm_obj_t* elts = vector->elts;
128         for (int i = 0; i < count; i++) put_datum(elts[i]);
129         return;
130     }
131     if (BVECTORP(obj)) {
132         scm_bvector_t bv = (scm_bvector_t)obj;
133         int count = bv->count;
134         emit_u8(FASL_TAG_BVECTOR);
135         emit_u32(count);
136         for (int i = 0; i < count; i++) emit_u8(bv->elts[i]);
137         return;
138     }
139     if (FLONUMP(obj)) {
140         union {
141             double      f64;
142             uint64_t    u64;
143         } n;
144         scm_flonum_t flonum = (scm_flonum_t)obj;
145         n.f64 = flonum->value;
146         emit_u8(FASL_TAG_FLONUM);
147         emit_u64(n.u64);
148         return;
149     }
150     if (CHARP(obj)) {
151         scm_char_t ch = (scm_char_t)obj;
152         emit_u8(FASL_TAG_CHAR);
153         emit_u32(CHAR(ch));
154         return;
155     }
156     if (BIGNUMP(obj)) {
157         scm_bignum_t bn = (scm_bignum_t)obj;
158         int sign = bn_get_sign(bn); // 0 or 1 or -1
159         int count = bn_get_count(bn);
160         emit_u8(FASL_TAG_BIGNUM);
161         emit_u32(sign);
162         emit_u32(count);
163 #if USE_DIGIT32
164         for (int i = 0; i < count; i++) emit_u32(bn->elts[i]);
165 #else
166         for (int i = 0; i < count; i++) {
167             uint64_t digit = bn->elts[i];
168             emit_u32(digit & 0xffffffff);
169             emit_u32(digit >> 32);
170         }
171 #endif
172         return;
173     }
174     if (RATIONALP(obj)) {
175         scm_rational_t rat = (scm_rational_t)obj;
176         emit_u8(FASL_TAG_RATIONAL);
177         put_datum(rat->nume);
178         put_datum(rat->deno);
179         return;
180     }
181     if (COMPLEXP(obj)) {
182         scm_complex_t comp = (scm_complex_t)obj;
183         emit_u8(FASL_TAG_COMPLEX);
184         put_datum(comp->real);
185         put_datum(comp->imag);
186         return;
187     }
188     fatal("%s:%u datum not supported in fasl", __FILE__, __LINE__);
189 }
190 
191 void
put_lites()192 fasl_printer_t::put_lites()
193 {
194     scm_obj_t* lites = (scm_obj_t*)calloc(m_lites->datum->live, sizeof(scm_obj_t));
195     try {
196         hashtable_rec_t* ht_datum = m_lites->datum;
197         int nsize = m_lites->datum->capacity;
198         for (int i = 0; i < nsize; i++) {
199             scm_obj_t key = ht_datum->elts[i];
200             scm_obj_t value = ht_datum->elts[i + nsize];
201             if (CELLP(key)) {
202                 assert(FIXNUM(value) < m_lites->datum->live);
203                 lites[FIXNUM(value)] = key;
204             }
205         }
206         emit_u32(m_lites->datum->live);
207         for (int i = 0; i < m_lites->datum->live; i++) {
208             if (SYMBOLP(lites[i])) {
209                 scm_symbol_t symbol = (scm_symbol_t)lites[i];
210                 if (UNINTERNEDSYMBOLP(symbol)) {
211                     emit_u8(FASL_TAG_UNINTERNED_SYMBOL);
212                     emit_u32(i);
213                     int n = HDR_SYMBOL_SIZE(symbol->hdr) + 2;
214                     emit_u32(n);
215                     emit_bytes(symbol->name, n);
216                 } else {
217                     emit_u8(FASL_TAG_SYMBOL);
218                     emit_u32(i);
219                     int n = HDR_SYMBOL_SIZE(symbol->hdr);
220                     emit_u32(n);
221                     emit_bytes(symbol->name, n);
222                 }
223                 continue;
224             }
225             if (STRINGP(lites[i])) {
226                 scm_string_t string = (scm_string_t)lites[i];
227                 emit_u8(FASL_TAG_STRING);
228                 emit_u32(i);
229                 int n = string->size;
230                 emit_u32(n);
231                 emit_bytes(string->name, n);
232                 continue;
233             }
234         }
235     } catch (...) {
236         free(lites);
237         throw;
238     }
239     free(lites);
240 }
241 
242 scm_obj_t
put(scm_obj_t obj)243 fasl_printer_t::put(scm_obj_t obj)
244 {
245     scoped_lock lock(m_lites->lock);
246     scan(obj);
247     if (m_bad != NULL) return m_bad;
248     put_lites();
249     put_datum(obj);
250     return NULL;
251 }
252 
253 scm_obj_t
get_datum()254 fasl_reader_t::get_datum()
255 {
256     uint8_t octet = fetch_u8();
257     switch (octet) {
258     case FASL_TAG_LOOKUP: {
259         uint32_t uid = fetch_u32();
260         return m_lites[uid];
261     }
262     case FASL_TAG_FIXNUM32: {
263         int32_t value = (int32_t)fetch_u32();
264         return MAKEFIXNUM(value);
265     }
266     case FASL_TAG_FIXNUM64: {
267 #if ARCH_LP64
268         int64_t value = (int64_t)fetch_u64();
269         return MAKEFIXNUM(value);
270 #else
271         int64_t value = (int64_t)fetch_u64();
272         return int64_to_integer(m_vm->m_heap, value);
273 #endif
274     }
275     case FASL_TAG_INT0: return MAKEFIXNUM(0);
276     case FASL_TAG_INT1: return MAKEFIXNUM(1);
277     case FASL_TAG_INT2: return MAKEFIXNUM(2);
278     case FASL_TAG_INT3: return MAKEFIXNUM(3);
279     case FASL_TAG_PLIST: {
280         int count = fetch_u32();
281         scm_obj_t lst = scm_nil;
282 #if USE_CONST_LITERAL
283         for (int i = 0; i < count; i++) lst = make_immutable_pair(m_vm->m_heap, get_datum(), lst);
284 #else
285         for (int i = 0; i < count; i++) lst = make_pair(m_vm->m_heap, get_datum(), lst);
286 #endif
287         return lst;
288     }
289     case FASL_TAG_DLIST: {
290         int count = fetch_u32();
291         scm_obj_t lst = get_datum();
292 #if USE_CONST_LITERAL
293         for (int i = 0; i < count; i++) lst = make_immutable_pair(m_vm->m_heap, get_datum(), lst);
294 #else
295         for (int i = 0; i < count; i++) lst = make_pair(m_vm->m_heap, get_datum(), lst);
296 #endif
297         return lst;
298     }
299     case FASL_TAG_VECTOR: {
300         int count = fetch_u32();
301         scm_vector_t vector = make_vector(m_vm->m_heap, count, scm_unspecified);
302         scm_obj_t* elts = vector->elts;
303         for (int i = 0; i < count; i++) elts[i] = get_datum();
304         return vector;
305     }
306     case FASL_TAG_RATIONAL: {
307         scm_obj_t nume = get_datum();
308         scm_obj_t deno = get_datum();
309         return make_rational(m_vm->m_heap, nume, deno);
310     }
311     case FASL_TAG_COMPLEX: {
312         scm_obj_t real = get_datum();
313         scm_obj_t imag = get_datum();
314         return make_complex(m_vm->m_heap, real, imag);
315     }
316     case FASL_TAG_FLONUM: {
317         union {
318             double      f64;
319             uint64_t    u64;
320         } n;
321         n.u64 = fetch_u64();
322         return make_flonum(m_vm->m_heap, n.f64);
323     }
324     case FASL_TAG_BIGNUM: {
325         int sign = (int)fetch_u32();
326         int count = (int)fetch_u32();
327         scm_bignum_t bn = make_bignum(m_vm->m_heap, count);
328         bn_set_sign(bn, sign);
329 #if USE_DIGIT32
330         for (int i = 0; i < count; i++) bn->elts[i] = fetch_u32();
331         return bn;
332 #else
333         for (int i = 0; i < count; i++) {
334             uint32_t lo = fetch_u32();
335             uint32_t hi = fetch_u32();
336             bn->elts[i] = ((uint64_t)hi << 32) + lo;
337         }
338         if (count == 1) {
339             int128_t n = bn->elts[0];
340             if (sign < 0) n = -n;
341             if ((n >= FIXNUM_MIN) & (n <= FIXNUM_MAX)) return MAKEFIXNUM(n);
342         }
343         return bn;
344 #endif
345     }
346     case FASL_TAG_BVECTOR: {
347         uint32_t count = fetch_u32();
348         scm_bvector_t bv = make_bvector(m_vm->m_heap, count);
349         for (int i = 0; i < count; i++) bv->elts[i] = fetch_u8();
350         return bv;
351     }
352     case FASL_TAG_CHAR: return MAKECHAR(fetch_u32());
353     case FASL_TAG_NIL: return scm_nil;
354     case FASL_TAG_T: return scm_true;
355     case FASL_TAG_F: return scm_false;
356     case FASL_EOF: return scm_eof;
357     case FASL_TAG_SYMBOL:
358     case FASL_TAG_STRING:
359     case FASL_TAG_UNINTERNED_SYMBOL:
360         break;
361     }
362     fatal("%s:%u invalid fasl format", __FILE__, __LINE__);
363 }
364 
365 bool
get_lites()366 fasl_reader_t::get_lites()
367 {
368     int buflen = MAX_READ_STRING_LENGTH;
369     char* buf = (char*)malloc(buflen + 1);
370     int count = fetch_u32();
371     m_lites = (scm_obj_t*)calloc(count, sizeof(scm_obj_t));
372     for (int i = 0; i < count; i++) {
373         uint8_t tag = fetch_u8();
374         uint32_t uid = fetch_u32();
375         uint32_t len = fetch_u32();
376         if (len > buflen) {
377             free(buf);
378             buf = (char*)malloc(len + 1);
379             buflen = len;
380         }
381         for (int i = 0; i < len; i++) buf[i] = fetch_u8();
382         buf[len] = 0;
383         switch (tag) {
384         case FASL_TAG_SYMBOL:
385             m_lites[uid] = make_symbol(m_vm->m_heap, buf, len);
386             break;
387         case FASL_TAG_UNINTERNED_SYMBOL:
388             m_lites[uid] = make_symbol_uninterned(m_vm->m_heap, buf, len - 2, buf[len - 1]);
389             break;
390         case FASL_TAG_STRING:
391             m_lites[uid] = make_string_literal(m_vm->m_heap, buf, len);
392             break;
393         default:
394             fatal("%s:%u invalid fasl format", __FILE__, __LINE__);
395         }
396     }
397     free(buf);
398     return false;
399 }
400 
401 scm_obj_t
get()402 fasl_reader_t::get()
403 {
404     if (get_lites()) return scm_eof;
405     return get_datum();
406 }
407