From 02b6643395029c6c536ba8e0271945f306057a39 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Mon, 20 Apr 2009 15:30:14 -0400 Subject: [PATCH] Changed the type system to have implicit casts (promotion by padding (which works only for signed values) and truncation). Type system is now much simpler, but does not do much verifications. Added 16 x 16 bit multiplication. Changed the condition system to support tests on multi-byte values properly. Has not been thoroughly tested yet, though. --- ast.scm | 35 +++++++++++++++-------- cfg.scm | 91 +++++++++++++++++++++++++++++++++++++++++++---------------- cte.scm | 7 ++--- operators.scm | 61 +++++++++++++-------------------------- six-comp.scm | 1 + 5 files changed, 113 insertions(+), 82 deletions(-) diff --git a/ast.scm b/ast.scm index bb1d785..5849700 100644 --- a/ast.scm +++ b/ast.scm @@ -56,19 +56,30 @@ (define (new-byte-lit x) (make-byte-lit x)) -(define (nb-bytes type) - (case type - ((void) 0) - ((byte) 1) - ((int8) 1) - ((int16) 2) - ((int24) 3) - ((int32) 4) - ((int) 4) ;; TODO should the default int be 32 bits ? - (else (error "wrong number of bytes ?")))) +(define types-bytes + '((void . 0) + (byte . 1) + (int8 . 1) + (int16 . 2) + (int24 . 3) + (int32 . 4) ;; TODO should the default int be 32 bits ? + (int . 4))) + +(define (type->bytes type) + (cond ((assq type types-bytes) + => (lambda (x) (cdr x))) + (else (error "wrong number of bytes ?")))) + +(define (bytes->type n) + (let loop ((l types-bytes)) + (cond ((null? l) (error (string-append "no type contains " + (number->string n) + " bytes"))) + ((= n (cdar l)) (caar l)) + (else (loop (cdr l)))))) (define (int->value n type) - (let ((len (nb-bytes type))) + (let ((len (type->bytes type))) (let loop ((len len) (n n) (rev-bytes '())) (if (= len 0) (new-value (reverse rev-bytes)) @@ -81,7 +92,7 @@ value);;;;;;;;;;;;;;;;;;;;; (define (alloc-value type) - (let ((len (nb-bytes type))) + (let ((len (type->bytes type))) (let loop ((len len) (rev-bytes '())) (if (= len 0) (new-value (reverse rev-bytes)) ;; TODO why reverse, everything is empty diff --git a/cfg.scm b/cfg.scm index e6f7b37..fee102e 100644 --- a/cfg.scm +++ b/cfg.scm @@ -194,7 +194,7 @@ (define (move-value from to) (let loop ((from (value-bytes from)) (to (value-bytes to))) - (cond ((null? to)) ; done + (cond ((null? to)) ; done, we truncate the rest ((null? from) ; promote the value by padding (move (new-byte-lit 0) (car to)) (loop from (cdr to))) @@ -388,18 +388,27 @@ (emit (new-instr id byte1 byte2 #f))))) ;; TODO doesn't change from if we had literals, at least not now (define (test-value id value1 value2 bb-true bb-false) - ;; note: for multi-byte values, only x==y works properly TODO fix it, will depend on byte order, is car the lsb or msb ? - (let loop ((bytes1 (value-bytes value1)) - (bytes2 (value-bytes value2))) - ;; TODO won't work with values of different widths - (let ((byte1 (car bytes1)) - (byte2 (car bytes2))) ;; TODO FAILS HERE if value2 is shorter than value1 BAD - (if (null? (cdr bytes1)) - (test-byte id byte1 byte2 bb-true bb-false) - (let ((bb-true2 (new-bb))) - (test-byte id byte1 byte2 bb-true2 bb-false) - (in bb-true2) - (loop (cdr bytes1) (cdr bytes2))))))) + (let loop ((bytes1 (value-bytes value1)) ; lsb first + (bytes2 (value-bytes value2)) + (padded1 '()) + (padded2 '())) + (if (not (and (null? bytes1) (null? bytes2))) + ;; note: won't work with signed types, as the padding is done + ;; with 0s only + (let ((byte1 (if (null? bytes1) (new-byte-lit 0) (car bytes1))) + (byte2 (if (null? bytes2) (new-byte-lit 0) (car bytes2)))) + (loop (cdr bytes1) (cdr bytes2) + (cons byte1 padded1) (cons byte2 padded2))) + ;; now so the test itself, using the padded values + ;; the comparisons are done msb-first, for < and > + (let loop2 ((bytes1 padded1) ; msb first + (bytes2 padded2)) + (if (null? (cdr bytes1)) ;; TODO TEST IT + (test-byte id byte1 byte2 bb-true bb-false) + (let ((bb-true2 (new-bb))) + (test-byte id byte1 byte2 bb-true2 bb-false) + (in bb-true2) + (loop (cdr bytes1) (cdr bytes2)))))))) (define (test-relation id x y bb-true bb-false) (cond ((and (literal? x) (not (literal? y))) ; literals must be in the last argument for code generation @@ -742,22 +751,56 @@ (move (get-register PRODH) (cadr z)))) ((mul16_8) - (let* ((x (car params)) ;; TODO make sure endianness is ok - (x0 (car (get-bytes x))) ; lsb - (x1 (cadr (get-bytes x))) - (y (cadr params)) - (y0 (car (get-bytes y))) + (let* ((x (get-bytes (car params))) ;; TODO make sure endianness is ok + (x0 (car x)) ; lsb + (x1 (cadr x)) + (y (get-bytes (cadr params))) + (y0 (car y)) (z (value-bytes value)) - (z2 (car z)) ; lsb + (z0 (car z)) ; lsb (z1 (cadr z)) - (z0 (caddr z))) + (z2 (caddr z))) (emit (new-instr 'mul y0 x1 #f)) - (move (get-register PRODH) z1) - (move (get-register PRODL) z2) + (move (get-register PRODH) z2) + (move (get-register PRODL) z1) + (emit (new-instr 'mul y0 x0 #f)) - (move (get-register PRODH) z0) + (move (get-register PRODL) z0) + (emit (new-instr 'add (get-register PRODH) z1 z1)) + (emit (new-instr 'addc z2 (new-byte-lit 0) z2)))) + + ((mul16_16) + (let* ((x (get-bytes (car params))) + (x0 (car x)) + (x1 (cadr x)) + (y (get-bytes (cadr params))) + (y0 (car y)) + (y1 (cadr y)) + (z (value-bytes value)) + (z0 (car z)) + (z1 (cadr z)) + (z2 (caddr z)) + (z3 (cadddr z))) + + (emit (new-instr 'mul x1 y1 #f)) + (move (get-register PRODH) z3) + (move (get-register PRODL) z2) + + (emit (new-instr 'mul x0 y0 #f)) + (move (get-register PRODH) z1) + (move (get-register PRODL) z0) + + (emit (new-instr 'mul x0 y1 #f)) + (emit (new-instr 'add (get-register PRODL) z1 z1)) + (emit (new-instr 'addc (get-register PRODH) z2 z2)) + (emit (new-instr 'addc z3 (new-byte-lit 0) z3)) + + (emit (new-instr 'mul x1 y0 #f)) (emit (new-instr 'add (get-register PRODL) z1 z1)) - (emit (new-instr 'addc z0 (new-byte-lit 0) z0))))) + (emit (new-instr 'addc (get-register PRODH) z2 z2)) + (emit (new-instr 'addc z3 (new-byte-lit 0) z3)))) + ;; TODO have 16-32 and 32-32 ? needed for picobit ? + ) ;; TODO alloc-value if intermediary results are needed, wouldn't be as optimal as directly adding prodl and prodh to the right register, but makes it more generic, maybe register allocation could fix this suboptimality ? (actually, for the moment, we play with the PROD registers right here, so it's not that subobtimal) (return-with-no-new-bb proc) (set! current-def-proc #f) diff --git a/cte.scm b/cte.scm index 716b489..fd3736f 100644 --- a/cte.scm +++ b/cte.scm @@ -80,10 +80,9 @@ ;; TODO maybe use some for the fsr variables ? and have the address be the fsr registers ;; for multiplication - ;; TODO do others - (predefine-routine 'mul8_8 'int16 '(byte byte)) - (predefine-routine 'mul16_8 'int24 '(int16 byte)) - + (predefine-routine 'mul8_8 'int16 '(byte byte)) + (predefine-routine 'mul16_8 'int24 '(int16 byte)) + (predefine-routine 'mul16_16 'int32 '(int16 int16)) ;; TODO maybe use predefine fun and have jump to a function already in rom ? then have some kind of linking to see if it's used, and if so, put the code in )) diff --git a/operators.scm b/operators.scm index 0b9687f..7324643 100644 --- a/operators.scm +++ b/operators.scm @@ -1,18 +1,5 @@ ;;; operators -(define (castable? from to) - (if (eq? from to) - #t ; base case - (case to - ((int) - (foldl (lambda (x y) (or x (castable? from y))) - #f - '(byte int8 int16 int32))) - ((bool) - (eq? from 'int)) - ;; TODO ajouter casts vers byte, int16, etc, probably not needed since operations are done on ints, and useless operations (on bytes that would not exist) are optimized away - (else #f)))) - (define operators '()) (define (define-op1 six-id id type-rule constant-fold code-gen) @@ -25,15 +12,15 @@ (cons (make-op2 six-id id type-rule constant-fold code-gen) operators))) +;; no need for type checks, every type sixpic supports can be casted to / from +;; ints (except void, but this is a non-issue) and promotion (by padding) and +;; truncation is done at the cfg level +;; TODO really ignore the void issue ? assigning the "result" of a void function to an int variable should be an error (define (type-rule-int-op1 ast) - (let ((t1 (expr-type (subast1 ast)))) - (cond ((castable? t1 'int) - 'int) - (else - (error "int-op1: type error" ast))))) + (expr-type (subast1 ast))) (define (largest t1 t2) - (let loop ((l '(int int32 int16 int8 byte))) + (let loop ((l '(int int32 int16 int8 byte))) ;; TODO FOO, use the functions type->bytes and bytes->type instead (if (null? l) (error "largest: unknown type") (let ((head (car l))) @@ -45,37 +32,23 @@ (define (type-rule-int-op2 ast) (let ((t1 (expr-type (subast1 ast))) (t2 (expr-type (subast2 ast)))) - (cond ((and (castable? t1 'int) (castable? t2 'int)) - (largest t1 t2)) - (else - (error "int-op2: type error" ast))))) + (largest t1 t2))) (define (type-rule-int-assign ast) ;; TODO why the int in the name ? - (let ((t1 (expr-type (subast1 ast))) - (t2 (expr-type (subast2 ast)))) - (if (not (castable? t2 t1)) ; the rhs must fit in the lhs - (error "int-assign: type error" ast)) + (let ((t1 (expr-type (subast1 ast)))) + ;; the type of the rhs is irrelevant, since it will be promoted + ;; or truncated at the cfg level t1)) (define (type-rule-int-comp-op2 ast) - (let ((t1 (expr-type (subast1 ast))) - (t2 (expr-type (subast2 ast)))) - (cond ((and (castable? t1 'int) (castable? t2 'int)) - 'bool) - (else - (error "int-comp-op2: type error" ast))))) + 'bool) ;; TODO why even bother ? anything can be casted to int to be used as argument here, old version is in garbage (and in version control) if needed (define (type-rule-bool-op2 ast) - (let ((t1 (expr-type (subast1 ast))) - (t2 (expr-type (subast2 ast)))) - (cond ((and (castable? t1 'bool) (castable? t2 'bool)) - 'bool) - (else - (error "bool-op2: type error" ast))))) + 'bool) ;; TODO same here (define-op1 'six.!x '!x type-rule-int-op1 - (lambda (ast) ;; TODO implement these + (lambda (ast) ;; TODO implement these ? ast) (lambda (ast) ...)) @@ -123,7 +96,11 @@ ...)) (define-op2 'six.x*y 'x*y - type-rule-int-op2 + ;; products can be as wide as the sum of the widths of the operands + (lambda (ast) + (let ((l1 (type->bytes (expr-type (subast1 ast)))) + (l2 (type->bytes (expr-type (subast2 ast))))) + (bytes->type (+ l1 l2)))) (lambda (ast) ast) (lambda (ast) @@ -146,7 +123,7 @@ ...)) (define-op2 'six.x/y 'x/y - type-rule-int-op2 + type-rule-int-op2 ;; TODO really ? (lambda (ast) ast) (lambda (ast) diff --git a/six-comp.scm b/six-comp.scm index 3befe4b..bf5c828 100755 --- a/six-comp.scm +++ b/six-comp.scm @@ -27,6 +27,7 @@ (float . #f) (double . #f) (obj . #f))) +;; TODO typedef should add to this list (define (read-source filename) (shell-command (string-append "cpp -P " filename " > " filename ".tmp")) -- 2.11.4.GIT