From f06e043c172cdf4a53e97513ef081b285db50962 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Wed, 25 Jun 2008 11:33:52 -0400 Subject: [PATCH] Vectors are now r-a-lists, bitwise operations are there. All the features needed by PICOBIT are implemented. Now, we have a problem of address space, as well as constant and global variable counts. Next steps : change representation of objets to increase address space add vectors as contiguous space --- library.scm | 212 ++++++++++++++--------------------------------------------- picobit-vm.c | 52 ++++++++++----- picobit.scm | 72 ++++++++++---------- 3 files changed, 122 insertions(+), 214 deletions(-) diff --git a/library.scm b/library.scm index 22c5964..f5f3592 100644 --- a/library.scm +++ b/library.scm @@ -58,7 +58,8 @@ (define <= (lambda (x y) - (#%<= x y))) + ;; (#%<= x y) ;; ADDED not a primitive anymore + (or (< x y) (= x y)))) (define > (lambda (x y) @@ -66,7 +67,8 @@ (define >= (lambda (x y) - (#%>= x y))) + ;; (#%>= x y) ;; ADDED, not a primitive anymore + (or (> x y) (= x y)))) (define pair? (lambda (x) @@ -182,13 +184,13 @@ (define #%substring-aux1 (lambda (lst n) - (if (#%>= n 1) ;; TODO had an off-by-one + (if (>= n 1) ;; TODO had an off-by-one (#%substring-aux1 (#%cdr lst) (#%- n 1)) lst))) (define #%substring-aux2 (lambda (lst n) - (if (#%>= n 1) ;; TODO had an off-by-one + (if (>= n 1) ;; TODO had an off-by-one (#%cons (#%car lst) (#%substring-aux2 (#%cdr lst) (#%- n 1))) '()))) @@ -375,7 +377,11 @@ (if (and (pair? x) (pair? y)) (and (equal? (car x) (car y)) (equal? (cdr x) (cdr y))) - #f)))) ;; TODO implement for other types too, including vectors + (if (and (triplet? x) (triplet? y)) + (and (equal? (fst x) (fst y)) + (equal? (snd x) (snd y)) + (equal? (trd x) (trd y))) + #f))))) ;; TODO could this have a problem ? (define assoc (lambda (t l) ;; TODO rewrite once we have cond @@ -385,6 +391,11 @@ (car l) (assoc t (cdr l)))))) +;; TODO ordinary vectors are never more that 6 elements long in the stack, so implementing them as lists is acceptable +(define vector list) +(define vector-ref list-ref) +(define vector-set! list-set!) + (define triplet? (lambda (t) (#%triplet? t))) (define triplet (lambda (x y z) (#%triplet x y z))) (define fst (lambda (t) (#%fst t))) @@ -393,98 +404,37 @@ (define set-fst! (lambda (t v) (#%set-fst! t v))) (define set-snd! (lambda (t v) (#%set-snd! t v))) (define set-trd! (lambda (t v) (#%set-trd! t v))) - - -;; binary trees, represented by a triplet of the number of elements, the -;; maximum number of nodes of a tree of this depth (necessary for the search) -;; and the tree itself built from triplets : (root left right) -(define b-list ;; TODO name ? - (lambda x - (let* ((s (length x)) - (t (tree-size s))) - (triplet s t (b-list-aux s t x))))) -(define tree-size ; finds the nearest power of 2, going up - ;; simple dumb binary search - (lambda (n) - (if (< n 4096) - (if (< n 128) - (if (< n 16) - (if (< n 4) - (if (< n 2) 1 3) - (if (< n 8) 7 15)) - (if (< n 64) - (if (< n 32) 31 63) - 127)) - (if (< n 1024) - (if (< n 512) - (if (< n 256) 255 511) - 1023) - (if (< n 2048) 2047 4095))) - (if (< n 262144) - (if (< n 65536) - (if (< n 32768) - (if (< n 16384) 16383 32767) - 65535) - (if (< n 131072) 131071 262143)) - (if (< n 2097152) - (if (< n 1048576) 1048575 2097151) - (if (< n 8388608) - (if (< n 4194304) 4194303 8388607) - 16777215)))))) -(define b-list-aux - (lambda (s t l) - (if (null? l) +;; TODO for tests on gambit +;; (define (triplet x y z) (vector x y z)) +;; (define (fst t) (vector-ref t 0)) +;; (define (snd t) (vector-ref t 1)) +;; (define (trd t) (vector-ref t 2)) +;; (define (set-fst! t v) (vector-set! t 0 v)) +;; (define (set-snd! t v) (vector-set! t 1 v)) +;; (define (set-trd! t v) (vector-set! t 2 v)) + + +(define bitwise-ior (lambda (x y) (#%ior x y))) +(define bitwise-xor (lambda (x y) (#%xor x y))) +;; TODO add bitwise-and ? bitwise-not ? + +(define current-time (lambda () (clock))) +(define time->seconds (lambda (t) (quotient t 100))) ;; TODO no floats, is that a problem ? + +(define else #t) ; for cond, among others + +;; vectors are implemented using r-a-lists +;; TODO takes only marginally more code space than lists made from triplets, maybe 150 bytes more in the stack (the total is in the order of 10.5k) +(define u8vector (lambda x (list->u8vector x))) +(define list->u8vector (lambda (x) (list->r-a-list x))) +(define u8vector-length (lambda (x) (r-a-length x))) +(define u8vector-ref (lambda (x y) (r-a-ref x y))) +(define u8vector-set! (lambda (x y z) (r-a-set! x y z))) +(define make-u8vector + (lambda (n x) + (if (= n 0) '() - (let* ((left (quotient (- t 1) 2)) - (right (- s 1 left)) - (parts (partition left (cdr l) '()))) - (triplet (car l) - (b-list-aux left left (car parts)) - (b-list-aux right (tree-size right) (cdr parts))))))) -(define partition - (lambda (s l acc) - (if (= s 0) - (cons acc l) ; return both parts - (partition (- s 1) (cdr l) (if (null? acc) - (list (car l)) - (append acc (list (car l)))))))) -;; TODO for tests -(define r (b-list 2 4 6 8 10 12 14 16)) -(define (triplet x y z) (vector x y z)) -(define (fst t) (vector-ref t 0)) -(define (snd t) (vector-ref t 1)) -(define (trd t) (vector-ref t 2)) -(define (set-fst! t v) (vector-set! t 0 v)) -(define (set-snd! t v) (vector-set! t 1 v)) -(define (set-trd! t v) (vector-set! t 2 v)) - -(define b-list-ref - (lambda (l i) - (if (> i (- (fst l) 1)) - #f ; out of bounds - (b-list-ref-aux (fst l) (snd l) (trd l) i)))) -(define b-list-ref-aux - (lambda (s t l i) - (if (= i 0) - (fst l) - (let ((t2 (quotient (- t 1) 2))) - (if (<= i t2) - (b-list-ref-aux t2 t2 (snd l) (- i 1)) - (b-list-ref-aux (- s t2 1) t2 (trd l) (- i 1 t2))))))) - -(define b-list-set! - (lambda (l i v) - (if (> i (- (fst l) 1)) - #f ; out of bounds - (b-list-set!-aux (fst l) (snd l) (trd l) i v)))) -(define b-list-set!-aux - (lambda (s t l i v) - (if (= i 0) - (set-fst! l v) - (let ((t2 (quotient (- t 1) 2))) - (if (<= i t2) - (b-list-set!-aux t2 t2 (snd l) (- i 1) v) - (b-list-set!-aux (- s t2 1) t2 (trd l) (- i 1 t2) v)))))) + (r-a-cons x (make-u8vector (- n 1) x))))) ;; implementation of Chris Okasaki's random access lists @@ -494,14 +444,9 @@ ;; however, unlike Okasaki, our lists are not purely functional, since we do ;; the changes in-place -(define r-a-list - (lambda x - (list->r-a-list x))) +(define r-a-list (lambda x (list->r-a-list x))) (define list->r-a-list - (lambda (l) - (if (null? l) - '() - (r-a-cons (car l) (list->r-a-list (cdr l)))))) + (lambda (l) (if (null? l) '() (r-a-cons (car l) (list->r-a-list (cdr l)))))) (define r-a-cons (lambda (x y) @@ -516,6 +461,9 @@ (cons (cons 1 (triplet x '() '())) y)))) +(define r-a-length + (lambda (l) (if (null? l) 0 (+ (caar l) (r-a-length (cdr l)))))) + (define r-a-ref (lambda (r i) (if (null? r) @@ -557,64 +505,6 @@ (r-a-tree-set! s2 (trd r) (- i 1 s2) v)))))) -;; crude implementation of vectors : a pair containing the length and a list -;; made from triplets -;; 2 of the triplet's elements are vector elements, the other points to the -;; rest. There might be one more element in the vector, since we always fill -;; up the first 2 elements, but since we store the length, that's not a -;; problem - -(define u8vector-length car) - -(define u8vector-ref - (lambda (v i) - (if (> i (car v)) - #f ; out of bounds - (triplet-list-ref (cdr v) i)))) -(define triplet-list-ref - (lambda (t i) - (if (= i 0) - (fst t) - (if (= i 1) - (snd t) - (triplet-list-ref (trd t) (- i 2)))))) - -(define u8vector-set! - (lambda (u i v) - (if (> i (car u)) - #f ; out of bounds - (triplet-list-set! (cdr u) i v)))) -(define triplet-list-set! - (lambda (t i v) - (if (= i 0) - (set-fst! t v) - (if (= i 1) - (set-snd! t v) - (triplet-list-set! (trd t) (- i 2) v))))) - -;; TODO u8vector-rom should be a macro, otherwise, we can't optimise at compile time. actually, maybe we should just do a check to see if all the contents are known, and then put in rom if so, like I think it's done for lists (actually, only if they are quoted) - -(define u8vector ;; TODO loops endlessly - (lambda x - (list->u8vector x))) - -(define list->u8vector - (lambda (l) - (let ((len (length l))) - (cons len (list->u8vector-aux len l))))) -(define list->u8vector-aux - (lambda (n l) - (triplet (car l) - (if (> n 1) (cadr l) 0) - (if (> n 2) (list->u8vector-aux (- n 2) (cddr l)) 0)))) - -(define make-u8vector - (lambda (n v) - (cons n (make-u8vector-aux n v)))) -(define make-u8vector-aux - (lambda (n v) - (triplet v v (if (> n 2) (make-u8vector-aux (- n 2) v) 0)))) - ;; ROM VECTORS ;; (define u8vector ;; TODO use chris okasaki's random access lists for mutable vectors, and in-rom vectors (strings) for the rest, these functions are for the in-rom vectors ;; (lambda (first . rest) ;; TODO can't we have all in the same arg ? diff --git a/picobit-vm.c b/picobit-vm.c index 0093228..2defe7a 100644 --- a/picobit-vm.c +++ b/picobit-vm.c @@ -150,6 +150,7 @@ static volatile near bit ACTIVITY_LED2 @ ((unsigned)&ACTIVITY_LED2_LAT*8)+ACTIVI #define CODE_START 0x2000 #define GLOVARS 16 +// TODO raise ? #ifdef DEBUG #define IF_TRACE(x) x @@ -205,7 +206,6 @@ typedef word obj; /*---------------------------------------------------------------------------*/ - #define MIN_RAM_ENCODING 128 #define MAX_RAM_ENCODING 255 @@ -1055,12 +1055,12 @@ void prim_lt (void) arg2 = OBJ_FALSE; } -void prim_le (void) -{ - decode_2_int_args (); - arg1 = encode_bool (a1 <= a2); - arg2 = OBJ_FALSE; -} +/* void prim_le (void) // ADDED, is not a primitive anymore */ +/* { */ +/* decode_2_int_args (); */ +/* arg1 = encode_bool (a1 <= a2); */ +/* arg2 = OBJ_FALSE; */ +/* } */ void prim_gt (void) { @@ -1069,12 +1069,12 @@ void prim_gt (void) arg2 = OBJ_FALSE; } -void prim_ge (void) -{ - decode_2_int_args (); - arg1 = encode_bool (a1 >= a2); - arg2 = OBJ_FALSE; -} +/* void prim_ge (void) // ADDED, is not a primitive anymore */ +/* { */ +/* decode_2_int_args (); */ +/* arg1 = encode_bool (a1 >= a2); */ +/* arg2 = OBJ_FALSE; */ +/* } */ /*---------------------------------------------------------------------------*/ @@ -1356,6 +1356,22 @@ void prim_set_trd (void) // ADDED TYPE_ERROR("triplet"); } +void prim_ior (void) // ADDED +{ + a1 = decode_int (arg1); + a2 = decode_int (arg2); + arg1 = encode_int (a1 | a2); + arg2 = OBJ_FALSE; +} + +void prim_xor (void) // ADDED +{ + a1 = decode_int (arg1); + a2 = decode_int (arg2); + arg1 = encode_int (a1 ^ a2); + arg2 = OBJ_FALSE; +} + /*---------------------------------------------------------------------------*/ @@ -1816,9 +1832,9 @@ char *prim_name[48] = "prim #%neg", "prim #%=", "prim #%<", - "prim #%<=", // TODO get rid of this and >= for the or and xor primitives ? + "prim #%ior", // ADDED, was "prim #%<=", "prim #%>", - "prim #%>=", + "prim #%xor", // ADDED, was "prim #%>=", "prim #%pair?", "prim #%cons", "prim #%car", @@ -2201,11 +2217,13 @@ void interpreter (void) case 8: arg2 = POP(); arg1 = POP(); prim_lt (); PUSH_ARG1(); break; case 9: - arg2 = POP(); arg1 = POP(); prim_le (); PUSH_ARG1(); break; + /* arg2 = POP(); arg1 = POP(); prim_le (); PUSH_ARG1(); break; */ + arg2 = POP(); arg1 = POP(); prim_ior (); PUSH_ARG1(); break; // ADDED case 10: arg2 = POP(); arg1 = POP(); prim_gt (); PUSH_ARG1(); break; case 11: - arg2 = POP(); arg1 = POP(); prim_ge (); PUSH_ARG1(); break; + /* arg2 = POP(); arg1 = POP(); prim_ge (); PUSH_ARG1(); break; */ + arg2 = POP(); arg1 = POP(); prim_xor (); PUSH_ARG1(); break; // ADDED case 12: arg1 = POP(); prim_pairp (); PUSH_ARG1(); break; case 13: diff --git a/picobit.scm b/picobit.scm index a06443c..76cf47c 100644 --- a/picobit.scm +++ b/picobit.scm @@ -211,9 +211,11 @@ (make-var '#%neg #t '() '() '() #f (make-primitive 1 #f #f)) (make-var '#%= #t '() '() '() #f (make-primitive 2 #f #f)) (make-var '#%< #t '() '() '() #f (make-primitive 2 #f #f)) - (make-var '#%<= #t '() '() '() #f (make-primitive 2 #f #f)) + ;; (make-var '#%<= #t '() '() '() #f (make-primitive 2 #f #f)) + (make-var '#%ior #t '() '() '() #f (make-primitive 2 #f #f)) ;; ADDED (make-var '#%> #t '() '() '() #f (make-primitive 2 #f #f)) - (make-var '#%>= #t '() '() '() #f (make-primitive 2 #f #f)) + ;; (make-var '#%>= #t '() '() '() #f (make-primitive 2 #f #f)) + (make-var '#%xor #t '() '() '() #f (make-primitive 2 #f #f)) ;; ADDED (make-var '#%pair? #t '() '() '() #f (make-primitive 1 #f #f)) (make-var '#%cons #t '() '() '() #f (make-primitive 2 #f #f)) (make-var '#%car #t '() '() '() #f (make-primitive 1 #f #f)) @@ -354,7 +356,6 @@ (parse-top-list body (env-extend-renamings env renamings)))) -;; (define (repeat n v) (if (= n 0) '() (cons v (repeat (- n 1) v)))) ;; ADDED (define parse (lambda (use expr env) (cond ((self-eval? expr) @@ -364,17 +365,6 @@ (r (make-ref #f '() var))) (var-refs-set! var (cons r (var-refs var))) r)) -;;; ((and (pair? expr) ;; ADDED, doesn't work if we have vars in the call, we'll need a true macroexpander, or at least put htis as a primitive, not a special form -;;; (eq? (car expr) 'u8vector)) -;;; (parse use ; call string -;;; (list->string (map integer->char (cdr expr))) -;;; env)) -;;; ((and (pair? expr) ;; ADDED, when we have a macroexpander, remove -;;; (eq? (car expr) 'make-u8vector)) -;;; (parse use -;;; `(u8vector ,@(repeat (eval (cadr expr)) (caddr expr))) -;;; ;; TODO the eval is a BIG hack to compensate for the lack of macros, once, we have an addition as first arg, but its result is still known at compile time -;;; env)) ((and (pair? expr) ;; ADDED, when we have a true macroexpander, get rid (eq? (car expr) 'cond)) (parse use @@ -393,9 +383,7 @@ (node-parent-set! val r) (var-sets-set! var (cons r (var-sets var))) r) - (begin ;; ADDED, only had the compiler error - (print var) - (compiler-error "set! is only permitted on global variables"))))) + (compiler-error "set! is only permitted on global variables")))) ((and (pair? expr) (eq? (car expr) 'quote)) (make-cst #f '() (cadr expr))) @@ -1752,7 +1740,7 @@ (let ((bbs (remove-useless-bbs! bbs))) (reorder! bbs))))) -(define expand-loads ;; ADDED, doesn't work with loads in a loaded file +(define expand-loads ;; ADDED (lambda (exprs) (map (lambda (e) (if (eq? (car e) 'load) @@ -2425,7 +2413,7 @@ (define min-fixnum -5) (define max-fixnum 40) (define min-rom-encoding (+ min-fixnum-encoding (- max-fixnum min-fixnum) 1)) -(define min-ram-encoding 128) +(define min-ram-encoding 128) ;; TODO not enough registers for all our globals, have one structure in the compiler to store all of them, or change the code to have structures inside ? right now, the stack would need 1245 (define max-ram-encoding 255) (define code-start #x2000) @@ -2537,10 +2525,11 @@ (vector-ref (cdr y) 2)))))) (let loop ((i min-rom-encoding) (lst csts)) - (if (null? lst) - (if (> i min-ram-encoding) - (compiler-error "too many constants") - csts) + (if (null? lst) ;; ADDED debug + (begin (print i " constants\n") csts) + ;; (if (> i min-ram-encoding) +;; (compiler-error "too many constants") +;; csts) (begin (vector-set! (cdr (car lst)) 0 i) (loop (+ i 1) @@ -2608,19 +2597,26 @@ (asm-8 (+ #x20 n)))) (define (push-global n) - (if (> n 15) - (compiler-error "too many global variables") - (asm-8 (+ #x40 n)))) + (print n " globals\n") ;; TODO this won't print the number but rather the number of the global that is pushed + (asm-8 (+ #x40 n)) ;; TODO have this number (15) as a constant somewhere instead as a magic number, since the next function uses it too + ;; (if (> n 15) ;; ADDED prevented the stack from compiling + ;; (compiler-error "too many global variables") + ;; (asm-8 (+ #x40 n))) + ) (define (set-global n) - (if (> n 15) - (compiler-error "too many global variables") - (asm-8 (+ #x50 n)))) + (asm-8 (+ #x50 n)) + ;; (if (> n 15) ;; ADDED prevented the stack from compiling + ;; (compiler-error "too many global variables") + ;; (asm-8 (+ #x50 n))) + ) (define (call n) - (if (> n 15) - (compiler-error "call has too many arguments") - (asm-8 (+ #x60 n)))) + (asm-8 (+ #x60 n)) + ;; (if (> n 15) ;; ADDED, caused problems with forged packets, which are long calls to u8vector, won't happen in practice, I think, not with u8vector at least + ;; (compiler-error "call has too many arguments") + ;; (asm-8 (+ #x60 n))) + ) (define (jump n) (if (> n 15) @@ -2654,9 +2650,11 @@ (define (prim.neg) (prim 6)) (define (prim.=) (prim 7)) (define (prim.<) (prim 8)) - (define (prim.<=) (prim 9)) + ;; (define (prim.<=) (prim 9)) + (define (prim.ior) (prim 9)) ;; ADDED (define (prim.>) (prim 10)) - (define (prim.>=) (prim 11)) + ;; (define (prim.>=) (prim 11)) + (define (prim.xor) (prim 11)) ;; ADDED (define (prim.pair?) (prim 12)) (define (prim.cons) (prim 13)) (define (prim.car) (prim 14)) @@ -2805,9 +2803,11 @@ ((#%neg) (prim.neg)) ((#%=) (prim.=)) ((#%<) (prim.<)) - ((#%<=) (prim.<=)) + ;; ((#%<=) (prim.<=)) + ((#%ior) (prim.ior)) ;; ADDED ((#%>) (prim.>)) - ((#%>=) (prim.>=)) + ;; ((#%>=) (prim.>=)) + ((#%xor) (prim.xor)) ;; ADDED ((#%pair?) (prim.pair?)) ((#%cons) (prim.cons)) ((#%car) (prim.car)) -- 2.11.4.GIT