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