From b11f158fcabac6d094a9e4cec61eff45135ca5e7 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Wed, 23 Jul 2008 17:16:16 -0400 Subject: [PATCH] Optimized the library a bit by calling primitives directly instead of wrappers. --- library.scm | 105 ++++++++++++++++++++++++++++++++++------------------------- picobit-vm.c | 2 +- picobit.scm | 2 +- 3 files changed, 62 insertions(+), 47 deletions(-) diff --git a/library.scm b/library.scm index ab6bc5c..38fe8c1 100644 --- a/library.scm +++ b/library.scm @@ -58,7 +58,7 @@ (define <= (lambda (x y) - (or (< x y) (= x y)))) + (or (#%< x y) (#%= x y)))) (define > (lambda (x y) @@ -66,7 +66,7 @@ (define >= (lambda (x y) - (or (> x y) (= x y)))) + (or (#%> x y) (#%= x y)))) (define pair? (lambda (x) @@ -114,7 +114,7 @@ (define #%length-aux (lambda (lst n) (if (#%pair? lst) - (#%length-aux (cdr lst) (#%+ n 1)) ;; TODO had an error and looped + (#%length-aux (cdr lst) (#%+ n 1)) n))) (define append @@ -196,7 +196,7 @@ (define #%substring-aux2 (lambda (lst n) - (if (>= n 1) ;; TODO had an off-by-one + (if (>= n 1) (#%cons (#%car lst) (#%substring-aux2 (#%cdr lst) (#%- n 1))) '()))) @@ -273,10 +273,6 @@ (lambda (sensor) (#%adc sensor))) -;; (define dac -;; (lambda (level) -;; (#%dac level))) ;; gone - (define sernum (lambda () (#%sernum))) @@ -378,39 +374,72 @@ (define caar (lambda (p) - (car (car p)))) + (#%car (#%car p)))) (define cadr (lambda (p) - (car (cdr p)))) + (#%car (#%cdr p)))) (define cdar (lambda (p) - (cdr (car p)))) -(define cddr ;; TODO implement all of them up to 4 chars ? + (#%cdr (#%car p)))) +(define cddr (lambda (p) - (cdr (cdr p)))) + (#%cdr (#%cdr p)))) +(define caaar + (lambda (p) + (#%car (#%car (#%car p))))) (define caadr (lambda (p) - (car (car (cdr p))))) + (#%car (#%car (#%cdr p))))) +(define cadar + (lambda (p) + (#%car (#%cdr (#%car p))))) +(define caddr + (lambda (p) + (#%car (#%cdr (#%cdr p))))) +(define cdaar + (lambda (p) + (#%cdr (#%car (#%car p))))) (define cdadr (lambda (p) - (cdr (car (cdr p))))) + (#%cdr (#%car (#%cdr p))))) +(define cddar + (lambda (p) + (#%cdr (#%cdr (#%car p))))) +(define cdddr + (lambda (p) + (#%cdr (#%cdr (#%cdr p))))) (define equal? - (lambda (x y) ;; TODO rewrite once we have cond, also add vectors - (if (eq? x y) + (lambda (x y) ;; TODO rewrite once we have cond, also add vectors, actually, we do have cond, but I don't really trust it + (if (#%eq? x y) + #t + (if (and (#%pair? x) (#%pair? y)) + (and (equal? (#%car x) (#%car y)) + (equal? (#%cdr x) (#%cdr y))) + (if (and (#%u8vector? x) (#%u8vector? y)) + (u8vector-equal? x y) + #f))))) ;; TODO could this have a problem ? + +(define u8vector-equal? + (lambda (x y) + (let ((lx (#%u8vector-length x))) + (if (#%= lx (#%u8vector-length y)) + (u8vector-equal?-loop x y lx) + #f)))) +(define u8vector-equal?-loop + (lambda (x y l) + (if (#%= l 0) #t - (if (and (pair? x) (pair? y)) - (and (equal? (car x) (car y)) - (equal? (cdr x) (cdr y))) - #f)))) ;; TODO could this have a problem ? + (and (#%= (#%u8vector-ref x l) (#%u8vector-ref y l)) + (u8vector-equal?-loop x y (#%- l 1)))))) ;; TODO test this (define assoc (lambda (t l) ;; TODO rewrite once we have cond - (if (null? l) + (if (#%null? l) #f (if (equal? t (caar l)) - (car l) - (assoc t (cdr l)))))) + (#%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) @@ -421,8 +450,8 @@ (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 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 @@ -437,8 +466,9 @@ v))) (define list->u8vector-loop (lambda (v n x) - (u8vector-set! v n (car x)) - (if (not (null? (cdr x))) (list->u8vector-loop v (+ n 1) (cdr x))))) + (#%u8vector-set! v n (#%car x)) + (if (#%not (#%null? (#%cdr x))) + (list->u8vector-loop v (#%+ n 1) (#%cdr x))))) (define u8vector-length (lambda (x) (#%u8vector-length x))) (define u8vector-ref (lambda (x y) (#%u8vector-ref x y))) (define u8vector-set! (lambda (x y z) (#%u8vector-set! x y z))) @@ -447,20 +477,5 @@ (make-u8vector-loop (#%make-u8vector n) n x))) (define make-u8vector-loop (lambda (v n x) - (u8vector-set! v n x) - (if (> n 0) (make-u8vector-loop v (- n 1) x)))) - - -;; ROM VECTORS -;; TODO make sure constant vectors end up in rom -;; (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 ? -;; (list->u8vector (cons first rest)))) -;; ;; TODO maybe still use the parser hack for the in-rom vectors, since they are known at compile time (but some might have variables inside instead of only numbers, would not work then) - -;; (define u8vector-ref -;; (lambda (u8 i) -;; (#%car (#%substring-aux1 (#%string->list u8) i)))) -;; ;; TODO yuck, this is O(n), do better, since we have contiguous memory for in-rom vectors, but not that important since these rom vectors are all small - -(define print display) ;; TODO watch out for differences between the 2 + (#%u8vector-set! v n x) + (if (#%> n 0) (make-u8vector-loop v (#%- n 1) x)))) diff --git a/picobit-vm.c b/picobit-vm.c index 8b782c8..c97043a 100644 --- a/picobit-vm.c +++ b/picobit-vm.c @@ -2562,7 +2562,7 @@ void interpreter (void) arg1 = POP(); prim_u8vector_length (); PUSH_ARG1(); break; case 12: /* push-constant [long] */ - FETCH_NEXT_BYTECODE(); + FETCH_NEXT_BYTECODE(); // TODO BREGG this is a test, the compiler only knows what's in rom or lower, so we only need a byte, unless we change the number of rom addresses OOPS, 8 bits is not enough even for fixnums, we'd probably be ok with 12, though (actually 9, but that's harder to have and 12 gives us more room should we increase the number of rom addresses) arg2 = bytecode; FETCH_NEXT_BYTECODE(); arg1 = (arg2 << 8) | bytecode; diff --git a/picobit.scm b/picobit.scm index 9a14eb2..1eec8d5 100644 --- a/picobit.scm +++ b/picobit.scm @@ -2604,7 +2604,7 @@ (asm-8 (+ #x00 n)) (begin (asm-8 #xfc) - (asm-8 (quotient n 256)) + (asm-8 (quotient n 256)) ;; BREGG this is a test, the compiler cannot know about anything over 256 (as long as no rom goes higher, which might change, watch out for this), so no need for 13 bits OOPS, actually, 8 is not enough for fixnums and rom, revert to 12 and use some of the free instrs ? (asm-8 (modulo n 256))))) ;; TODO with 13-bit objects, we need 2 bytes, maybe limit to 12, so we could use a byte and a half, but we'd need to use an opcode with only 4 bits, maybe the call/jump stuff can be combined ? FOOBAR (define (push-stack n) -- 2.11.4.GIT