From 1b345a2a478603a9d90eb004fa9ad38c68eb6c7b Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Mon, 6 Apr 2009 00:35:34 -0400 Subject: [PATCH] Support for predefined routines has been added. Predefined routines have to be declared in the initial cte and their body must be implemented as a cfg (in the include-predefined-routines function). This was implemented to have multiplication as routines and save code space. So far, 8x8 bit (unsigned) multiplication has been implemented using this method, and seems to be working. Adding the other multiplication routines should be easy since predefined routines work. Some endianness issues might remain. More testing is in order. The simulator has also been adapted to support multiplication (and any other instruction with results that are more than 8 bits wide). --- cfg.scm | 204 ++++++++++++++++++++++++++++++++-------------------- code-generation.scm | 140 +++++++++++++++++++----------------- cte.scm | 42 ++++++++--- parser.scm | 2 +- pic18-sim.scm | 40 +++++++---- six-comp.scm | 27 +++++-- utilities.scm | 45 ++++++------ 7 files changed, 306 insertions(+), 194 deletions(-) diff --git a/cfg.scm b/cfg.scm index d29de4d..166d747 100644 --- a/cfg.scm +++ b/cfg.scm @@ -1,7 +1,7 @@ ;;; generation of control flow graph ;; special variables whose contents are located in the FSR registers -(define fsr-variables '(SIXPIC_FSR0 SIXPIC_FSR1 SIXPIC_FSR2)) +(define fsr-variables '(SIXPIC_FSR0 SIXPIC_FSR1 SIXPIC_FSR2)) ;; TODO use the predefined variables from cte.scm instead ? (define-type cfg bbs @@ -78,31 +78,22 @@ (define bb #f) ; current bb - (define (in x) - (set! bb x)) + (define (in x) (set! bb x)) - (define (new-bb) - (add-bb cfg)) + (define (new-bb) (add-bb cfg)) - (define (emit instr) - (add-instr bb instr)) + (define (emit instr) (add-instr bb instr)) (define current-def-proc #f) (define break-stack '()) (define continue-stack '()) (define delayed-post-incdec '()) - (define (push-break x) - (set! break-stack (cons x break-stack))) + (define (push-break x) (set! break-stack (cons x break-stack))) + (define (pop-break) (set! break-stack (cdr break-stack))) - (define (pop-break) - (set! break-stack (cdr break-stack))) - - (define (push-continue x) - (set! continue-stack (cons x continue-stack))) - - (define (pop-continue) - (set! continue-stack (cdr continue-stack))) + (define (push-continue x) (set! continue-stack (cons x continue-stack))) + (define (pop-continue) (set! continue-stack (cdr continue-stack))) (define (push-delayed-post-incdec x) (set! delayed-post-incdec (cons x delayed-post-incdec))) @@ -133,24 +124,23 @@ (let ((ext-value (extend value (def-variable-type ast)))) (move-value value (def-variable-value ast))))))) + ;; resolve the C gotos by setting the appropriate successor to their bb + (define (resolve-all-gotos start table visited) + (if (not (memq start visited)) + (begin (for-each (lambda (x) + (if (and (eq? (instr-id x) 'goto) + (instr-dst x)) ; unresolved label + (let ((target (assoc (instr-dst x) table))) + (if target + (begin (add-succ start (cdr target)) + (instr-dst-set! x #f)) + (error "invalid goto target" (instr-dst x)))))) + (bb-rev-instrs start)) + (for-each (lambda (x) + (resolve-all-gotos x table (cons start visited))) + (bb-succs start))))) + (define (def-procedure ast) - - ;; resolve the C gotos by setting the appropriate successor to their bb - (define (resolve-all-gotos start table visited) - (if (not (memq start visited)) - (begin (for-each (lambda (x) - (if (and (eq? (instr-id x) 'goto) - (instr-dst x)) ; unresolved label - (let ((target (assoc (instr-dst x) table))) - (if target - (begin (add-succ start (cdr target)) - (instr-dst-set! x #f)) - (error "invalid goto target" (instr-dst x)))))) - (bb-rev-instrs start)) - (for-each (lambda (x) - (resolve-all-gotos x table (cons start visited))) - (bb-succs start))))) - (let ((old-bb bb) (entry (new-bb))) (def-procedure-entry-set! ast entry) @@ -175,32 +165,20 @@ '())) (define (statement ast) - (cond ((def-variable? ast) - (def-variable ast)) - ((block? ast) - (block ast)) - ((return? ast) - (return ast)) - ((if? ast) - (if (null? (cddr (ast-subasts ast))) - (if1 ast) - (if2 ast))) - ((while? ast) - (while ast)) - ((do-while? ast) - (do-while ast)) - ((for? ast) - (for ast)) - ((switch? ast) - (switch ast)) - ((break? ast) - (break ast)) - ((continue? ast) - (continue ast)) - ((goto? ast) - (goto ast)) - (else - (expression ast)))) + (cond ((def-variable? ast) (def-variable ast)) + ((block? ast) (block ast)) + ((return? ast) (return ast)) + ((if? ast) (if (null? (cddr (ast-subasts ast))) + (if1 ast) + (if2 ast))) + ((while? ast) (while ast)) + ((do-while? ast) (do-while ast)) + ((for? ast) (for ast)) + ((switch? ast) (switch ast)) + ((break? ast) (break ast)) + ((continue? ast) (continue ast)) + ((goto? ast) (goto ast)) + (else (expression ast)))) (define (block ast) (if (block-name ast) ; named block ? @@ -216,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 ((null? from) ; promote the value by padding (move (new-byte-lit 0) (car to)) (loop from (cdr to))) @@ -319,7 +297,8 @@ (for-each (lambda (x) ; generate each case (in (new-bb)) ; this bb will be given the name of the case (add-succ decision-bb bb) - (if (null? (bb-succs prev-bb)) ; if the previous case didn't end in a break, fall through + ;; if the previous case didn't end in a break, fall through + (if (null? (bb-succs prev-bb)) (let ((curr bb)) (in prev-bb) (gen-goto curr) @@ -542,17 +521,43 @@ (cdr bytes3) #f))))) - (define (mul value1 value2 result) - ;; for now, multiplication is limited to 8 bits values. any larger - ;; values will be truncated. the result is a 16 bit value - ;; TODO implement multiplication for larger values, if necessary in PICOBIT - (emit (new-instr 'mul - (car (value-bytes value1)) - (car (value-bytes value2)))) - ;; the result goes into the PIC18 multiplication registers - (move-value (new-value (list (get-register PRODL) - (get-register PRODH))) - result)) + (define (mul x y type result) + ;; finds the appropriate multiplication routine (depending on the length + ;; of each argument) and turns the multiplication into a call to the + ;; routine + ;; the arguments must be the asts of the 2 arguments (x and y) and the + ;; type of the returned value, since these are what are expected by the + ;; call function + (let* ((lx (length (value-bytes (expression x)))) ;; TODO can't handle literals... I don't get it, see add-sub, maybe use the type to determine instead + (ly (length (value-bytes (expression y)))) ;; TODO we end up doing some work that call will also end up doing, wasteful, but I don't see another way + (op (string->symbol ; mul8_8, mul8_16, etc + (string-append "mul" ;; TODO watch out for signed / unsigned + (number->string (* lx 8)) "_" + (number->string (* ly 8))))) + ;; find the definition of the predefined routine in the initial cte + (def-proc (car (memp (lambda (x) (eq? (def-id x) op)) ;; TODO ugly + initial-cte)))) + ;; put the result of the call where the rest of the expression expects it TODO wasteful, or will register allocation coalesce these ? + (move-value (call (new-call (list x y) ;; TODO actually, take the subsasts of the arithmetic expression, instead of separately ? + type + def-proc)) + result))) + + ;; bitwise and, or, xor TODO not ? no, elsewhere since it's unary + ;; TODO similar to add-sub and probably others, abstract multi-byte operations + (define (bitwise id value1 value2 result) + (let loop ((bytes1 (value-bytes value1)) + (bytes2 (value-bytes value2)) + (bytes3 (value-bytes result))) + (if (not (null? bytes3)) + (begin (emit + (new-instr (case id ((x&y) 'and) ((|x\|y|) 'ior) ((x^y) 'xor)) + (if (null? bytes1) (new-byte-lit 0) (car bytes1)) + (if (null? bytes2) (new-byte-lit 0) (car bytes2)) + (car bytes3))) + (loop (if (null? bytes1) bytes1 (cdr bytes1)) + (if (null? bytes2) bytes2 (cdr bytes2)) + (cdr bytes3)))))) (define (do-delayed-post-incdec) (if (not (null? delayed-post-incdec)) @@ -648,7 +653,7 @@ (error "unary operation error" ast)))) (begin (case id - ((x+y x-y x*y x/y x%y) + ((x+y x-y x*y x/y x%y x&y |x\|y| x^y) (let* ((x (subast1 ast)) (y (subast2 ast))) (let* ((value-x (expression x)) @@ -660,11 +665,17 @@ (eq? id 'x-y)) (add-sub id ext-value-x ext-value-y result)) ((eq? id 'x*y) - (error "multiplication not implemented yet")) ;; TODO maybe just implement multiplication by powers of 2 + ;; the asts of x and y must be used, since mul + ;; calls call + (mul x y type result)) ((eq? id 'x/y) (error "division not implemented yet")) ;; TODO implement these ((eq? id 'x%y) - (error "modulo not implemented yet"))) + (error "modulo not implemented yet")) + ((or (eq? id 'x&y) + (eq? id '|x\|y|) + (eq? id 'x^y)) + (bitwise id ext-value-x ext-value-y result))) result))))) ((x=y) (let* ((x (subast1 ast)) @@ -695,9 +706,50 @@ (new-value (list (get-register INDF0)))) (else (error "binary operation error" ast)))))))) + + ;; generates the cfg for a predefined routine and adds it to the current cfg + (define (include-predefined-routine proc) ;; TODO put elsewhere ? + (let ((id (def-id proc)) + (params (def-procedure-params proc)) + (value (def-procedure-value proc)) + (old-bb bb) + (entry (new-bb))) ;; TODO taken from def-procedure, or something like that, abstract + (def-procedure-entry-set! proc entry) + (set! current-def-proc proc) + (in entry) + (case id + ((mul8_8) + (let ((x (car params)) + (y (cadr params)) + (z (value-bytes value))) + (define (get-cell var) + (car (value-bytes (def-variable-value var)))) ;; TODO IMPLEMENT LITERAL MULTIPLICATION IN THWE SIMULATOR + (emit (new-instr 'mul (get-cell x) (get-cell y) #f)) ;; TODO have a destination (actually 2, for the 2 parts of PROD), instead of leaving the values in PROD and moving them here + (move (get-register PRODL) (car z)) ;; TODO big or little endian ? TODO talking about PRODL/H here is an abstraction leak, pass + (move (get-register PRODH) (cadr z))))) + ;; 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) ;; TODO not sure the right value gets returned NO IT'S NOT. FOO + +;; (define (return ast) ;; TODO use this... but what I have looks the same +;; (if (null? (ast-subasts ast)) +;; (return-with-no-new-bb current-def-proc) +;; (let ((value (expression (subast1 ast)))) +;; (let ((ext-value (extend value (def-procedure-type current-def-proc)))) +;; (move-value value (def-procedure-value current-def-proc)) +;; (return-with-no-new-bb current-def-proc)))) +;; (in (new-bb))) + + (set! current-def-proc #f) + (resolve-all-gotos entry (list-named-bbs entry '()) '()) + (in old-bb))) (define (call ast) (let ((def-proc (call-def-proc ast))) + (if (and (memq (def-id def-proc) predefined-routines) + (not (def-procedure-entry def-proc))) + ;; it's the first time we encounter this predefined routine, generate + ;; the corresponding cfg + (include-predefined-routine def-proc)) (for-each (lambda (ast def-var) (let ((value (expression ast))) (let ((ext-value (extend value (def-variable-type def-var)))) diff --git a/code-generation.scm b/code-generation.scm index 4d4a374..aa89ff1 100644 --- a/code-generation.scm +++ b/code-generation.scm @@ -150,52 +150,49 @@ (define (movlw val) (emit (list 'movlw val))) - (define (movwf adr) (emit (list 'movwf adr))) - (define (movfw adr) (emit (list 'movfw adr))) - (define (movff src dst) (emit (list 'movff src dst))) (define (clrf adr) (emit (list 'clrf adr))) - (define (setf adr) (emit (list 'setf adr))) (define (incf adr) (emit (list 'incf adr))) - (define (decf adr) (emit (list 'decf adr))) (define (addwf adr) (emit (list 'addwf adr))) - (define (addwfc adr) (emit (list 'addwfc adr))) (define (subwf adr) (emit (list 'subwf adr))) - (define (subwfb adr) (emit (list 'subwfb adr))) (define (mullw adr) (emit (list 'mullw adr))) - (define (mulwf adr) (emit (list 'mulwf adr))) + + (define (andwf adr) + (emit (list 'andwf adr))) + (define (iorwf adr) + (emit (list 'iorwf adr))) + (define (xorwf adr) + (emit (list 'xorwf adr))) (define (cpfseq adr) (emit (list 'cpfseq adr))) - (define (cpfslt adr) (emit (list 'cpfslt adr))) - (define (cpfsgt adr) (emit (list 'cpfsgt adr))) @@ -272,7 +269,9 @@ (byte-cell-adr src1)) (or (not (byte-cell? src2)) (byte-cell-adr src2))) + (case (instr-id instr) + ((move) (if (byte-lit? src1) (let ((n (byte-lit-val src1)) @@ -281,6 +280,7 @@ (let ((x (byte-cell-adr src1)) (z (byte-cell-adr dst))) (move-reg x z)))) + ((add addc sub subb) (if (byte-lit? src2) (let ((n (byte-lit-val src2)) @@ -289,58 +289,68 @@ (move-lit (byte-lit-val src1) z) (move-reg (byte-cell-adr src1) z)) (case (instr-id instr) - ((add) - (cond ((= n 1) - (incf z)) - ((= n #xff) - (decf z)) - (else - (movlw n) - (addwf z)))) - ((addc) - (movlw n) - (addwfc z)) - ((sub) - (cond ((= n 1) - (decf z)) - ((= n #xff) - (incf z)) - (else - (movlw n) - (subwf z)))) - ((subb) - (movlw n) - (subwfb z)))) + ((add) (cond ((= n 1) (incf z)) + ((= n #xff) (decf z)) + (else (movlw n) + (addwf z)))) + ((addc) (movlw n) (addwfc z)) + ((sub) (cond ((= n 1) (decf z)) + ((= n #xff) (incf z)) + (else (movlw n) + (subwf z)))) + ((subb) (movlw n) (subwfb z)))) (let ((x (byte-cell-adr src1)) (y (byte-cell-adr src2)) (z (byte-cell-adr dst))) (cond ((and (not (= x y)) (= y z)) - (move-reg x WREG) - (case (instr-id instr) - ((add) - (addwf z)) - ((addc) - (addwfc z)) - ((sub) - (subwfr z)) - ((subb) - (subwfbr z)) - (else (error "...")))) + (move-reg x WREG)) (else (move-reg x z) - (move-reg y WREG) - (case (instr-id instr) - ((add) - (addwf z)) - ((addc) - (addwfc z)) - ((sub) - (subwf z)) - ((subb) - (subwfb z)) - (else (error "...")))))))) - ((mul) - TODO) ;; TODO FOO implement multiplication, choose between mullw and mulwf, no need to do shifts, I guess, since multiplications are 1 cycle + (move-reg y WREG))) + (case (instr-id instr) ;; TODO used to be in each branch of the cond, now is abstracted test to see if it still works + ((add) (addwf z)) + ((addc) (addwfc z)) + ((sub) (subwf z)) + ((subb) (subwfb z)) + (else (error "...")))))) + + ((mul) ; 8 by 8 multiplication + (if (byte-lit? src2) + (let ((n (byte-lit-val src2))) + (if (byte-lit? src1) ;; TODO will probably never be called with literals, since it's always inside a function + (movlw (byte-lit-val src1)) + (movereg (byte-cell-adr src1) WREG)) + ;; literal multiplication + (mullw n)) + (let ((x (byte-cell-adr src1)) ;; TODO how to be sure that we can't get the case of the 1st arg being a literal, but not the 2nd ? + (y (byte-cell-adr src2))) + (move-reg x WREG) + (mulwf y)))) ;; TODO seems to take the same argument twice, see test32 + + ((and ior xor) ;; TODO similar to add sub and co, except that I removed the literal part + (let ((x (if (byte-lit? src1) + (byte-lit-val src1) + (byte-cell-adr src1))) + (y (if (byte-lit? src2) + (byte-lit-val src2) + (byte-cell-adr src2))) + (z (byte-cell-adr dst))) + (cond ((byte-lit? src1) + (if (byte-lit? src2) + (move-lit y z) + (move-reg y z)) + (movlw x)) ;; TODO not sure it will work + ((and (not (= x y)) (= y z)) + (move-reg x WREG)) + (else + (move-reg x z) + (move-reg y WREG))) + (case (instr-id instr) + ((and) (andwf z)) + ((ior) (iorwf z)) + ((xor) (xorwf z)) + (else (error "..."))))) + ((goto) (let* ((succs (bb-succs bb)) (dest (car succs))) @@ -443,6 +453,12 @@ (mullw (cadr instr))) ((mulwf) (mulwf (cadr instr))) + ((andwf) + (andwf (cadr instr))) + ((iorwf) + (iorwf (cadr instr))) + ((xorwf) + (xorwf (cadr instr))) ((cpfseq) (cpfseq (cadr instr))) ((cpfslt) @@ -470,17 +486,7 @@ (let ((code (linearize-and-cleanup cfg))) ; (pretty-print code) - (for-each gen code)) - - (asm-assemble) - - '(display "------------------ GENERATED CODE\n") - - '(asm-display-listing (current-output-port)) - - (asm-write-hex-file (string-append filename ".hex")) ;; TODO move to main ? - - (asm-end!)) + (for-each gen code))) (define (code-gen filename cfg) (allocate-registers cfg) diff --git a/cte.scm b/cte.scm index d9167e0..19e8ac5 100644 --- a/cte.scm +++ b/cte.scm @@ -7,7 +7,7 @@ (define (predefine-fun id type param-defs adr) (let* ((value - (cond ((eq? type 'int) + (cond ((eq? type 'byte) ;; TODO have the others, or make this generic (this is not actually used anyway) (new-value (list (make-byte-cell WREG '() '())))) ((eq? type 'void) (new-value '())) @@ -15,6 +15,7 @@ (error "unknown return type")))) (params (map (lambda (x) + ;; parameters don't need names here (predefine-var 'foo (car x) (cdr x))) param-defs)) (ast @@ -25,10 +26,24 @@ (def-procedure-entry-set! ast entry) ast)) -(define (initial-cte) ;; TODO see what really has to be predefined - (list (predefine-var 'X 'int 5) - (predefine-var 'Y 'int 6) - (predefine-var 'Z 'int 7) +(define predefined-routines '()) + +;; as predefine-fun, but represented as bbs, not as preloaded machine code +;; the body of the procedure (as a cfg) will be generated during the generation +;; of the main cfg +(define (predefine-routine id type param-defs) + (let ((params + (map (lambda (type) ; parameters are passed like this: (type type ...) + ;; parameters don't need names here + (new-def-variable '() 'foo '() type (alloc-value type) '())) + param-defs))) + (set! predefined-routines (cons id predefined-routines)) + (new-def-procedure '() id '() type (alloc-value type) params))) + +(define initial-cte ;; TODO clean this up + (list (predefine-var 'X 'byte 5) + (predefine-var 'Y 'byte 6) + (predefine-var 'Z 'byte 7) (predefine-fun 'FLASH_execute_erase 'void '() @@ -39,7 +54,7 @@ #x1F0) (predefine-fun 'led_set 'void - (list (cons 'int WREG)) + (list (cons 'byte WREG)) #x1F2) (predefine-fun 'irda_tx_wake_up 'void @@ -47,10 +62,10 @@ #x1F4) (predefine-fun 'irda_tx_raw 'void - (list (cons 'int WREG)) + (list (cons 'byte WREG)) #x1F6) (predefine-fun 'irda_rx_raw - 'int + 'byte '() #x1F8) (predefine-fun 'sleep_mode @@ -60,7 +75,16 @@ (predefine-fun 'exec_client 'void '() - #x1FC))) + #x1FC) + + ;; TODO maybe use some for the fsr variables ? and have the address be the fsr registers + + ;; for multiplication + ;; TODO FOO do others + (predefine-routine 'mul8_8 'int16 '(byte byte)) + + ;; 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 + )) (define (cte-extend cte bindings) (append bindings cte)) diff --git a/parser.scm b/parser.scm index 6d49081..113a3a6 100644 --- a/parser.scm +++ b/parser.scm @@ -434,6 +434,6 @@ cte)))) (program source - (initial-cte) + initial-cte (lambda (ast cte) ast))) diff --git a/pic18-sim.scm b/pic18-sim.scm index 4fec43d..9d0d239 100644 --- a/pic18-sim.scm +++ b/pic18-sim.scm @@ -209,12 +209,15 @@ (loop (+ i 1))))))) (define (byte-oriented opcode mnemonic flags-changed operation) - (byte-oriented-aux opcode mnemonic flags-changed operation #f)) - + (byte-oriented-aux opcode mnemonic flags-changed operation 'wreg)) (define (byte-oriented-file opcode mnemonic flags-changed operation) - (byte-oriented-aux opcode mnemonic flags-changed operation #t)) + (byte-oriented-aux opcode mnemonic flags-changed operation 'file)) +(define (byte-oriented-wide opcode mnemonic flags-changed operation dest) + ;; for use with instructions that have results more than a byte wide, such + ;; as multiplication. the result goes at the given addresses + (byte-oriented-aux opcode mnemonic flags-changed operation dest)) ;; TODO do the same for literals -(define (byte-oriented-aux opcode mnemonic flags-changed operation file?) +(define (byte-oriented-aux opcode mnemonic flags-changed operation dest) (let* ((f (bitwise-and opcode #xff)) (adr (if (= 0 (bitwise-and opcode #x100)) (if (= 0 (bitwise-and f #x80)) f (+ f #xf00)) @@ -223,15 +226,27 @@ (display (list (last-pc) " " mnemonic " " (let ((x (assv adr file-reg-names))) (if x (cdr x) (list "0x" (number->string adr 16)))) - (if (or file? (not (= 0 (bitwise-and opcode #x200)))) - "" - ", w") + (if (or (eq? dest 'wreg) + (= 0 (bitwise-and opcode #x200))) + ", w" + "") ""))) (let* ((result (operation (get-ram adr))) (result-8bit (bitwise-and result #xff))) - (if (or file? (not (= 0 (bitwise-and opcode #x200)))) - (set-ram adr result-8bit) - (set-wreg result-8bit)) + (cond ((list? dest) + ;; result is more than a byte wide (i.e. multiplication) + ;; put it in the right destinations (dest is a list of addresses) + (let loop ((dest dest) (result result)) + (if (not (null? dest)) + ;; the head of the list is the lsb + (begin (set-ram (car dest) (bitwise-and result #xff)) + (loop (cdr dest) (arithmetic-shift result -8)))))) + ((or (eq? dest 'file) (not (= 0 (bitwise-and opcode #x200)))) + ;; the result goes in memory (file) + (set-ram adr result-8bit)) + ((eq? dest 'wreg) + ;; result goes in wreg + (set-wreg result-8bit))) (if (not (eq? flags-changed 'none)) (begin (set-zero-flag (if (= 0 result-8bit) 1 0)) @@ -519,9 +534,10 @@ (decode-opcode #b0000001 9 (lambda (opcode) - (byte-oriented-file opcode "mulwf" 'none + (byte-oriented-wide opcode "mulwf" 'none (lambda (f) - (* f (get-wreg)))))) + (* f (get-wreg))) + (list PRODL PRODH)))) (decode-opcode #b0110110 9 (lambda (opcode) diff --git a/six-comp.scm b/six-comp.scm index 768fb3a..4a2326a 100755 --- a/six-comp.scm +++ b/six-comp.scm @@ -13,6 +13,20 @@ ;------------------------------------------------------------------------------ +;; temporary solution, to support more than int +(set! ##six-types ;; TODO unsigned types ? + '((int . #f) + (byte . #f) + (int8 . #f) + (int16 . #f) + (int32 . #f) + (char . #f) + (bool . #f) + (void . #f) + (float . #f) + (double . #f) + (obj . #f))) + (define (read-source filename) (shell-command (string-append "cpp -P " filename " > " filename ".tmp")) ;; (##read-all-as-a-begin-expr-from-path ;; TODO use vectorized notation to have info on errors (where in the source) @@ -41,10 +55,10 @@ (let ((source (read-source filename))) '(pretty-print source) - (let ((ast (parse source))) + (let* ((ast (parse source))) '(pretty-print ast) (let ((cfg (generate-cfg ast))) - (print-cfg-bbs cfg) + '(print-cfg-bbs cfg) (pretty-print cfg) (remove-branch-cascades-and-dead-code cfg) (remove-converging-branches cfg) @@ -53,6 +67,11 @@ '(print-cfg-bbs cfg) '(pretty-print cfg) (let ((code (code-gen filename cfg))) - '(pretty-print code) + (asm-assemble) + '(display "------------------ GENERATED CODE\n") + (asm-display-listing (current-output-port)) + (asm-write-hex-file (string-append filename ".hex")) + (asm-end!) '(display "------------------ EXECUTION USING SIMULATOR\n") - '(execute-hex-file (string-append filename ".hex"))))))) + (execute-hex-file (string-append filename ".hex")) + #t))))) diff --git a/utilities.scm b/utilities.scm index b74975d..61d944a 100644 --- a/utilities.scm +++ b/utilities.scm @@ -41,36 +41,31 @@ (else (loop (cdr lst) (+ i 1)))))) (define (remove x lst) - (cond ((null? lst) - '()) - ((eq? x (car lst)) - (cdr lst)) - (else - (cons (car lst) - (remove x (cdr lst)))))) + (cond ((null? lst) '()) + ((eq? x (car lst)) (cdr lst)) + (else (cons (car lst) + (remove x (cdr lst)))))) (define (replace x y lst) - (cond ((null? lst) - '()) - ((eq? x (car lst)) - (cons y (cdr lst))) - (else - (cons (car lst) - (replace x y (cdr lst)))))) + (cond ((null? lst) '()) + ((eq? x (car lst)) (cons y (cdr lst))) + (else (cons (car lst) + (replace x y (cdr lst)))))) (define (last lst) - (cond ((null? lst) - #f) - ((null? (cdr lst)) - (car lst)) - (else (last (cdr lst))))) + (cond ((null? lst) #f) + ((null? (cdr lst)) (car lst)) + (else (last (cdr lst))))) (define (all-but-last lst) (let loop ((lst lst) (new '())) - (cond ((null? lst) - #f) - ((null? (cdr lst)) - (reverse new)) - (else (loop (cdr lst) - (cons (car lst) new)))))) + (cond ((null? lst) #f) + ((null? (cdr lst)) (reverse new)) + (else (loop (cdr lst) + (cons (car lst) new)))))) + +(define (memp p l) + (cond ((null? l) #f) + ((p (car l)) l) + (else (memp p (cdr l))))) -- 2.11.4.GIT