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 ((n
- (ram_get_cdr(o
) * 4)) < 4) // TODO is there a better way ?
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
);
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 obj elems
= alloc_vec_cell (arg1
); // arg1 is length
1301 arg1
= alloc_ram_cell_init (COMPOSITE_FIELD0
| (arg1
>> 8),
1303 VECTOR_FIELD2
| (elems
>> 8),
1305 // the contents of the vector are intentionally left as they were.
1306 // it is up to the library functions to set them accordingly
1309 void prim_u8vector_ref (void)
1310 { // TODO how do we deal with rom vectors ? as lists ? they're never all that long
1311 arg2
= decode_int (arg2
);
1315 if (!RAM_VECTOR(arg1
))
1316 TYPE_ERROR("u8vector-ref", "vector");
1317 if (ram_get_car (arg1
) < arg2
)
1318 ERROR("vector index too large");
1319 arg1
= ram_get_cdr (arg1
);
1321 else if (IN_ROM(arg1
))
1323 if (!ROM_VECTOR(arg1
))
1324 TYPE_ERROR("u8vector-ref", "vector");
1325 arg3
= rom_get_car (arg1
); // we'll need the length later
1327 ERROR("vector index too large");
1328 arg1
= rom_get_cdr (arg1
);
1331 TYPE_ERROR("u8vector-ref", "vector");
1341 arg1
= ram_get_field0 (arg1
); break;
1343 arg1
= ram_get_field1 (arg1
); break;
1345 arg1
= ram_get_field2 (arg1
); break;
1347 arg1
= ram_get_field3 (arg1
); break;
1350 arg1
= encode_int (arg1
);
1352 else // rom vector, stored as a list
1353 { // 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)
1354 arg4
= arg2
; // we save the index
1357 arg1
= rom_get_cdr (arg1
);
1359 // since rom vectors are dotted pairs, the last element is in cdr
1360 if (arg4
< (arg3
- 1))
1361 arg1
= rom_get_car (arg1
);
1369 void prim_u8vector_set (void)
1370 { // TODO a lot in common with ref, abstract that
1371 arg2
= decode_int (arg2
);
1372 arg3
= decode_int (arg3
);
1375 ERROR("byte vectors can only contain bytes");
1379 if (!RAM_VECTOR(arg1
))
1380 TYPE_ERROR("u8vector-set!", "vector");
1381 if (ram_get_car (arg1
) < arg2
)
1382 ERROR("vector index too large");
1383 arg1
= ram_get_cdr (arg1
);
1386 TYPE_ERROR("u8vector-set!", "vector");
1394 ram_set_field0 (arg1
, arg3
); break;
1396 ram_set_field1 (arg1
, arg3
); break;
1398 ram_set_field2 (arg1
, arg3
); break;
1400 ram_set_field3 (arg1
, arg3
); break;
1408 void prim_u8vector_length (void)
1412 if (!RAM_VECTOR(arg1
))
1413 TYPE_ERROR("u8vector-length", "vector");
1414 arg1
= encode_int (ram_get_car (arg1
));
1416 else if (IN_ROM(arg1
))
1418 if (!ROM_VECTOR(arg1
))
1419 TYPE_ERROR("u8vector-length", "vector");
1420 arg1
= rom_get_car (arg1
);
1423 TYPE_ERROR("u8vector-length", "vector");
1426 /*---------------------------------------------------------------------------*/
1428 /* Miscellaneous operations */
1430 void prim_eqp (void)
1432 arg1
= encode_bool (arg1
== arg2
);
1436 void prim_not (void)
1438 arg1
= encode_bool (arg1
== OBJ_FALSE
);
1441 void prim_symbolp (void)
1444 arg1
= encode_bool (RAM_SYMBOL(arg1
));
1445 else if (IN_ROM(arg1
))
1446 arg1
= encode_bool (ROM_SYMBOL(arg1
));
1451 void prim_stringp (void)
1454 arg1
= encode_bool (RAM_STRING(arg1
));
1455 else if (IN_ROM(arg1
))
1456 arg1
= encode_bool (ROM_STRING(arg1
));
1461 void prim_string2list (void)
1465 if (!RAM_STRING(arg1
))
1466 TYPE_ERROR("string->list", "string");
1468 arg1
= ram_get_car (arg1
);
1470 else if (IN_ROM(arg1
))
1472 if (!ROM_STRING(arg1
))
1473 TYPE_ERROR("string->list", "string");
1475 arg1
= rom_get_car (arg1
);
1478 TYPE_ERROR("string->list", "string");
1481 void prim_list2string (void)
1483 arg1
= alloc_ram_cell_init (COMPOSITE_FIELD0
| ((arg1
& 0x1f00) >> 8),
1490 /*---------------------------------------------------------------------------*/
1492 /* Robot specific operations */
1495 void prim_print (void)
1510 int32
read_clock (void)
1516 now
= from_now( 0 );
1524 static int32 start
= 0;
1529 now
= tb
.time
* 1000 + tb
.millitm
;
1536 static int32 start
= 0;
1539 if (gettimeofday (&tv
, NULL
) == 0)
1541 now
= tv
.tv_sec
* 1000 + tv
.tv_usec
/ 1000;
1555 void prim_clock (void)
1557 arg1
= encode_int (read_clock ());
1561 void prim_motor (void)
1563 decode_2_int_args ();
1565 if (a1
< 1 || a1
> 2 || a2
< -100 || a2
> 100)
1566 ERROR("argument out of range to procedure \"motor\"");
1576 printf ("motor %d -> power=%d\n", a1
, a2
);
1586 void prim_led (void)
1588 decode_2_int_args ();
1589 a3
= decode_int (arg3
);
1591 if (a1
< 1 || a1
> 3 || a2
< 0 || a3
< 0)
1592 ERROR("argument out of range to procedure \"led\"");
1596 LED_set( a1
, a2
, a3
);
1602 printf ("led %d -> duty=%d period=%d\n", a1
, a2
, a3
);
1613 void prim_led2_color (void)
1615 a1
= decode_int (arg1
);
1617 if (a1
< 0 || a1
> 1)
1618 ERROR("argument out of range to procedure \"led2-color\"");
1622 LED2_color_set( a1
);
1628 printf ("led2-color -> %s\n", (a1
==0)?"green":"red");
1637 void prim_getchar_wait (void)
1639 decode_2_int_args();
1640 a1
= read_clock () + a1
;
1642 if (a1
< 0 || a2
< 1 || a2
> 3)
1643 ERROR("argument out of range to procedure \"getchar-wait\"");
1650 serial_port_set ports
;
1651 ports
= serial_rx_wait_with_timeout( a2
, a1
);
1653 arg1
= encode_int (serial_rx_read( ports
));
1668 arg1
= encode_int (_getch ());
1671 } while (read_clock () < a1
);
1676 arg1
= encode_int (getchar ());
1684 void prim_putchar (void)
1686 decode_2_int_args ();
1688 if (a1
< 0 || a1
> 255 || a2
< 1 || a2
> 3)
1689 ERROR("argument out of range to procedure \"putchar\"");
1693 serial_tx_write( a2
, a1
);
1709 void prim_beep (void)
1711 decode_2_int_args ();
1713 if (a1
< 1 || a1
> 255 || a2
< 0)
1714 ERROR("argument out of range to procedure \"beep\"");
1718 beep( a1
, from_now( a2
) );
1724 printf ("beep -> freq-div=%d duration=%d\n", a1
, a2
);
1734 void prim_adc (void)
1738 a1
= decode_int (arg1
);
1740 if (a1
< 1 || a1
> 3)
1741 ERROR("argument out of range to procedure \"adc\"");
1751 x
= read_clock () & 255;
1753 if (x
> 127) x
= 256 - x
;
1759 arg1
= encode_int (x
);
1763 void prim_dac (void)
1765 a1
= decode_int (arg1
);
1767 if (a1
< 0 || a1
> 255)
1768 ERROR("argument out of range to procedure \"dac\"");
1778 printf ("dac -> %d\n", a1
);
1787 void prim_sernum (void)
1803 arg1
= encode_int (x
);
1807 /*---------------------------------------------------------------------------*/
1811 int hidden_fgetc (FILE *f
)
1821 #define fgetc(f) hidden_fgetc(f)
1823 void write_hex_nibble (int n
)
1825 putchar ("0123456789ABCDEF"[n
]);
1828 void write_hex (uint8 n
)
1830 write_hex_nibble (n
>> 4);
1831 write_hex_nibble (n
& 0x0f);
1836 if (c
>= '0' && c
<= '9')
1839 if (c
>= 'A' && c
<= 'F')
1840 return (c
- 'A' + 10);
1842 if (c
>= 'a' && c
<= 'f')
1843 return (c
- 'a' + 10);
1848 int read_hex_byte (FILE *f
)
1850 int h1
= hex (fgetc (f
));
1851 int h2
= hex (fgetc (f
));
1853 if (h1
>= 0 && h2
>= 0)
1854 return (h1
<<4) + h2
;
1859 int read_hex_file (char *filename
)
1862 FILE *f
= fopen (filename
, "r");
1872 for (i
=0; i
<ROM_BYTES
; i
++)
1877 while ((c
= fgetc (f
)) != EOF
)
1879 if ((c
== '\r') || (c
== '\n'))
1883 (len
= read_hex_byte (f
)) < 0 ||
1884 (a1
= read_hex_byte (f
)) < 0 ||
1885 (a2
= read_hex_byte (f
)) < 0 ||
1886 (t
= read_hex_byte (f
)) < 0)
1892 sum
= len
+ a1
+ a2
+ t
;
1900 unsigned long adr
= ((unsigned long)hi16
<< 16) + a
- CODE_START
;
1902 if ((b
= read_hex_byte (f
)) < 0)
1905 if (adr
>= 0 && adr
< ROM_BYTES
)
1908 a
= (a
+ 1) & 0xffff;
1925 if ((a1
= read_hex_byte (f
)) < 0 ||
1926 (a2
= read_hex_byte (f
)) < 0)
1931 hi16
= (a1
<<8) + a2
;
1936 if ((b
= read_hex_byte (f
)) < 0)
1943 printf ("*** HEX file checksum error (expected 0x%02x)\n", sum
);
1949 if ((c
!= '\r') && (c
!= '\n'))
1960 printf ("*** HEX file syntax error\n");
1970 /*---------------------------------------------------------------------------*/
1972 #define FETCH_NEXT_BYTECODE() bytecode = rom_get (pc++)
1974 #define BEGIN_DISPATCH() \
1976 IF_TRACE(show_state (pc)); \
1977 FETCH_NEXT_BYTECODE(); \
1978 bytecode_hi4 = bytecode & 0xf0; \
1979 bytecode_lo4 = bytecode & 0x0f; \
1980 switch (bytecode_hi4 >> 4) {
1982 #define END_DISPATCH() }
1984 #define CASE(opcode) case (opcode>>4):;
1986 #define DISPATCH(); goto dispatch;
1991 #define bytecode TABLAT
1992 #define bytecode_hi4 WREG
1995 #define PUSH_CONSTANT1 0x00
1996 #define PUSH_CONSTANT2 0x10
1997 #define PUSH_STACK1 0x20
1998 #define PUSH_STACK2 0x30
1999 #define PUSH_GLOBAL 0x40
2000 #define SET_GLOBAL 0x50
2003 #define LABEL_INSTR 0x80
2004 #define PUSH_CONSTANT_LONG 0x90
2006 // TODO these are free
2008 #define GOTO_IF_FALSE 0xb0
2009 #define CLOSURE 0xc0
2017 char *prim_name
[48] =
2041 "prim #%graft-to-cont",
2042 "prim #%return-to-cont",
2046 "prim #%string->list",
2047 "prim #%list->string",
2048 "prim #%make-u8vector", // TODO was prim29
2049 "prim #%u8vector-ref", // TODO was prim30
2050 "prim #%u8vector-set!", // TODO was prim31
2055 "prim #%led2-color",
2056 "prim #%getchar-wait",
2060 "prim #%u8vector?", // TODO was dac, but it's not plugged to anything
2062 "prim #%u8vector-length", // TODO was prim43
2063 "push-constant [long]",
2071 #define PUSH_ARG1() push_arg1 ()
2074 void push_arg1 (void)
2076 env
= cons (arg1
, env
);
2082 obj o
= ram_get_car (env
);
2083 env
= ram_get_cdr (env
);
2087 void pop_procedure (void)
2093 if (!RAM_CLOSURE(arg1
))
2094 TYPE_ERROR("pop_procedure", "procedure");
2096 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
2098 else if (IN_ROM(arg1
))
2100 if (!ROM_CLOSURE(arg1
))
2101 TYPE_ERROR("pop_procedure", "procedure");
2103 entry
= rom_get_entry (arg1
) + CODE_START
;
2106 TYPE_ERROR("pop_procedure", "procedure");
2109 void handle_arity_and_rest_param (void)
2113 np
= rom_get (entry
++);
2115 if ((np
& 0x80) == 0)
2118 ERROR("wrong number of arguments");
2125 ERROR("wrong number of arguments");
2133 arg3
= cons (arg4
, arg3
);
2139 arg1
= cons (arg3
, arg1
);
2144 void build_env (void)
2150 arg1
= cons (arg3
, arg1
);
2158 void save_cont (void)
2160 // the second half is a closure
2161 arg3
= alloc_ram_cell_init (CLOSURE_FIELD0
| (pc
>> 11),
2163 ((pc
& 0x0007) << 5) | (env
>> 8),
2165 cont
= alloc_ram_cell_init (COMPOSITE_FIELD0
| (cont
>> 8),
2167 CONTINUATION_FIELD2
| (arg3
>> 8),
2172 void interpreter (void)
2174 pc
= (CODE_START
+ 4) + ((rom_addr
)rom_get (CODE_START
+2) << 2);
2176 glovars
= rom_get (CODE_START
+3); // number of global variables
2182 /***************************************************************************/
2183 CASE(PUSH_CONSTANT1
);
2185 IF_TRACE(printf(" (push-constant "); show (bytecode_lo4
); printf (")\n"));
2187 arg1
= bytecode_lo4
;
2193 /***************************************************************************/
2194 CASE(PUSH_CONSTANT2
);
2196 IF_TRACE(printf(" (push-constant "); show (bytecode_lo4
+16); printf (")\n"));
2197 arg1
= bytecode_lo4
+16;
2203 /***************************************************************************/
2206 IF_TRACE(printf(" (push-stack %d)\n", bytecode_lo4
));
2210 while (bytecode_lo4
!= 0)
2212 arg1
= ram_get_cdr (arg1
);
2216 arg1
= ram_get_car (arg1
);
2222 /***************************************************************************/
2225 IF_TRACE(printf(" (push-stack %d)\n", bytecode_lo4
+16));
2226 // TODO does this ever happens ?
2231 while (bytecode_lo4
!= 0)
2233 arg1
= ram_get_cdr (arg1
);
2237 arg1
= ram_get_car (arg1
);
2243 /***************************************************************************/
2246 IF_TRACE(printf(" (push-global %d)\n", bytecode_lo4
));
2248 arg1
= get_global (bytecode_lo4
);
2254 /***************************************************************************/
2257 IF_TRACE(printf(" (set-global %d)\n", bytecode_lo4
));
2259 set_global (bytecode_lo4
, POP()); // TODO debug
2263 /***************************************************************************/
2266 IF_TRACE(printf(" (call %d)\n", bytecode_lo4
));
2271 handle_arity_and_rest_param ();
2282 /***************************************************************************/
2285 IF_TRACE(printf(" (jump %d)\n", bytecode_lo4
));
2290 handle_arity_and_rest_param ();
2300 /***************************************************************************/
2303 switch (bytecode_lo4
)
2305 case 0: // call-toplevel TODO put these in separate functions ?
2306 FETCH_NEXT_BYTECODE();
2309 FETCH_NEXT_BYTECODE();
2311 IF_TRACE(printf(" (call-toplevel 0x%04x)\n",
2312 ((arg2
<< 8) | bytecode
) + CODE_START
));
2314 entry
= (arg2
<< 8) + bytecode
+ CODE_START
;
2317 na
= rom_get (entry
++);
2330 case 1: // jump-toplevel
2331 FETCH_NEXT_BYTECODE();
2334 FETCH_NEXT_BYTECODE();
2336 IF_TRACE(printf(" (jump-toplevel 0x%04x)\n",
2337 ((arg2
<< 8) | bytecode
) + CODE_START
));
2339 entry
= (arg2
<< 8) + bytecode
+ CODE_START
; // TODO this is a common pattern
2342 na
= rom_get (entry
++);
2355 FETCH_NEXT_BYTECODE();
2358 FETCH_NEXT_BYTECODE();
2360 IF_TRACE(printf(" (goto 0x%04x)\n",
2361 (arg2
<< 8) + bytecode
+ CODE_START
));
2363 pc
= (arg2
<< 8) + bytecode
+ CODE_START
;
2367 case 3: // goto-if-false
2368 FETCH_NEXT_BYTECODE();
2371 FETCH_NEXT_BYTECODE();
2373 IF_TRACE(printf(" (goto-if-false 0x%04x)\n",
2374 (arg2
<< 8) + bytecode
+ CODE_START
));
2376 if (POP() == OBJ_FALSE
)
2377 pc
= (arg2
<< 8) + bytecode
+ CODE_START
;
2382 FETCH_NEXT_BYTECODE();
2385 FETCH_NEXT_BYTECODE();
2387 IF_TRACE(printf(" (closure 0x%04x)\n", (arg2
<< 8) | bytecode
));
2389 arg3
= POP(); // env
2391 entry
= (arg2
<< 8) | bytecode
;
2393 arg1
= alloc_ram_cell_init (CLOSURE_FIELD0
| (arg2
>> 3),
2394 ((arg2
& 0x07) << 5) | (bytecode
>> 3),
2395 ((bytecode
&0x07) <<5) |((arg3
&0x1f00) >>8),
2405 case 5: // call-toplevel-short
2406 FETCH_NEXT_BYTECODE(); // TODO the sort version have a lot in common with the long ones, abstract ?
2407 // TODO short instructions don't work at the moment
2408 IF_TRACE(printf(" (call-toplevel-short 0x%04x)\n",
2409 pc
+ bytecode
+ CODE_START
));
2411 entry
= pc
+ bytecode
+ CODE_START
;
2414 na
= rom_get (entry
++);
2426 case 6: // jump-toplevel-short
2427 FETCH_NEXT_BYTECODE();
2429 IF_TRACE(printf(" (jump-toplevel-short 0x%04x)\n",
2430 pc
+ bytecode
+ CODE_START
));
2432 entry
= pc
+ bytecode
+ CODE_START
;
2435 na
= rom_get (entry
++);
2446 case 7: // goto-short
2447 FETCH_NEXT_BYTECODE();
2449 IF_TRACE(printf(" (goto-short 0x%04x)\n", pc
+ bytecode
+ CODE_START
));
2451 pc
= pc
+ bytecode
+ CODE_START
;
2455 case 8: // goto-if-false-short
2456 FETCH_NEXT_BYTECODE();
2458 IF_TRACE(printf(" (goto-if-false-short 0x%04x)\n",
2459 pc
+ bytecode
+ CODE_START
));
2461 if (POP() == OBJ_FALSE
)
2462 pc
= pc
+ bytecode
+ CODE_START
;
2466 case 9: // closure-short TODO I doubt these short instrs will have great effect, and this is the one I doubt the most about
2467 FETCH_NEXT_BYTECODE();
2469 IF_TRACE(printf(" (closure-short 0x%04x)\n", pc
+ bytecode
));
2471 arg3
= POP(); // env
2473 entry
= pc
+ bytecode
; // TODO makes sense for a closure ?
2475 arg1
= alloc_ram_cell_init (CLOSURE_FIELD0
| (arg2
>> 3),
2476 ((arg2
& 0x07) << 5) | (bytecode
>> 3),
2477 ((bytecode
&0x07) <<5) |((arg3
&0x1f00) >>8),
2496 case 14: // push_global [long]
2497 FETCH_NEXT_BYTECODE();
2499 IF_TRACE(printf(" (push-global [long] %d)\n", bytecode
));
2501 arg1
= get_global (bytecode
);
2507 case 15: // set_global [long]
2508 FETCH_NEXT_BYTECODE();
2510 IF_TRACE(printf(" (set-global [long] %d)\n", bytecode
));
2512 set_global (bytecode
, POP());
2519 /***************************************************************************/
2520 CASE(PUSH_CONSTANT_LONG
);
2522 /* push-constant [long] */
2524 FETCH_NEXT_BYTECODE();
2526 IF_TRACE(printf(" (push [long] 0x%04x)\n", (bytecode_lo4
<< 8) + bytecode
));
2528 arg1
= (bytecode_lo4
<< 8) | bytecode
;
2533 /***************************************************************************/
2534 CASE(GOTO
); // BREGG move
2538 /***************************************************************************/
2539 CASE(GOTO_IF_FALSE
); // BREGG move
2543 /***************************************************************************/
2544 CASE(CLOSURE
); // BREGG move
2548 /***************************************************************************/
2551 IF_TRACE(printf(" (%s)\n", prim_name
[bytecode_lo4
]));
2553 switch (bytecode_lo4
)
2556 arg1
= POP(); prim_numberp (); PUSH_ARG1(); break;
2558 arg2
= POP(); arg1
= POP(); prim_add (); PUSH_ARG1(); break;
2560 arg2
= POP(); arg1
= POP(); prim_sub (); PUSH_ARG1(); break;
2562 arg2
= POP(); arg1
= POP(); prim_mul (); PUSH_ARG1(); break;
2564 arg2
= POP(); arg1
= POP(); prim_div (); PUSH_ARG1(); break;
2566 arg2
= POP(); arg1
= POP(); prim_rem (); PUSH_ARG1(); break;
2568 arg1
= POP(); prim_neg (); PUSH_ARG1(); break;
2570 arg2
= POP(); arg1
= POP(); prim_eq (); PUSH_ARG1(); break;
2572 arg2
= POP(); arg1
= POP(); prim_lt (); PUSH_ARG1(); break;
2574 arg2
= POP(); arg1
= POP(); prim_ior (); PUSH_ARG1(); break;
2576 arg2
= POP(); arg1
= POP(); prim_gt (); PUSH_ARG1(); break;
2578 arg2
= POP(); arg1
= POP(); prim_xor (); PUSH_ARG1(); break;
2580 arg1
= POP(); prim_pairp (); PUSH_ARG1(); break;
2582 arg2
= POP(); arg1
= POP(); prim_cons (); PUSH_ARG1(); break;
2584 arg1
= POP(); prim_car (); PUSH_ARG1(); break;
2586 arg1
= POP(); prim_cdr (); PUSH_ARG1(); break;
2591 /***************************************************************************/
2594 IF_TRACE(printf(" (%s)\n", prim_name
[bytecode_lo4
+16]));
2596 switch (bytecode_lo4
)
2599 arg2
= POP(); arg1
= POP(); prim_set_car (); break;
2601 arg2
= POP(); arg1
= POP(); prim_set_cdr (); break;
2603 arg1
= POP(); prim_nullp (); PUSH_ARG1(); break;
2605 arg2
= POP(); arg1
= POP(); prim_eqp (); PUSH_ARG1(); break;
2607 arg1
= POP(); prim_not (); PUSH_ARG1(); break;
2609 /* prim #%get-cont */
2614 /* prim #%graft-to-cont */
2616 arg1
= POP(); /* thunk to call */
2617 cont
= POP(); /* continuation */
2624 handle_arity_and_rest_param ();
2634 /* prim #%return-to-cont */
2636 arg1
= POP(); /* value to return */
2637 cont
= POP(); /* continuation */
2639 arg2
= ram_get_cdr (cont
);
2641 pc
= ram_get_entry (arg2
);
2643 env
= ram_get_cdr (arg2
);
2644 cont
= ram_get_car (cont
);
2654 /* prim #%symbol? */
2655 arg1
= POP(); prim_symbolp (); PUSH_ARG1(); break;
2657 /* prim #%string? */
2658 arg1
= POP(); prim_stringp (); PUSH_ARG1(); break;
2660 /* prim #%string->list */
2661 arg1
= POP(); prim_string2list (); PUSH_ARG1(); break;
2663 /* prim #%list->string */
2664 arg1
= POP(); prim_list2string (); PUSH_ARG1(); break;
2666 /* prim #%make-u8vector */
2667 arg1
= POP(); prim_make_u8vector (); PUSH_ARG1(); break;
2669 /* prim #%u8vector-ref */
2670 arg2
= POP(); arg1
= POP(); prim_u8vector_ref (); PUSH_ARG1(); break;
2672 /* prim #%u8vector-set! */
2673 arg3
= POP(); arg2
= POP(); arg1
= POP(); prim_u8vector_set (); break;
2678 /***************************************************************************/
2681 IF_TRACE(printf(" (%s)\n", prim_name
[bytecode_lo4
+32]));
2683 switch (bytecode_lo4
)
2692 prim_clock (); PUSH_ARG1(); break;
2695 arg2
= POP(); arg1
= POP(); prim_motor (); break;
2698 arg3
= POP(); arg2
= POP(); arg1
= POP(); prim_led (); ;break;
2700 /* prim #%led2-color */
2701 arg1
= POP(); prim_led2_color (); break;
2703 /* prim #%getchar-wait */
2704 arg2
= POP(); arg1
= POP(); prim_getchar_wait (); PUSH_ARG1(); break;
2706 /* prim #%putchar */
2707 arg2
= POP(); arg1
= POP(); prim_putchar (); break;
2710 arg2
= POP(); arg1
= POP(); prim_beep (); break;
2713 arg1
= POP(); prim_adc (); PUSH_ARG1(); break;
2715 /* prim #%u8vector? */
2716 arg1
= POP(); prim_u8vectorp (); PUSH_ARG1(); break;
2719 prim_sernum (); PUSH_ARG1(); break;
2721 /* prim #%u8vector-length */
2722 arg1
= POP(); prim_u8vector_length (); PUSH_ARG1(); break;
2724 // FREE find something to do with this
2739 arg2
= ram_get_cdr (cont
);
2740 pc
= ram_get_entry (arg2
);
2741 env
= ram_get_cdr (arg2
);
2742 cont
= ram_get_car (cont
);
2750 /***************************************************************************/
2755 /*---------------------------------------------------------------------------*/
2761 printf ("usage: sim file.hex\n");
2765 int main (int argc
, char *argv
[])
2768 rom_addr rom_start_addr
= 0;
2770 if (argc
> 1 && argv
[1][0] == '-' && argv
[1][1] == 's')
2777 if ((h1
= hex (argv
[1][2])) < 0 ||
2778 (h2
= hex (argv
[1][3])) < 0 ||
2779 (h3
= hex (argv
[1][4])) != 0 ||
2780 (h4
= hex (argv
[1][5])) != 0 ||
2784 rom_start_addr
= (h1
<< 12) | (h2
<< 8) | (h3
<< 4) | h4
;
2791 printf ("Start address = 0x%04x\n", rom_start_addr
); // TODO says 0, but should be CODE_START ?
2797 if (!read_hex_file (argv
[1]))
2798 printf ("*** Could not read hex file \"%s\"\n", argv
[1]);
2803 if (rom_get (CODE_START
+0) != 0xfb ||
2804 rom_get (CODE_START
+1) != 0xd7)
2805 printf ("*** The hex file was not compiled with PICOBIT\n");
2809 for (i
=0; i
<8192; i
++) // TODO remove this ? and not the night address space, now 16 bits
2810 if (rom_get (i
) != 0xff)
2811 printf ("rom_mem[0x%04x] = 0x%02x\n", i
, rom_get (i
));
2817 printf ("**************** memory needed = %d\n", max_live
+1);
2827 /*---------------------------------------------------------------------------*/