1 /* file: "picobit-vm.c" */
4 * Copyright 2004 by Marc Feeley, All Rights Reserved.
8 * 15/08/2004 Release of version 1
9 * 06/07/2008 Modified for PICOBOARD2_R3
10 * 07/18/2008 Modified to use new object representation
16 /*---------------------------------------------------------------------------*/
21 typedef unsigned char uint8
;
22 typedef unsigned short uint16
;
23 typedef unsigned long uint32
;
25 /*---------------------------------------------------------------------------*/
45 static volatile near uint8 FW_VALUE_UP @
0x33;
46 static volatile near uint8 FW_VALUE_HI @
0x33;
47 static volatile near uint8 FW_VALUE_LO @
0x33;
49 #define ACTIVITY_LED1_LAT LATB
50 #define ACTIVITY_LED1_BIT 5
51 #define ACTIVITY_LED2_LAT LATB
52 #define ACTIVITY_LED2_BIT 4
53 static volatile near bit ACTIVITY_LED1 @
((unsigned)&ACTIVITY_LED1_LAT
*8)+ACTIVITY_LED1_BIT
;
54 static volatile near bit ACTIVITY_LED2 @
((unsigned)&ACTIVITY_LED2_LAT
*8)+ACTIVITY_LED2_BIT
;
65 #include <sys/types.h>
66 #include <sys/timeb.h>
75 /*---------------------------------------------------------------------------*/
79 #define CODE_START 0x5000
83 #define IF_GC_TRACE(x) x
86 #define IF_GC_TRACE(x)
89 /*---------------------------------------------------------------------------*/
94 #define ERROR(msg) halt_with_error()
95 #define TYPE_ERROR(prim, type) halt_with_error()
102 #define ERROR(msg) error (msg)
103 #define TYPE_ERROR(prim, type) type_error (prim, type)
105 void error (char *msg
)
107 printf ("ERROR: %s\n", msg
);
111 void type_error (char *prim
, char *type
)
113 printf ("ERROR: %s: An argument of type %s was expected\n", prim
, type
);
120 /*---------------------------------------------------------------------------*/
128 typedef uint16 ram_addr
;
129 typedef uint16 rom_addr
;
133 /*---------------------------------------------------------------------------*/
135 #define MAX_VEC_ENCODING 8191
136 #define MIN_VEC_ENCODING 4096
137 #define VEC_BYTES ((MAX_VEC_ENCODING - MIN_VEC_ENCODING + 1)*4)
138 // TODO this is new. if the pic has less than 8k of memory, start this lower
139 // TODO max was 8192 for ram, would have been 1 too much (watch out, master branch still has that), now corrected
140 // TODO the pic actually has 2k, so change these FOOBAR
141 // TODO we'd only actually need 1024 or so for ram and vectors, since we can't address more. this gives us a lot of rom space
143 #define MAX_RAM_ENCODING 4095
144 #define MIN_RAM_ENCODING 512
145 #define RAM_BYTES ((MAX_RAM_ENCODING - MIN_RAM_ENCODING + 1)*4)
146 // TODO watch out if we address more than what the PIC actually has
149 // TODO subtracts min_ram since vectors are actually in ram
150 #define OBJ_TO_VEC_ADDR(o,f) (((ram_addr)((uint16)(o) - MIN_RAM_ENCODING) << 2) + (f))
151 #define OBJ_TO_RAM_ADDR(o,f) (((ram_addr)((uint16)(o) - MIN_RAM_ENCODING) << 2) + (f))
152 #define OBJ_TO_ROM_ADDR(o,f) (((rom_addr)((uint16)(o) - MIN_ROM_ENCODING) << 2) + (CODE_START + 4 + (f)))
157 #define ram_get(a) *(uint8*)(a+0x200)
158 #define ram_set(a,x) *(uint8*)(a+0x200) = (x)
159 // TODO change these since we change proportion of ram and rom ?
165 uint8 ram_mem
[RAM_BYTES
+ VEC_BYTES
];
167 #define ram_get(a) ram_mem[a]
168 #define ram_set(a,x) ram_mem[a] = (x)
173 /*---------------------------------------------------------------------------*/
177 /* #if WORD_BITS == 8 */
178 /* #endif */ // TODO useless
180 uint8
rom_get (rom_addr a
)
182 return *(rom uint8
*)a
;
190 #define ROM_BYTES 8192
191 // TODO the new pics have 32k, change this ? minus the vm size, firmware ?
193 uint8 rom_mem
[ROM_BYTES
] =
196 #define PUTCHAR_LIGHT_not
199 0xFB, 0xD7, 0x03, 0x00, 0x00, 0x00, 0x00, 0x32
200 , 0x03, 0x00, 0x00, 0x00, 0x03, 0x00, 0x00, 0x00
201 , 0x08, 0x50, 0x80, 0x16, 0xFE, 0xE8, 0x00, 0xFC
202 , 0x32, 0x80, 0x2D, 0xFE, 0xFC, 0x31, 0x80, 0x43
203 , 0xFE, 0xFC, 0x33, 0x80, 0x2D, 0xFE, 0xFC, 0x31
204 , 0x80, 0x43, 0xFE, 0x90, 0x16, 0x01, 0x20, 0xFC
205 , 0x32, 0xE3, 0xB0, 0x37, 0x09, 0xF3, 0xFF, 0x20
206 , 0xFC, 0x33, 0xE3, 0xB0, 0x40, 0x0A, 0xF3, 0xFF
207 , 0x08, 0xF3, 0xFF, 0x01, 0x40, 0x21, 0xD1, 0x00
208 , 0x02, 0xC0, 0x4C, 0x71, 0x01, 0x20, 0x50, 0x90
209 , 0x51, 0x00, 0xF1, 0x40, 0xD8, 0xB0, 0x59, 0x90
213 0xFB, 0xD7, 0x00, 0x00, 0x80, 0x08, 0xFE, 0xE8
214 , 0x00, 0xF6, 0xF5, 0x90, 0x08
218 uint8
rom_get (rom_addr a
)
220 return rom_mem
[a
-CODE_START
];
225 /*---------------------------------------------------------------------------*/
233 fixnum n MIN_FIXNUM -> 3 ... MAX_FIXNUM -> 3 + (MAX_FIXNUM-MIN_FIXNUM)
234 rom object 4 + (MAX_FIXNUM-MIN_FIXNUM) ... MIN_RAM_ENCODING-1
235 ram object MIN_RAM_ENCODING ... MAX_RAM_ENCODING
236 vector MIN_VEC_ENCODING ... 8191
238 layout of memory allocated objects:
240 G's represent mark bits used by the gc
242 bignum n 00G00000 uuuuuuuu hhhhhhhh llllllll (24 bit signed integer)
243 TODO we could have 29-bit integers
245 pair 1GGaaaaa aaaaaaaa 000ddddd dddddddd
248 gives an address space of 2^13 * 4 = 32k divided between simple objects,
251 symbol 1GG00000 00000000 00100000 00000000
253 string 1GG***** *chars** 01000000 00000000
255 vector 1GG***** *elems** 01100000 00000000 TODO old
256 vector 1GGxxxxx xxxxxxxx 011yyyyy yyyyyyyy
257 x is length of the vector, in bytes
258 y is pointer to the elements themselves (stored in vector space)
259 TODO pointer could be shorter since it always points in vector space, same for length, will never be this long
260 TODO show how vectors are represented in vector space
261 TODO what kind of gc to have for vectors ? if we have a copying gc (which we argues against in the paper), we might need a header in vector space to point to the ram header, so it can update the pointer when the vector is copied
262 TODO have a header with length here that points to vector space, or have the header in vector space, for now, header is in ordinary ram
263 TODO how to deal with gc ? mayeb when we sweep a vector header, go sweep its contents in vector space ?
265 closure 01Gaaaaa aaaaaaaa aaaxxxxx xxxxxxxx
266 0x5ff<a<0x4000 is entry
267 x is pointer to environment
268 the reason why the environment is on the cdr (and the entry is split on 3
269 bytes) is that, when looking for a variable, a closure is considered to be a
270 pair. The compiler adds an extra offset to any variable in the closure's
271 environment, so the car of the closure (which doesn't really exist) is never
272 checked, but the cdr is followed to find the other bindings
274 continuation 1GGxxxxx xxxxxxxx 100yyyyy yyyyyyyy
275 x is parent continuation
276 y is pointer to the second half, which is a closure (contains env and entry)
278 An environment is a list of objects built out of pairs. On entry to
279 a procedure the environment is the list of parameters to which is
280 added the environment of the closure being called.
282 The first byte at the entry point of a procedure gives the arity of
285 n = 0 to 127 -> procedure has n parameters (no rest parameter)
286 n = -128 to -1 -> procedure has -n parameters, the last is
294 #define MIN_FIXNUM_ENCODING 3
296 #define MAX_FIXNUM 255
297 #define MIN_ROM_ENCODING (MIN_FIXNUM_ENCODING+MAX_FIXNUM-MIN_FIXNUM+1)
299 #define ENCODE_FIXNUM(n) ((obj)(n) + (MIN_FIXNUM_ENCODING - MIN_FIXNUM))
300 #define DECODE_FIXNUM(o) ((int32)(o) - (MIN_FIXNUM_ENCODING - MIN_FIXNUM))
302 // TODO why this ifdef ?
304 #define IN_VEC(o) ((o) >= MIN_VEC_ENCODING)
305 #define IN_RAM(o) (!IN_VEC(o) && ((o) >= MIN_RAM_ENCODING))
306 #define IN_ROM(o) (!IN_VEC(o) && !IN_RAM(o) && ((o) >= MIN_ROM_ENCODING))
308 // TODO performance ?
310 // bignum first byte : 00G00000
311 #define BIGNUM_FIELD0 0
312 #define RAM_BIGNUM(o) ((ram_get_field0 (o) & 0xc0) == BIGNUM_FIELD0)
313 #define ROM_BIGNUM(o) ((rom_get_field0 (o) & 0xc0) == BIGNUM_FIELD0)
315 // composite first byte : 1GGxxxxx
316 #define COMPOSITE_FIELD0 0x80
317 #define RAM_COMPOSITE(o) ((ram_get_field0 (o) & 0x80) == COMPOSITE_FIELD0)
318 #define ROM_COMPOSITE(o) ((rom_get_field0 (o) & 0x80) == COMPOSITE_FIELD0)
320 // pair third byte : 000xxxxx
321 #define PAIR_FIELD2 0
322 #define RAM_PAIR(o) (RAM_COMPOSITE (o) && ((ram_get_field2 (o) & 0xe0) == PAIR_FIELD2))
323 #define ROM_PAIR(o) (ROM_COMPOSITE (o) && ((rom_get_field2 (o) & 0xe0) == PAIR_FIELD2))
325 // symbol third byte : 001xxxxx
326 #define SYMBOL_FIELD2 0x20
327 #define RAM_SYMBOL(o) (RAM_COMPOSITE (o) && ((ram_get_field2 (o) & 0xe0) == SYMBOL_FIELD2))
328 #define ROM_SYMBOL(o) (ROM_COMPOSITE (o) && ((rom_get_field2 (o) & 0xe0) == SYMBOL_FIELD2))
330 // string third byte : 010xxxxx
331 #define STRING_FIELD2 0x40
332 #define RAM_STRING(o) (RAM_COMPOSITE (o) && ((ram_get_field2 (o) & 0xe0) == STRING_FIELD2))
333 #define ROM_STRING(o) (ROM_COMPOSITE (o) && ((rom_get_field2 (o) & 0xe0) == STRING_FIELD2))
335 // vector third byte : 011xxxxx
336 #define VECTOR_FIELD2 0x60
337 #define RAM_VECTOR(o) (RAM_COMPOSITE (o) && ((ram_get_field2 (o) & 0xe0) == VECTOR_FIELD2))
338 #define ROM_VECTOR(o) (ROM_COMPOSITE (o) && ((rom_get_field2 (o) & 0xe0) == VECTOR_FIELD2))
339 // TODO this is only for headers
341 // continuation third byte : 100xxxxx
342 #define CONTINUATION_FIELD2 0x80
343 #define RAM_CONTINUATION(o) (RAM_COMPOSITE (o) && ((ram_get_field2 (o) & 0xe0) == CONTINUATION_FIELD2))
344 #define ROM_CONTINUATION(o) (ROM_COMPOSITE (o) && ((rom_get_field2 (o) & 0xe0) == CONTINUATION_FIELD2))
346 // closure first byte : 01Gxxxxx
347 #define CLOSURE_FIELD0 0x40
348 #define RAM_CLOSURE(o) ((ram_get_field0 (o) & 0xc0) == CLOSURE_FIELD0)
349 #define ROM_CLOSURE(o) ((rom_get_field0 (o) & 0xc0) == CLOSURE_FIELD0)
352 /*---------------------------------------------------------------------------*/
354 #define RAM_GET_FIELD0_MACRO(o) ram_get (OBJ_TO_RAM_ADDR(o,0))
355 #define RAM_SET_FIELD0_MACRO(o,val) ram_set (OBJ_TO_RAM_ADDR(o,0), val)
356 #define ROM_GET_FIELD0_MACRO(o) rom_get (OBJ_TO_ROM_ADDR(o,0))
358 #define RAM_GET_GC_TAGS_MACRO(o) (RAM_GET_FIELD0_MACRO(o) & 0x60)
359 #define RAM_GET_GC_TAG0_MACRO(o) (RAM_GET_FIELD0_MACRO(o) & 0x20)
360 #define RAM_GET_GC_TAG1_MACRO(o) (RAM_GET_FIELD0_MACRO(o) & 0x40)
361 #define RAM_SET_GC_TAGS_MACRO(o,tags) \
362 (RAM_SET_FIELD0_MACRO(o,(RAM_GET_FIELD0_MACRO(o) & 0x9f) | (tags)))
363 #define RAM_SET_GC_TAG0_MACRO(o,tag) \
364 RAM_SET_FIELD0_MACRO(o,(RAM_GET_FIELD0_MACRO(o) & 0xdf) | (tag))
365 #define RAM_SET_GC_TAG1_MACRO(o,tag) \
366 RAM_SET_FIELD0_MACRO(o,(RAM_GET_FIELD0_MACRO(o) & 0xbf) | (tag))
369 #define RAM_GET_FIELD1_MACRO(o) ram_get (OBJ_TO_RAM_ADDR(o,1))
370 #define RAM_GET_FIELD2_MACRO(o) ram_get (OBJ_TO_RAM_ADDR(o,2))
371 #define RAM_GET_FIELD3_MACRO(o) ram_get (OBJ_TO_RAM_ADDR(o,3))
372 #define RAM_SET_FIELD1_MACRO(o,val) ram_set (OBJ_TO_RAM_ADDR(o,1), val)
373 #define RAM_SET_FIELD2_MACRO(o,val) ram_set (OBJ_TO_RAM_ADDR(o,2), val)
374 #define RAM_SET_FIELD3_MACRO(o,val) ram_set (OBJ_TO_RAM_ADDR(o,3), val)
375 #define ROM_GET_FIELD1_MACRO(o) rom_get (OBJ_TO_ROM_ADDR(o,1))
376 #define ROM_GET_FIELD2_MACRO(o) rom_get (OBJ_TO_ROM_ADDR(o,2))
377 #define ROM_GET_FIELD3_MACRO(o) rom_get (OBJ_TO_ROM_ADDR(o,3))
378 #define VEC_GET_BYTE0_MACRO(o) ram_get (OBJ_TO_RAM_ADDR(o,0))
379 #define VEC_GET_BYTE1_MACRO(o) ram_get (OBJ_TO_RAM_ADDR(o,1))
380 #define VEC_GET_BYTE2_MACRO(o) ram_get (OBJ_TO_RAM_ADDR(o,2))
381 #define VEC_GET_BYTE3_MACRO(o) ram_get (OBJ_TO_RAM_ADDR(o,3))
382 #define VEC_SET_BYTE0_MACRO(o,val) ram_set (OBJ_TO_RAM_ADDR(o,0), val)
383 #define VEC_SET_BYTE1_MACRO(o,val) ram_set (OBJ_TO_RAM_ADDR(o,1), val)
384 #define VEC_SET_BYTE2_MACRO(o,val) ram_set (OBJ_TO_RAM_ADDR(o,2), val)
385 #define VEC_SET_BYTE3_MACRO(o,val) ram_set (OBJ_TO_RAM_ADDR(o,3), val)
386 // TODO put these in the ifdef ? and is the ifdef necessary ? are the vec macros necessary ? use the word field instead of byte, for consistency ?
389 uint8
ram_get_gc_tags (obj o
) { return RAM_GET_GC_TAGS_MACRO(o
); }
390 uint8
ram_get_gc_tag0 (obj o
) { return RAM_GET_GC_TAG0_MACRO(o
); }
391 uint8
ram_get_gc_tag1 (obj o
) { return RAM_GET_GC_TAG1_MACRO(o
); }
392 void ram_set_gc_tags (obj o
, uint8 tags
) { RAM_SET_GC_TAGS_MACRO(o
, tags
); }
393 void ram_set_gc_tag0 (obj o
, uint8 tag
) { RAM_SET_GC_TAG0_MACRO(o
,tag
); }
394 void ram_set_gc_tag1 (obj o
, uint8 tag
) { RAM_SET_GC_TAG1_MACRO(o
,tag
); }
395 uint8
ram_get_field0 (obj o
) { return RAM_GET_FIELD0_MACRO(o
); }
396 word
ram_get_field1 (obj o
) { return RAM_GET_FIELD1_MACRO(o
); }
397 word
ram_get_field2 (obj o
) { return RAM_GET_FIELD2_MACRO(o
); }
398 word
ram_get_field3 (obj o
) { return RAM_GET_FIELD3_MACRO(o
); }
399 void ram_set_field0 (obj o
, uint8 val
) { RAM_SET_FIELD0_MACRO(o
,val
); }
400 void ram_set_field1 (obj o
, word val
) { RAM_SET_FIELD1_MACRO(o
,val
); }
401 void ram_set_field2 (obj o
, word val
) { RAM_SET_FIELD2_MACRO(o
,val
); }
402 void ram_set_field3 (obj o
, word val
) { RAM_SET_FIELD3_MACRO(o
,val
); }
403 uint8
rom_get_field0 (obj o
) { return ROM_GET_FIELD0_MACRO(o
); }
404 word
rom_get_field1 (obj o
) { return ROM_GET_FIELD1_MACRO(o
); }
405 word
rom_get_field2 (obj o
) { return ROM_GET_FIELD2_MACRO(o
); }
406 word
rom_get_field3 (obj o
) { return ROM_GET_FIELD3_MACRO(o
); }
407 /* word vec_get_byte0 (obj o) { return VEC_GET_BYTE0_MACRO(o); } */
408 /* word vec_get_byte1 (obj o) { return VEC_GET_BYTE1_MACRO(o); } */
409 /* word vec_get_byte2 (obj o) { return VEC_GET_BYTE2_MACRO(o); } */
410 /* word vec_get_byte3 (obj o) { return VEC_GET_BYTE3_MACRO(o); } */
411 /* word vec_set_byte0 (obj o, word val) { VEC_SET_BYTE0_MACRO(o,val); } */
412 /* word vec_set_byte1 (obj o, word val) { VEC_SET_BYTE1_MACRO(o,val); } */
413 /* word vec_set_byte2 (obj o, word val) { VEC_SET_BYTE2_MACRO(o,val); } */
414 /* word vec_set_byte3 (obj o, word val) { VEC_SET_BYTE3_MACRO(o,val); } */
415 // TODO use the word field or byte ? actually the ram functions are used, since this is in ram anyways
417 obj
ram_get_car (obj o
)
418 { return ((ram_get_field0 (o
) & 0x1f) << 8) | ram_get_field1 (o
); }
419 obj
rom_get_car (obj o
)
420 { return ((rom_get_field0 (o
) & 0x1f) << 8) | rom_get_field1 (o
); }
421 obj
ram_get_cdr (obj o
)
422 { return ((ram_get_field2 (o
) & 0x1f) << 8) | ram_get_field3 (o
); }
423 obj
rom_get_cdr (obj o
)
424 { return ((rom_get_field2 (o
) & 0x1f) << 8) | rom_get_field3 (o
); }
425 void ram_set_car (obj o
, obj val
)
427 ram_set_field0 (o
, (val
>> 8) | (ram_get_field0 (o
) & 0xe0));
428 ram_set_field1 (o
, val
& 0xff);
430 void ram_set_cdr (obj o
, obj val
)
432 ram_set_field2 (o
, (val
>> 8) | (ram_get_field2 (o
) & 0xe0));
433 ram_set_field3 (o
, val
& 0xff);
435 obj
ram_get_entry (obj o
)
437 return (((ram_get_field0 (o
) & 0x1f) << 11)
438 | (ram_get_field1 (o
) << 3)
439 | (ram_get_field2 (o
) >> 5));
441 obj
rom_get_entry (obj o
)
443 return (((rom_get_field0 (o
) & 0x1f) << 11)
444 | (rom_get_field1 (o
) << 3)
445 | (rom_get_field2 (o
) >> 5));
448 obj
get_global (uint8 i
)
449 // globals occupy the beginning of ram, with 2 globals per word
452 return ram_get_cdr (MIN_RAM_ENCODING
+ (i
/ 2));
454 return ram_get_car (MIN_RAM_ENCODING
+ (i
/ 2));
457 void set_global (uint8 i
, obj o
)
460 ram_set_cdr (MIN_RAM_ENCODING
+ (i
/ 2), o
);
462 ram_set_car (MIN_RAM_ENCODING
+ (i
/ 2), o
);
466 void show_type (obj o
) // for debugging purposes
469 if (o
== OBJ_FALSE
) printf("#f");
470 else if (o
== OBJ_TRUE
) printf("#t");
471 else if (o
== OBJ_NULL
) printf("()");
472 else if (o
< MIN_ROM_ENCODING
) printf("fixnum");
475 if (RAM_BIGNUM(o
)) printf("ram bignum");
476 else if (RAM_PAIR(o
)) printf("ram pair");
477 else if (RAM_SYMBOL(o
)) printf("ram symbol");
478 else if (RAM_STRING(o
)) printf("ram string");
479 else if (RAM_VECTOR(o
)) printf("ram vector");
480 else if (RAM_CONTINUATION(o
)) printf("ram continuation");
481 else if (RAM_CLOSURE(o
)) printf("ram closure");
485 if (ROM_BIGNUM(o
)) printf("rom bignum");
486 else if (ROM_PAIR(o
)) printf("rom pair");
487 else if (ROM_SYMBOL(o
)) printf("rom symbol");
488 else if (ROM_STRING(o
)) printf("rom string");
489 else if (ROM_VECTOR(o
)) printf("rom vector");
490 else if (ROM_CONTINUATION(o
)) printf("rom continuation");
491 else if (RAM_CLOSURE(o
)) printf("rom closure");
498 /*---------------------------------------------------------------------------*/
500 /* Interface to GC */
502 // TODO explain what each tag means, with 1-2 mark bits
503 #define GC_TAG_0_LEFT (1<<5)
504 // TODO was 3<<5, changed to play nice with procedures and bignums, but should actually set only this bit, not clear the other
505 #define GC_TAG_1_LEFT (2<<5)
506 #define GC_TAG_UNMARKED (0<<5)
508 /* Number of object fields of objects in ram */
509 #define HAS_2_OBJECT_FIELDS(visit) (RAM_PAIR(visit) || RAM_CONTINUATION(visit))
510 #define HAS_1_OBJECT_FIELD(visit) (RAM_COMPOSITE(visit) || RAM_CLOSURE(visit))
511 // all composites except pairs and continuations have 1 object field
512 // TODO if we ever have true bignums, bignums will have 1 object field
514 #define NIL OBJ_FALSE
516 /*---------------------------------------------------------------------------*/
518 /* Garbage collector */
520 obj free_list
; /* list of unused cells */
521 obj free_list_vec
; /* list of unused cells in vector space */
523 obj arg1
; /* root set */
530 uint8 na
; /* interpreter variables */
541 void init_ram_heap (void)
544 obj o
= MAX_RAM_ENCODING
;
548 while (o
> (MIN_RAM_ENCODING
+ (glovars
+ 1) / 2))
549 // we don't want to add globals to the free list, and globals occupy the
550 // beginning of memory at the rate of 2 globals per word (car and cdr)
552 ram_set_gc_tags (o
, GC_TAG_UNMARKED
);
553 ram_set_car (o
, free_list
);
558 free_list_vec
= MIN_VEC_ENCODING
;
559 ram_set_car (free_list_vec
, 0); // TODO is ram_set_car appropriate ? now we have vector space objects that can either be a list or 4 bytes
560 // each node of the free list must know the free length that follows it
561 // this free length is stored in words, not in bytes
562 // if we did count in bytes, the number might need more than 13 bits
563 ram_set_cdr (free_list_vec
, VEC_BYTES
/ 4);
564 // TODO so, at the start, we have only 1 node that says the whole space is free
566 for (i
=0; i
<glovars
; i
++)
567 set_global (i
, OBJ_FALSE
);
594 // IF_GC_TRACE(printf ("push stack=%d (tag=%d) visit=%d (tag=%d)\n", stack, ram_get_gc_tags (stack)>>5, visit, ram_get_gc_tags (visit)>>5)); // TODO error here, tried to get the tag of nil
595 IF_GC_TRACE(printf ("push stack=%d visit=%d (tag=%d)\n", stack
, visit
, ram_get_gc_tags (visit
)>>5));
597 if ((HAS_1_OBJECT_FIELD (visit
) && ram_get_gc_tag0 (visit
))
598 || (HAS_2_OBJECT_FIELDS (visit
)
599 && (ram_get_gc_tags (visit
) != GC_TAG_UNMARKED
)))
600 // TODO ugly condition
601 IF_GC_TRACE(printf ("case 1\n"));
604 if (HAS_2_OBJECT_FIELDS(visit
)) // pairs and continuations
606 IF_GC_TRACE(printf ("case 5\n"));
610 temp
= ram_get_cdr (visit
);
614 IF_GC_TRACE(printf ("case 6\n"));
615 ram_set_gc_tags (visit
, GC_TAG_1_LEFT
);
616 ram_set_cdr (visit
, stack
);
620 IF_GC_TRACE(printf ("case 7\n"));
625 if (HAS_1_OBJECT_FIELD(visit
))
627 IF_GC_TRACE(printf ("case 8\n"));
631 if (RAM_CLOSURE(visit
)) // closures have the pointer in the cdr
632 temp
= ram_get_cdr (visit
);
634 temp
= ram_get_car (visit
);
638 IF_GC_TRACE(printf ("case 9\n"));
639 ram_set_gc_tag0 (visit
, GC_TAG_0_LEFT
);
640 if (RAM_CLOSURE(visit
))
641 ram_set_cdr (visit
, stack
);
643 ram_set_car (visit
, stack
);
648 IF_GC_TRACE(printf ("case 10\n"));
651 IF_GC_TRACE(printf ("case 11\n"));
653 ram_set_gc_tag0 (visit
, GC_TAG_0_LEFT
);
658 /* IF_GC_TRACE(printf ("pop stack=%d (tag=%d) visit=%d (tag=%d)\n", stack, ram_get_gc_tags (stack)>>6, visit, ram_get_gc_tags (visit)>>6)); */
659 // TODO, like for push, getting the gc tags of nil is not great
660 IF_GC_TRACE(printf ("pop stack=%d visit=%d (tag=%d)\n", stack
, visit
, ram_get_gc_tags (visit
)>>6));
664 if (HAS_2_OBJECT_FIELDS(stack
) && ram_get_gc_tag1 (stack
))
666 IF_GC_TRACE(printf ("case 13\n"));
668 temp
= ram_get_cdr (stack
); /* pop through cdr */
669 ram_set_cdr (stack
, visit
);
673 ram_set_gc_tag1(visit
, GC_TAG_UNMARKED
);
674 // we unset the "1-left" bit
679 if (RAM_CLOSURE(stack
))
680 // closures have one object field, but it's in the cdr
682 IF_GC_TRACE(printf ("case 13.5\n")); // TODO renumber cases
684 temp
= ram_get_cdr (stack
); /* pop through cdr */
685 ram_set_cdr (stack
, visit
);
692 IF_GC_TRACE(printf ("case 14\n"));
694 temp
= ram_get_car (stack
); /* pop through car */
695 ram_set_car (stack
, visit
);
716 obj visit
= MAX_RAM_ENCODING
;
720 while (visit
>= (MIN_RAM_ENCODING
+ ((glovars
+ 1) / 2)))
721 // we don't want to sweep the global variables area
723 if ((RAM_COMPOSITE(visit
)
724 && (ram_get_gc_tags (visit
) == GC_TAG_UNMARKED
)) // 2 mark bit
725 || !(ram_get_gc_tags (visit
) & GC_TAG_0_LEFT
)) // 1 mark bit
728 if (RAM_VECTOR(visit
))
729 // when we sweep a vector, we also have to sweep its contents
731 obj o
= ram_get_cdr (visit
);
732 uint16 i
= ram_get_car (visit
); // number of elements
733 ram_set_car (o
, free_list_vec
);
734 ram_set_cdr (o
, (i
+ 3) / 4); // free length, in words
736 // TODO fuse free spaces if needed ? would be a good idea FOOBAR or maybe just fuse when we call the gc ? actually, compacting might be a better idea, but would need a second header in vector space that would point to the header in ram
738 ram_set_car (visit
, free_list
);
743 if (RAM_COMPOSITE(visit
))
744 ram_set_gc_tags (visit
, GC_TAG_UNMARKED
);
745 else // only 1 mark bit to unset
746 ram_set_gc_tag0 (visit
, GC_TAG_UNMARKED
);
758 printf ("**************** memory needed = %d\n", max_live
+1);
768 IF_TRACE(printf("\nGC BEGINS\n"));
770 IF_GC_TRACE(printf("arg1\n"));
772 IF_GC_TRACE(printf("arg2\n"));
774 IF_GC_TRACE(printf("arg3\n"));
776 IF_GC_TRACE(printf("arg4\n"));
778 IF_GC_TRACE(printf("cont\n"));
780 IF_GC_TRACE(printf("env\n"));
781 mark (env
); // TODO do we mark the free list or do we rebuild it every time ? what about vectors ?
783 for (i
=0; i
<glovars
; i
++)
784 mark (get_global (i
));
789 obj
alloc_ram_cell (void)
803 ERROR("memory is full");
808 free_list
= ram_get_car (o
);
813 obj
alloc_ram_cell_init (uint8 f0
, uint8 f1
, uint8 f2
, uint8 f3
)
815 obj o
= alloc_ram_cell ();
817 ram_set_field0 (o
, f0
);
818 ram_set_field1 (o
, f1
);
819 ram_set_field2 (o
, f2
);
820 ram_set_field3 (o
, f3
);
825 obj
alloc_vec_cell (uint16 n
) // TODO add a init version ?
827 obj o
= free_list_vec
;
836 while ((ram_get_cdr (o
) * 4) < n
) // free space too small
837 { // TODO BREGG IMPORTANT : si on atteint le fond de la free list, 0, le get_cdr foire, et on meurt avant de pouvoir faire du gc
838 if (o
== 0) // no free space, or none big enough
840 if (gc_done
) // we gc'd, but no space is big enough for the vector
841 ERROR("no room for vector");
849 } // TODO fuse adjacent free spaces, and maybe compact ? FOOBAR
854 // case 1 : the new vector fills every free word advertized, we remove the
855 // node from the free list
856 // TODO mettre le cdr de o dans une var temporaire ?
857 if (((ram_get_cdr(o
) * 4) - n
) < 4) // TODO is there a better way ?
859 if (prec
) // TODO does this mean that the free list nodes are in the same order as they are in memory ?
860 ram_set_car (prec
, ram_get_car (o
));
862 free_list_vec
= ram_get_car (o
);
864 // case 2 : there is still some space left in the free section, create a new
865 // node to represent this space
868 obj new_free
= o
+ (n
+ 3)/4;
870 ram_set_car (prec
, new_free
);
872 free_list_vec
= new_free
;
873 ram_set_car (new_free
, ram_get_car (o
));
874 ram_set_cdr (new_free
, ram_get_cdr (o
) - (n
+ 3)/4); // TODO documenter structure de cette free list quelque part
880 /*---------------------------------------------------------------------------*/
882 int32
decode_int (obj o
)
888 if (o
< MIN_FIXNUM_ENCODING
)
889 TYPE_ERROR("decode_int", "integer");
891 if (o
<= (MIN_FIXNUM_ENCODING
+ (MAX_FIXNUM
- MIN_FIXNUM
)))
892 return DECODE_FIXNUM(o
);
897 TYPE_ERROR("decode_int", "integer");
899 u
= ram_get_field1 (o
);
900 h
= ram_get_field2 (o
);
901 l
= ram_get_field3 (o
);
906 TYPE_ERROR("decode_int", "integer");
908 u
= rom_get_field1 (o
);
909 h
= rom_get_field2 (o
);
910 l
= rom_get_field3 (o
);
913 TYPE_ERROR("decode_int", "integer");
916 return ((int32
)((((int16
)u
- 256) << 8) + h
) << 8) + l
;
918 return ((int32
)(((int16
)u
<< 8) + h
) << 8) + l
;
921 obj
encode_int (int32 n
)
923 if (n
>= MIN_FIXNUM
&& n
<= MAX_FIXNUM
)
924 return ENCODE_FIXNUM(n
);
926 return alloc_ram_cell_init (BIGNUM_FIELD0
, n
>> 16, n
>> 8, n
);
929 /*---------------------------------------------------------------------------*/
941 else if (o
== OBJ_TRUE
)
943 else if (o
== OBJ_NULL
)
945 else if (o
<= (MIN_FIXNUM_ENCODING
+ (MAX_FIXNUM
- MIN_FIXNUM
)))
946 printf ("%d", DECODE_FIXNUM(o
));
947 else // TODO past here, everything is either in ram or in rom, until we add a 3rd space for vectors, that is
956 if ((in_ram
&& RAM_BIGNUM(o
)) || (!in_ram
&& ROM_BIGNUM(o
)))
957 printf ("%d", decode_int (o
));
958 else if ((in_ram
&& RAM_COMPOSITE(o
)) || (!in_ram
&& ROM_COMPOSITE(o
)))
963 if ((in_ram
&& RAM_PAIR(o
)) || (!in_ram
&& ROM_PAIR(o
))) // TODO not exactly efficient, fix it
967 car
= ram_get_car (o
);
968 cdr
= ram_get_cdr (o
);
972 car
= rom_get_car (o
);
973 cdr
= rom_get_cdr (o
);
984 else if ((IN_RAM(cdr
) && RAM_PAIR(cdr
))
985 || (IN_ROM(cdr
) && ROM_PAIR(cdr
)))
989 car
= ram_get_car (cdr
);
990 cdr
= ram_get_cdr (cdr
);
994 car
= rom_get_car (cdr
);
995 cdr
= rom_get_cdr (cdr
);
1008 else if ((in_ram
&& RAM_SYMBOL(o
)) || (!in_ram
&& ROM_SYMBOL(o
)))
1009 printf ("#<symbol>");
1010 else if ((in_ram
&& RAM_STRING(o
)) || (!in_ram
&& ROM_STRING(o
)))
1011 printf ("#<string>");
1012 else if ((in_ram
&& RAM_VECTOR(o
)) || (!in_ram
&& ROM_VECTOR(o
)))
1013 printf ("#<vector %d>", o
); // TODO do better DEBUG BREGG
1017 car
= ram_get_car (o
);
1018 cdr
= ram_get_cdr (o
);
1019 goto loop
; // TODO ugly hack, takes advantage of the fact that pairs and continuations have the same layout
1027 if (IN_RAM(o
)) // TODO can closures be in rom ? I don't think so
1028 env
= ram_get_cdr (o
);
1030 env
= rom_get_cdr (o
);
1033 pc
= ram_get_entry (o
);
1035 pc
= rom_get_entry (o
);
1037 printf ("{0x%04x ", pc
);
1046 void show_state (rom_addr pc
)
1049 printf ("pc=0x%04x bytecode=0x%02x env=", pc
, rom_get (pc
));
1066 /*---------------------------------------------------------------------------*/
1068 /* Integer operations */
1070 #define encode_bool(x) ((obj)(x))
1072 void prim_numberp (void)
1074 if (arg1
>= MIN_FIXNUM_ENCODING
1075 && arg1
<= (MIN_FIXNUM_ENCODING
+ (MAX_FIXNUM
- MIN_FIXNUM
)))
1080 arg1
= encode_bool (RAM_BIGNUM(arg1
));
1081 else if (IN_ROM(arg1
))
1082 arg1
= encode_bool (ROM_BIGNUM(arg1
));
1088 void decode_2_int_args (void)
1090 a1
= decode_int (arg1
);
1091 a2
= decode_int (arg2
);
1094 void prim_add (void)
1096 decode_2_int_args ();
1097 arg1
= encode_int (a1
+ a2
);
1101 void prim_sub (void)
1103 decode_2_int_args ();
1104 arg1
= encode_int (a1
- a2
);
1108 void prim_mul (void)
1110 decode_2_int_args ();
1111 arg1
= encode_int (a1
* a2
);
1115 void prim_div (void)
1117 decode_2_int_args ();
1119 ERROR("divide by 0");
1120 arg1
= encode_int (a1
/ a2
);
1124 void prim_rem (void)
1126 decode_2_int_args ();
1128 ERROR("divide by 0");
1129 arg1
= encode_int (a1
% a2
);
1133 void prim_neg (void)
1135 a1
= decode_int (arg1
);
1136 arg1
= encode_int (- a1
);
1141 decode_2_int_args ();
1142 arg1
= encode_bool (a1
== a2
);
1148 decode_2_int_args ();
1149 arg1
= encode_bool (a1
< a2
);
1155 decode_2_int_args ();
1156 arg1
= encode_bool (a1
> a2
);
1160 void prim_ior (void)
1162 a1
= decode_int (arg1
); // TODO use decode_2_int_args ? can't see why not
1163 a2
= decode_int (arg2
);
1164 arg1
= encode_int (a1
| a2
);
1168 void prim_xor (void)
1170 a1
= decode_int (arg1
);
1171 a2
= decode_int (arg2
);
1172 arg1
= encode_int (a1
^ a2
);
1177 /*---------------------------------------------------------------------------*/
1179 /* List operations */
1181 void prim_pairp (void)
1184 arg1
= encode_bool (RAM_PAIR(arg1
));
1185 else if (IN_ROM(arg1
))
1186 arg1
= encode_bool (ROM_PAIR(arg1
));
1191 obj
cons (obj car
, obj cdr
)
1193 return alloc_ram_cell_init (COMPOSITE_FIELD0
| (car
>> 8), // TODO was ((car & 0x1f00) >> 8), probably redundant
1195 PAIR_FIELD2
| (cdr
>> 8), // TODO was ((cdr & 0x1f00) >> 8), probably redundant
1199 void prim_cons (void)
1201 arg1
= cons (arg1
, arg2
);
1205 void prim_car (void)
1209 if (!RAM_PAIR(arg1
))
1210 TYPE_ERROR("car", "pair");
1211 arg1
= ram_get_car (arg1
);
1213 else if (IN_ROM(arg1
))
1215 if (!ROM_PAIR(arg1
))
1216 TYPE_ERROR("car", "pair");
1217 arg1
= rom_get_car (arg1
);
1221 TYPE_ERROR("car", "pair");
1225 void prim_cdr (void)
1229 if (!RAM_PAIR(arg1
))
1230 TYPE_ERROR("cdr", "pair");
1231 arg1
= ram_get_cdr (arg1
);
1233 else if (IN_ROM(arg1
))
1235 if (!ROM_PAIR(arg1
))
1236 TYPE_ERROR("cdr", "pair");
1237 arg1
= rom_get_cdr (arg1
);
1241 TYPE_ERROR("cdr", "pair");
1245 void prim_set_car (void)
1249 if (!RAM_PAIR(arg1
))
1250 TYPE_ERROR("set-car!", "pair");
1252 ram_set_car (arg1
, arg2
);
1258 TYPE_ERROR("set-car!", "pair");
1262 void prim_set_cdr (void)
1266 if (!RAM_PAIR(arg1
))
1267 TYPE_ERROR("set-cdr!", "pair");
1269 ram_set_cdr (arg1
, arg2
);
1275 TYPE_ERROR("set-cdr!", "pair");
1279 void prim_nullp (void)
1281 arg1
= encode_bool (arg1
== OBJ_NULL
);
1284 /*---------------------------------------------------------------------------*/
1286 /* Vector operations */
1288 void prim_u8vectorp (void)
1291 arg1
= encode_bool (RAM_VECTOR(arg1
));
1292 else if (IN_ROM(arg1
))
1293 arg1
= encode_bool (ROM_VECTOR(arg1
));
1298 void prim_make_u8vector (void)
1300 decode_2_int_args (); // arg1 is length, arg2 is contents
1303 ERROR("byte vectors can only contain bytes");
1305 arg3
= alloc_vec_cell (a1
);
1306 arg1
= alloc_ram_cell_init (COMPOSITE_FIELD0
| (a1
>> 8),
1308 VECTOR_FIELD2
| (arg3
>> 8),
1311 a1
= (a1
+ 3) / 4; // actual length, in words
1314 ram_set_field0 (arg3
, a2
);
1315 ram_set_field1 (arg3
, a2
);
1316 ram_set_field2 (arg3
, a2
);
1317 ram_set_field3 (arg3
, a2
);
1322 void prim_u8vector_ref (void)
1323 { // TODO how do we deal with rom vectors ? as lists ? they're never all that long
1324 a2
= decode_int (arg2
);
1328 if (!RAM_VECTOR(arg1
))
1329 TYPE_ERROR("u8vector-ref", "vector");
1330 if (ram_get_car (arg1
) < a2
)
1331 ERROR("vector index too large");
1332 arg1
= ram_get_cdr (arg1
);
1334 else if (IN_ROM(arg1
))
1336 if (!ROM_VECTOR(arg1
))
1337 TYPE_ERROR("u8vector-ref", "vector");
1338 arg3
= rom_get_car (arg1
); // we'll need the length later
1340 ERROR("vector index too large");
1341 arg1
= rom_get_cdr (arg1
);
1344 TYPE_ERROR("u8vector-ref", "vector");
1354 arg1
= ram_get_field0 (arg1
); break;
1356 arg1
= ram_get_field1 (arg1
); break;
1358 arg1
= ram_get_field2 (arg1
); break;
1360 arg1
= ram_get_field3 (arg1
); break;
1363 arg1
= encode_int (arg1
);
1365 else // rom vector, stored as a list
1366 { // TODO since these are stored as lists, nothing prevents us from having ordinary vectors, and not just byte vectors. in rom, both are lists so they are the same. in ram, byte vectors are in vector space, while ordinary vectors are still lists (the functions are already in the library)
1367 arg4
= a2
; // we save the index
1370 arg1
= rom_get_cdr (arg1
);
1372 // since rom vectors are dotted pairs, the last element is in cdr
1373 if (arg4
< (arg3
- 1))
1374 arg1
= rom_get_car (arg1
);
1382 void prim_u8vector_set (void)
1383 { // TODO a lot in common with ref, abstract that
1384 a2
= decode_int (arg2
);
1385 a3
= decode_int (arg3
);
1388 ERROR("byte vectors can only contain bytes");
1392 if (!RAM_VECTOR(arg1
))
1393 TYPE_ERROR("u8vector-set!", "vector");
1394 if (ram_get_car (arg1
) < a2
)
1395 ERROR("vector index too large");
1396 arg1
= ram_get_cdr (arg1
);
1399 TYPE_ERROR("u8vector-set!", "vector");
1407 ram_set_field0 (arg1
, a3
); break;
1409 ram_set_field1 (arg1
, a3
); break;
1411 ram_set_field2 (arg1
, a3
); break;
1413 ram_set_field3 (arg1
, a3
); break;
1421 void prim_u8vector_length (void)
1425 if (!RAM_VECTOR(arg1
))
1426 TYPE_ERROR("u8vector-length", "vector");
1427 arg1
= encode_int (ram_get_car (arg1
));
1429 else if (IN_ROM(arg1
))
1431 if (!ROM_VECTOR(arg1
))
1432 TYPE_ERROR("u8vector-length", "vector");
1433 arg1
= encode_int (rom_get_car (arg1
));
1436 TYPE_ERROR("u8vector-length", "vector");
1439 /*---------------------------------------------------------------------------*/
1441 /* Miscellaneous operations */
1443 void prim_eqp (void)
1445 arg1
= encode_bool (arg1
== arg2
);
1449 void prim_not (void)
1451 arg1
= encode_bool (arg1
== OBJ_FALSE
);
1454 void prim_symbolp (void)
1457 arg1
= encode_bool (RAM_SYMBOL(arg1
));
1458 else if (IN_ROM(arg1
))
1459 arg1
= encode_bool (ROM_SYMBOL(arg1
));
1464 void prim_stringp (void)
1467 arg1
= encode_bool (RAM_STRING(arg1
));
1468 else if (IN_ROM(arg1
))
1469 arg1
= encode_bool (ROM_STRING(arg1
));
1474 void prim_string2list (void)
1478 if (!RAM_STRING(arg1
))
1479 TYPE_ERROR("string->list", "string");
1481 arg1
= ram_get_car (arg1
);
1483 else if (IN_ROM(arg1
))
1485 if (!ROM_STRING(arg1
))
1486 TYPE_ERROR("string->list", "string");
1488 arg1
= rom_get_car (arg1
);
1491 TYPE_ERROR("string->list", "string");
1494 void prim_list2string (void)
1496 arg1
= alloc_ram_cell_init (COMPOSITE_FIELD0
| ((arg1
& 0x1f00) >> 8),
1503 /*---------------------------------------------------------------------------*/
1505 /* Robot specific operations */
1508 void prim_print (void)
1523 int32
read_clock (void)
1529 now
= from_now( 0 );
1537 static int32 start
= 0;
1542 now
= tb
.time
* 1000 + tb
.millitm
;
1549 static int32 start
= 0;
1552 if (gettimeofday (&tv
, NULL
) == 0)
1554 now
= tv
.tv_sec
* 1000 + tv
.tv_usec
/ 1000;
1568 void prim_clock (void)
1570 arg1
= encode_int (read_clock ());
1574 void prim_motor (void)
1576 decode_2_int_args ();
1578 if (a1
< 1 || a1
> 2 || a2
< -100 || a2
> 100)
1579 ERROR("argument out of range to procedure \"motor\"");
1589 printf ("motor %d -> power=%d\n", a1
, a2
);
1599 void prim_led (void)
1601 decode_2_int_args ();
1602 a3
= decode_int (arg3
);
1604 if (a1
< 1 || a1
> 3 || a2
< 0 || a3
< 0)
1605 ERROR("argument out of range to procedure \"led\"");
1609 LED_set( a1
, a2
, a3
);
1615 printf ("led %d -> duty=%d period=%d\n", a1
, a2
, a3
);
1626 void prim_led2_color (void)
1628 a1
= decode_int (arg1
);
1630 if (a1
< 0 || a1
> 1)
1631 ERROR("argument out of range to procedure \"led2-color\"");
1635 LED2_color_set( a1
);
1641 printf ("led2-color -> %s\n", (a1
==0)?"green":"red");
1650 void prim_getchar_wait (void)
1652 decode_2_int_args();
1653 a1
= read_clock () + a1
;
1655 if (a1
< 0 || a2
< 1 || a2
> 3)
1656 ERROR("argument out of range to procedure \"getchar-wait\"");
1663 serial_port_set ports
;
1664 ports
= serial_rx_wait_with_timeout( a2
, a1
);
1666 arg1
= encode_int (serial_rx_read( ports
));
1681 arg1
= encode_int (_getch ());
1684 } while (read_clock () < a1
);
1689 arg1
= encode_int (getchar ());
1697 void prim_putchar (void)
1699 decode_2_int_args ();
1701 if (a1
< 0 || a1
> 255 || a2
< 1 || a2
> 3)
1702 ERROR("argument out of range to procedure \"putchar\"");
1706 serial_tx_write( a2
, a1
);
1722 void prim_beep (void)
1724 decode_2_int_args ();
1726 if (a1
< 1 || a1
> 255 || a2
< 0)
1727 ERROR("argument out of range to procedure \"beep\"");
1731 beep( a1
, from_now( a2
) );
1737 printf ("beep -> freq-div=%d duration=%d\n", a1
, a2
);
1747 void prim_adc (void)
1751 a1
= decode_int (arg1
);
1753 if (a1
< 1 || a1
> 3)
1754 ERROR("argument out of range to procedure \"adc\"");
1764 x
= read_clock () & 255;
1766 if (x
> 127) x
= 256 - x
;
1772 arg1
= encode_int (x
);
1776 void prim_dac (void)
1778 a1
= decode_int (arg1
);
1780 if (a1
< 0 || a1
> 255)
1781 ERROR("argument out of range to procedure \"dac\"");
1791 printf ("dac -> %d\n", a1
);
1800 void prim_sernum (void)
1816 arg1
= encode_int (x
);
1820 /*---------------------------------------------------------------------------*/
1824 int hidden_fgetc (FILE *f
)
1834 #define fgetc(f) hidden_fgetc(f)
1836 void write_hex_nibble (int n
)
1838 putchar ("0123456789ABCDEF"[n
]);
1841 void write_hex (uint8 n
)
1843 write_hex_nibble (n
>> 4);
1844 write_hex_nibble (n
& 0x0f);
1849 if (c
>= '0' && c
<= '9')
1852 if (c
>= 'A' && c
<= 'F')
1853 return (c
- 'A' + 10);
1855 if (c
>= 'a' && c
<= 'f')
1856 return (c
- 'a' + 10);
1861 int read_hex_byte (FILE *f
)
1863 int h1
= hex (fgetc (f
));
1864 int h2
= hex (fgetc (f
));
1866 if (h1
>= 0 && h2
>= 0)
1867 return (h1
<<4) + h2
;
1872 int read_hex_file (char *filename
)
1875 FILE *f
= fopen (filename
, "r");
1885 for (i
=0; i
<ROM_BYTES
; i
++)
1890 while ((c
= fgetc (f
)) != EOF
)
1892 if ((c
== '\r') || (c
== '\n'))
1896 (len
= read_hex_byte (f
)) < 0 ||
1897 (a1
= read_hex_byte (f
)) < 0 ||
1898 (a2
= read_hex_byte (f
)) < 0 ||
1899 (t
= read_hex_byte (f
)) < 0)
1905 sum
= len
+ a1
+ a2
+ t
;
1913 unsigned long adr
= ((unsigned long)hi16
<< 16) + a
- CODE_START
;
1915 if ((b
= read_hex_byte (f
)) < 0)
1918 if (adr
>= 0 && adr
< ROM_BYTES
)
1921 a
= (a
+ 1) & 0xffff;
1938 if ((a1
= read_hex_byte (f
)) < 0 ||
1939 (a2
= read_hex_byte (f
)) < 0)
1944 hi16
= (a1
<<8) + a2
;
1949 if ((b
= read_hex_byte (f
)) < 0)
1956 printf ("*** HEX file checksum error (expected 0x%02x)\n", sum
);
1962 if ((c
!= '\r') && (c
!= '\n'))
1973 printf ("*** HEX file syntax error\n");
1983 /*---------------------------------------------------------------------------*/
1985 #define FETCH_NEXT_BYTECODE() bytecode = rom_get (pc++)
1987 #define BEGIN_DISPATCH() \
1989 IF_TRACE(show_state (pc)); \
1990 FETCH_NEXT_BYTECODE(); \
1991 bytecode_hi4 = bytecode & 0xf0; \
1992 bytecode_lo4 = bytecode & 0x0f; \
1993 switch (bytecode_hi4 >> 4) {
1995 #define END_DISPATCH() }
1997 #define CASE(opcode) case (opcode>>4):;
1999 #define DISPATCH(); goto dispatch;
2004 #define bytecode TABLAT
2005 #define bytecode_hi4 WREG
2008 #define PUSH_CONSTANT1 0x00
2009 #define PUSH_CONSTANT2 0x10
2010 #define PUSH_STACK1 0x20
2011 #define PUSH_STACK2 0x30
2012 #define PUSH_GLOBAL 0x40
2013 #define SET_GLOBAL 0x50
2016 #define LABEL_INSTR 0x80
2017 #define PUSH_CONSTANT_LONG 0x90
2019 // TODO these are free
2021 #define GOTO_IF_FALSE 0xb0
2022 #define CLOSURE 0xc0
2030 char *prim_name
[48] =
2054 "prim #%graft-to-cont",
2055 "prim #%return-to-cont",
2059 "prim #%string->list",
2060 "prim #%list->string",
2061 "prim #%make-u8vector", // TODO was prim29
2062 "prim #%u8vector-ref", // TODO was prim30
2063 "prim #%u8vector-set!", // TODO was prim31
2068 "prim #%led2-color",
2069 "prim #%getchar-wait",
2073 "prim #%u8vector?", // TODO was dac, but it's not plugged to anything
2075 "prim #%u8vector-length", // TODO was prim43
2076 "push-constant [long]",
2084 #define PUSH_ARG1() push_arg1 ()
2087 void push_arg1 (void)
2089 env
= cons (arg1
, env
);
2095 obj o
= ram_get_car (env
);
2096 env
= ram_get_cdr (env
);
2100 void pop_procedure (void)
2106 if (!RAM_CLOSURE(arg1
))
2107 TYPE_ERROR("pop_procedure", "procedure");
2109 entry
= ram_get_entry (arg1
) + CODE_START
; // FOO all addresses in the bytecode should be from 0, not from CODE_START, should be fixed everywhere, but might not be
2111 else if (IN_ROM(arg1
))
2113 if (!ROM_CLOSURE(arg1
))
2114 TYPE_ERROR("pop_procedure", "procedure");
2116 entry
= rom_get_entry (arg1
) + CODE_START
;
2119 TYPE_ERROR("pop_procedure", "procedure");
2122 void handle_arity_and_rest_param (void)
2126 np
= rom_get (entry
++);
2128 if ((np
& 0x80) == 0)
2131 ERROR("wrong number of arguments");
2138 ERROR("wrong number of arguments");
2146 arg3
= cons (arg4
, arg3
);
2152 arg1
= cons (arg3
, arg1
);
2157 void build_env (void)
2163 arg1
= cons (arg3
, arg1
);
2171 void save_cont (void)
2173 // the second half is a closure
2174 arg3
= alloc_ram_cell_init (CLOSURE_FIELD0
| (pc
>> 11),
2176 ((pc
& 0x0007) << 5) | (env
>> 8),
2178 cont
= alloc_ram_cell_init (COMPOSITE_FIELD0
| (cont
>> 8),
2180 CONTINUATION_FIELD2
| (arg3
>> 8),
2185 void interpreter (void)
2187 pc
= (CODE_START
+ 4) + ((rom_addr
)rom_get (CODE_START
+2) << 2);
2189 glovars
= rom_get (CODE_START
+3); // number of global variables
2195 /***************************************************************************/
2196 CASE(PUSH_CONSTANT1
);
2198 IF_TRACE(printf(" (push-constant "); show (bytecode_lo4
); printf (")\n"));
2200 arg1
= bytecode_lo4
;
2206 /***************************************************************************/
2207 CASE(PUSH_CONSTANT2
);
2209 IF_TRACE(printf(" (push-constant "); show (bytecode_lo4
+16); printf (")\n"));
2210 arg1
= bytecode_lo4
+16;
2216 /***************************************************************************/
2219 IF_TRACE(printf(" (push-stack %d)\n", bytecode_lo4
));
2223 while (bytecode_lo4
!= 0)
2225 arg1
= ram_get_cdr (arg1
);
2229 arg1
= ram_get_car (arg1
);
2235 /***************************************************************************/
2238 IF_TRACE(printf(" (push-stack %d)\n", bytecode_lo4
+16));
2239 // TODO does this ever happens ?
2244 while (bytecode_lo4
!= 0)
2246 arg1
= ram_get_cdr (arg1
);
2250 arg1
= ram_get_car (arg1
);
2256 /***************************************************************************/
2259 IF_TRACE(printf(" (push-global %d)\n", bytecode_lo4
));
2261 arg1
= get_global (bytecode_lo4
);
2267 /***************************************************************************/
2270 IF_TRACE(printf(" (set-global %d)\n", bytecode_lo4
));
2272 set_global (bytecode_lo4
, POP()); // TODO debug
2276 /***************************************************************************/
2279 IF_TRACE(printf(" (call %d)\n", bytecode_lo4
));
2284 handle_arity_and_rest_param ();
2295 /***************************************************************************/
2298 IF_TRACE(printf(" (jump %d)\n", bytecode_lo4
));
2303 handle_arity_and_rest_param ();
2313 /***************************************************************************/
2316 switch (bytecode_lo4
)
2318 case 0: // call-toplevel TODO put these in separate functions ?
2319 FETCH_NEXT_BYTECODE();
2322 FETCH_NEXT_BYTECODE();
2324 IF_TRACE(printf(" (call-toplevel 0x%04x)\n",
2325 ((arg2
<< 8) | bytecode
) + CODE_START
));
2327 entry
= (arg2
<< 8) + bytecode
+ CODE_START
;
2330 na
= rom_get (entry
++);
2343 case 1: // jump-toplevel
2344 FETCH_NEXT_BYTECODE();
2347 FETCH_NEXT_BYTECODE();
2349 IF_TRACE(printf(" (jump-toplevel 0x%04x)\n",
2350 ((arg2
<< 8) | bytecode
) + CODE_START
));
2352 entry
= (arg2
<< 8) + bytecode
+ CODE_START
; // TODO this is a common pattern
2355 na
= rom_get (entry
++);
2368 FETCH_NEXT_BYTECODE();
2371 FETCH_NEXT_BYTECODE();
2373 IF_TRACE(printf(" (goto 0x%04x)\n",
2374 (arg2
<< 8) + bytecode
+ CODE_START
));
2376 pc
= (arg2
<< 8) + bytecode
+ CODE_START
;
2380 case 3: // goto-if-false
2381 FETCH_NEXT_BYTECODE();
2384 FETCH_NEXT_BYTECODE();
2386 IF_TRACE(printf(" (goto-if-false 0x%04x)\n",
2387 (arg2
<< 8) + bytecode
+ CODE_START
));
2389 if (POP() == OBJ_FALSE
)
2390 pc
= (arg2
<< 8) + bytecode
+ CODE_START
;
2395 FETCH_NEXT_BYTECODE();
2398 FETCH_NEXT_BYTECODE();
2400 IF_TRACE(printf(" (closure 0x%04x)\n", (arg2
<< 8) | bytecode
));
2402 arg3
= POP(); // env
2404 entry
= (arg2
<< 8) | bytecode
;
2406 arg1
= alloc_ram_cell_init (CLOSURE_FIELD0
| (arg2
>> 3),
2407 ((arg2
& 0x07) << 5) | (bytecode
>> 3),
2408 ((bytecode
&0x07) <<5) |((arg3
&0x1f00) >>8),
2418 case 5: // call-toplevel-short
2419 FETCH_NEXT_BYTECODE(); // TODO the sort version have a lot in common with the long ones, abstract ?
2420 // TODO short instructions don't work at the moment
2421 IF_TRACE(printf(" (call-toplevel-short 0x%04x)\n",
2422 pc
+ bytecode
+ CODE_START
));
2424 entry
= pc
+ bytecode
+ CODE_START
;
2427 na
= rom_get (entry
++);
2439 case 6: // jump-toplevel-short
2440 FETCH_NEXT_BYTECODE();
2442 IF_TRACE(printf(" (jump-toplevel-short 0x%04x)\n",
2443 pc
+ bytecode
+ CODE_START
));
2445 entry
= pc
+ bytecode
+ CODE_START
;
2448 na
= rom_get (entry
++);
2459 case 7: // goto-short
2460 FETCH_NEXT_BYTECODE();
2462 IF_TRACE(printf(" (goto-short 0x%04x)\n", pc
+ bytecode
+ CODE_START
));
2464 pc
= pc
+ bytecode
+ CODE_START
;
2468 case 8: // goto-if-false-short
2469 FETCH_NEXT_BYTECODE();
2471 IF_TRACE(printf(" (goto-if-false-short 0x%04x)\n",
2472 pc
+ bytecode
+ CODE_START
));
2474 if (POP() == OBJ_FALSE
)
2475 pc
= pc
+ bytecode
+ CODE_START
;
2479 case 9: // closure-short TODO I doubt these short instrs will have great effect, and this is the one I doubt the most about
2480 FETCH_NEXT_BYTECODE();
2482 IF_TRACE(printf(" (closure-short 0x%04x)\n", pc
+ bytecode
));
2484 arg3
= POP(); // env
2486 entry
= pc
+ bytecode
; // TODO makes sense for a closure ?
2488 arg1
= alloc_ram_cell_init (CLOSURE_FIELD0
| (arg2
>> 3),
2489 ((arg2
& 0x07) << 5) | (bytecode
>> 3),
2490 ((bytecode
&0x07) <<5) |((arg3
&0x1f00) >>8),
2509 case 14: // push_global [long]
2510 FETCH_NEXT_BYTECODE();
2512 IF_TRACE(printf(" (push-global [long] %d)\n", bytecode
));
2514 arg1
= get_global (bytecode
);
2520 case 15: // set_global [long]
2521 FETCH_NEXT_BYTECODE();
2523 IF_TRACE(printf(" (set-global [long] %d)\n", bytecode
));
2525 set_global (bytecode
, POP());
2532 /***************************************************************************/
2533 CASE(PUSH_CONSTANT_LONG
);
2535 /* push-constant [long] */
2537 FETCH_NEXT_BYTECODE();
2539 IF_TRACE(printf(" (push [long] 0x%04x)\n", (bytecode_lo4
<< 8) + bytecode
));
2541 arg1
= (bytecode_lo4
<< 8) | bytecode
;
2546 /***************************************************************************/
2547 CASE(GOTO
); // BREGG move
2551 /***************************************************************************/
2552 CASE(GOTO_IF_FALSE
); // BREGG move
2556 /***************************************************************************/
2557 CASE(CLOSURE
); // BREGG move
2561 /***************************************************************************/
2564 IF_TRACE(printf(" (%s)\n", prim_name
[bytecode_lo4
]));
2566 switch (bytecode_lo4
)
2569 arg1
= POP(); prim_numberp (); PUSH_ARG1(); break;
2571 arg2
= POP(); arg1
= POP(); prim_add (); PUSH_ARG1(); break;
2573 arg2
= POP(); arg1
= POP(); prim_sub (); PUSH_ARG1(); break;
2575 arg2
= POP(); arg1
= POP(); prim_mul (); PUSH_ARG1(); break;
2577 arg2
= POP(); arg1
= POP(); prim_div (); PUSH_ARG1(); break;
2579 arg2
= POP(); arg1
= POP(); prim_rem (); PUSH_ARG1(); break;
2581 arg1
= POP(); prim_neg (); PUSH_ARG1(); break;
2583 arg2
= POP(); arg1
= POP(); prim_eq (); PUSH_ARG1(); break;
2585 arg2
= POP(); arg1
= POP(); prim_lt (); PUSH_ARG1(); break;
2587 arg2
= POP(); arg1
= POP(); prim_ior (); PUSH_ARG1(); break;
2589 arg2
= POP(); arg1
= POP(); prim_gt (); PUSH_ARG1(); break;
2591 arg2
= POP(); arg1
= POP(); prim_xor (); PUSH_ARG1(); break;
2593 arg1
= POP(); prim_pairp (); PUSH_ARG1(); break;
2595 arg2
= POP(); arg1
= POP(); prim_cons (); PUSH_ARG1(); break;
2597 arg1
= POP(); prim_car (); PUSH_ARG1(); break;
2599 arg1
= POP(); prim_cdr (); PUSH_ARG1(); break;
2604 /***************************************************************************/
2607 IF_TRACE(printf(" (%s)\n", prim_name
[bytecode_lo4
+16]));
2609 switch (bytecode_lo4
)
2612 arg2
= POP(); arg1
= POP(); prim_set_car (); break;
2614 arg2
= POP(); arg1
= POP(); prim_set_cdr (); break;
2616 arg1
= POP(); prim_nullp (); PUSH_ARG1(); break;
2618 arg2
= POP(); arg1
= POP(); prim_eqp (); PUSH_ARG1(); break;
2620 arg1
= POP(); prim_not (); PUSH_ARG1(); break;
2622 /* prim #%get-cont */
2627 /* prim #%graft-to-cont */
2629 arg1
= POP(); /* thunk to call */
2630 cont
= POP(); /* continuation */
2637 handle_arity_and_rest_param ();
2647 /* prim #%return-to-cont */
2649 arg1
= POP(); /* value to return */
2650 cont
= POP(); /* continuation */
2652 arg2
= ram_get_cdr (cont
);
2654 pc
= ram_get_entry (arg2
);
2656 env
= ram_get_cdr (arg2
);
2657 cont
= ram_get_car (cont
);
2667 /* prim #%symbol? */
2668 arg1
= POP(); prim_symbolp (); PUSH_ARG1(); break;
2670 /* prim #%string? */
2671 arg1
= POP(); prim_stringp (); PUSH_ARG1(); break;
2673 /* prim #%string->list */
2674 arg1
= POP(); prim_string2list (); PUSH_ARG1(); break;
2676 /* prim #%list->string */
2677 arg1
= POP(); prim_list2string (); PUSH_ARG1(); break;
2679 /* prim #%make-u8vector */
2680 arg2
= POP(); arg1
= POP(); prim_make_u8vector (); PUSH_ARG1(); break;
2682 /* prim #%u8vector-ref */
2683 arg2
= POP(); arg1
= POP(); prim_u8vector_ref (); PUSH_ARG1(); break;
2685 /* prim #%u8vector-set! */
2686 arg3
= POP(); arg2
= POP(); arg1
= POP(); prim_u8vector_set (); break;
2691 /***************************************************************************/
2694 IF_TRACE(printf(" (%s)\n", prim_name
[bytecode_lo4
+32]));
2696 switch (bytecode_lo4
)
2705 prim_clock (); PUSH_ARG1(); break;
2708 arg2
= POP(); arg1
= POP(); prim_motor (); break;
2711 arg3
= POP(); arg2
= POP(); arg1
= POP(); prim_led (); ;break;
2713 /* prim #%led2-color */
2714 arg1
= POP(); prim_led2_color (); break;
2716 /* prim #%getchar-wait */
2717 arg2
= POP(); arg1
= POP(); prim_getchar_wait (); PUSH_ARG1(); break;
2719 /* prim #%putchar */
2720 arg2
= POP(); arg1
= POP(); prim_putchar (); break;
2723 arg2
= POP(); arg1
= POP(); prim_beep (); break;
2726 arg1
= POP(); prim_adc (); PUSH_ARG1(); break;
2728 /* prim #%u8vector? */
2729 arg1
= POP(); prim_u8vectorp (); PUSH_ARG1(); break;
2732 prim_sernum (); PUSH_ARG1(); break;
2734 /* prim #%u8vector-length */
2735 arg1
= POP(); prim_u8vector_length (); PUSH_ARG1(); break;
2737 // FREE find something to do with this
2752 arg2
= ram_get_cdr (cont
);
2753 pc
= ram_get_entry (arg2
);
2754 env
= ram_get_cdr (arg2
);
2755 cont
= ram_get_car (cont
);
2763 /***************************************************************************/
2768 /*---------------------------------------------------------------------------*/
2774 printf ("usage: sim file.hex\n");
2778 int main (int argc
, char *argv
[])
2781 rom_addr rom_start_addr
= 0;
2783 if (argc
> 1 && argv
[1][0] == '-' && argv
[1][1] == 's')
2790 if ((h1
= hex (argv
[1][2])) < 0 ||
2791 (h2
= hex (argv
[1][3])) < 0 ||
2792 (h3
= hex (argv
[1][4])) != 0 ||
2793 (h4
= hex (argv
[1][5])) != 0 ||
2797 rom_start_addr
= (h1
<< 12) | (h2
<< 8) | (h3
<< 4) | h4
;
2804 printf ("Start address = 0x%04x\n", rom_start_addr
); // TODO says 0, but should be CODE_START ?
2810 if (!read_hex_file (argv
[1]))
2811 printf ("*** Could not read hex file \"%s\"\n", argv
[1]);
2816 if (rom_get (CODE_START
+0) != 0xfb ||
2817 rom_get (CODE_START
+1) != 0xd7)
2818 printf ("*** The hex file was not compiled with PICOBIT\n");
2822 for (i
=0; i
<8192; i
++) // TODO remove this ? and not the night address space, now 16 bits
2823 if (rom_get (i
) != 0xff)
2824 printf ("rom_mem[0x%04x] = 0x%02x\n", i
, rom_get (i
));
2830 printf ("**************** memory needed = %d\n", max_live
+1);
2840 /*---------------------------------------------------------------------------*/