(module nolife-ast mzscheme (define delete-duplicates (lambda (s) (if (null? s) s (let ((a (car s)) (d (cdr s))) (if (or (null? a) (member a d)) (delete-duplicates d) (cons a (delete-duplicates d))))))) (define nth (lambda (l c) (cond ((null? l) #f) ((> c 0) (nth (cdr l) (- c 1))) (else (car l))))) (define count-list (lambda (c) (letrec ((count-list-tr (lambda (n l) (if (< n 0) l (count-list-tr (- n 1) (cons n l)))))) (count-list-tr (- c 1) '())))) (define frameptr '%vr0) (define stackptr '%vr1) (define number->reg (lambda (n) (string->symbol (string-append "%vr" (number->string n))))) (define reg->number (lambda (vr) (let ((vrs (symbol->string vr))) (string->number (substring vrs 3 (string-length vrs)))))) (define data-string (lambda (name str) (list '.string name str))) (define data-float (lambda (name val) (list '.float name val))) (define data-global (lambda (name size align) (list '.global name size align))) (define data-const (lambda (er) (cond ((not (env-record? er)) '()) ((equal? 'STR (env-record-base-type er)) (data-string (env-record-name er) (env-record-val er))) ((equal? 'FLOAT (env-record-base-type er)) (data-float (env-record-name er) (env-record-val er))) (else '())))) (define data-main_fp '(.global main_fp 4 4)) (define data-int_wformat '(.string .int_wformat "\"%d\\12\"")) (define data-flt_wformat '(.string .float_wformat "\"%f\\12\"")) (define data-chr_wformat '(.string .char_wformat "\"%c\\12\"")) (define data-str_wformat '(.string .string_wformat "\"%s\\12\"")) (define data-int_rformat '(.string .int_rformat "\"%d\"")) (define data-flt_rformat '(.string .float_rformat "\"%f\"")) (define data-chr_rformat '(.string .char_rformat "\"%c\"")) (define data-str_rformat '(.string .string_rformat "\"%s\"")) (define data-header (list '(.data) data-chr_rformat data-chr_wformat data-flt_rformat data-flt_wformat data-int_rformat data-int_wformat data-str_rformat data-str_wformat)) (define text-header '((.text))) (define text-frame (lambda (name size nargs) (letrec ((build-args (lambda (n c l) (if (eq? n 0) l (build-args (- n 1) (+ c 1) (append l (list (number->reg c)))))))) (append (list '.frame name size) (build-args nargs 4 '()))))) (define text-store-main_fp (list '(loadI main_fp => %vr2) '(store %vr0 => %vr2))) (define text-load-main_fp (list '(loadI main_fp => %vr2) '(load %vr2 => %vr3))) (define text-load-const-addr (lambda (name vr) (list (list 'loadI name '=> vr)))) (define text-load-global-addr (lambda (vr off) (append text-load-main_fp (list (list 'subI '%vr3 off '=> vr))))) (define text-load-local-addr (lambda (vr off) (list (list 'subI '%vr0 off '=> vr)))) (define text-load-param-addr (lambda (vr off) (list (list 'i2i vr '=> vr)))) (define num-array-elem (lambda (t) (let ((dim (cadadr t))) (+ 1 (if (equal? 'CHAR (cadr t)) (- (char->integer (caddr dim)) (char->integer (cadr dim))) (- (caddr dim) (cadr dim))))))) (define type-size (lambda (t) (cond ((equal? 'INT t) 4) ((equal? 'CHAR t) 4) ((equal? 'FLOAT t) 4) ((equal? 'STR t) 0) ((list? t) (* (type-size (caddr t)) (num-array-elem t)))))) (define base-size (lambda (t) (cond ((symbol? t) (type-size t)) ((list? t) (type-size (caddr t)))))) (define-struct hash-env (env max-vr local-size)) (define-struct env-record (name base-type full-type val load-addr-iloc addr-vr)) (define-struct full-type (name size array? callable? const? min max dim-type param-types)) (define display-full-type (lambda (ft) (if (full-type? ft) (begin (display "(") (display (full-type-name ft)) (display " ") (display (full-type-size ft)) (display " ") (display (full-type-array? ft)) (display " ") (display (full-type-callable? ft)) (display " ") (display (full-type-const? ft)) (display " ") (display (full-type-min ft)) (display " ") (display (full-type-max ft)) (display " ") (display (full-type-dim-type ft)) (display " ") (display (full-type-param-types ft)) (display ")"))))) (define display-env-record (lambda (record) (if (env-record? record) (begin (display "(") (display (env-record-name record)) (display " ") (display (env-record-base-type record)) (display " ") (display-full-type (env-record-full-type record)) (display " ") (display (env-record-val record)) (display " ") (display (env-record-load-addr-iloc record)) (display " ") (display (env-record-addr-vr record)) (display ")"))))) (define display-henv (lambda (henv) (if (hash-env? henv) (begin (display "hash-env:") (newline) (display " max-vr: ") (display (hash-env-max-vr henv)) (newline) (display " local-size: ") (display (hash-env-local-size henv)) (newline) (display " records:") (newline) (hash-table-map (hash-env-env henv) (lambda (name record) (begin (display " ") (display name) (display ": ") (display-env-record record) (newline)))))))) (define make-array-er (lambda (name type vr off load-addr-f) (let ( (base-type (caddr type)) (dim-type (caadr type)) (min (cadadr (cadr type))) (max (caddr (cadr (cadr type)))) ) (make-env-record name base-type (make-full-type base-type (type-size type) #t #f #f min max dim-type '()) #f (load-addr-f vr off) vr)))) (define make-const-er (lambda (name type val vr) (make-env-record name type (make-full-type type (type-size type) #f #f #t 0 0 'NULL '()) val (text-load-const-addr name vr) vr))) (define make-proc-er (lambda (name type param-types) (make-env-record name type (make-full-type type 0 #f #t #f 0 0 'NULL param-types) #f '() #f))) (define make-std-er (lambda (name type vr off load-addr-f) (make-env-record name type (make-full-type type (type-size type) #f #f #f 0 0 'NULL '()) #f (load-addr-f vr off) vr))) (define make-henv (lambda (funcnam locals args globals consts procs) (letrec ( (local-size (lambda (l s) (if (null? l) s (local-size (cdr l) (+ s (full-type-size (env-record-full-type (cdar l)))))))) (build-type-list (lambda (l types) (if (null? l) types (build-type-list (cdr l) (append types (list (caar l))))))) (build-proc-ers (lambda (l ers) (if (null? l) ers (build-proc-ers (cdr l) (cons (cons (cadr (cadar l)) (make-proc-er (cadr (cadar l)) (caadar l) (build-type-list (caddar l) '()))) ers))))) (build-var-ers (lambda (l vr off global? ers) (if (null? l) ers (build-var-ers (cdr l) (+ vr 1) (+ off (type-size (caar l))) global? (cons (cons (cadar l) (if (list? (caar l)) (make-array-er (cadar l) (caar l) (number->reg vr) (+ off (type-size (caar l))) (if global? text-load-global-addr text-load-local-addr)) (make-std-er (cadar l) (caar l) (number->reg vr) (+ off (type-size (caar l))) (if global? text-load-global-addr text-load-local-addr)))) ers))))) (build-arg-ers (lambda (l vr ers) (if (null? l) ers (build-arg-ers (cdr l) (+ vr 1) (cons (cons (cadar l) (if (list? (caar l)) (make-array-er (cadar l) (caar l) (number->reg vr) 0 text-load-param-addr) (make-std-er (cadar l) (caar l) (number->reg vr) 0 text-load-param-addr))) ers))))) (build-const-ers (lambda (l vr ers) (if (null? l) ers (build-const-ers (cdr l) (+ vr 1) (cons (let ((name (string->symbol (string-append "CONST_" (symbol->string (caar l)) "_" (if (null? funcnam) "" (symbol->string funcnam)) (number->string vr))))) (cons name (make-const-er name (caar l) (cadar l) (number->reg vr)))) ers))))) (arg-er-list (build-arg-ers args 4 '())) (local-er-list (build-var-ers locals (+ 4 (length arg-er-list)) 0 #f '())) (global-er-list (build-var-ers globals (+ 4 (+ (length arg-er-list) (length local-er-list))) 0 #t '())) (const-er-list (build-const-ers consts (+ 4 (+ (length arg-er-list) (+ (length local-er-list) (length global-er-list)))) '())) (proc-er-list (build-proc-ers procs '())) (maxvr (+ 3 (+ (length arg-er-list) (+ (length local-er-list) (+ (length global-er-list) (length const-er-list)))))) ) (make-hash-env (make-immutable-hash-table (append const-er-list proc-er-list global-er-list arg-er-list local-er-list)) maxvr (local-size local-er-list 0))))) (define lookup-const-henv (lambda (val henv) (if (hash-env? henv) (let ((resl (delete-duplicates (hash-table-map (hash-env-env henv) (lambda (x y) (if (equal? val (env-record-val y)) y '())))))) (if (null? resl) '() (car resl)))))) (define lookup-var-henv (lambda (name henv) (if (hash-env? henv) (hash-table-get (hash-env-env henv) name '()) '()))) (define lookup-array-dim-type (lambda (name henv) (let ((record (lookup-var-henv name henv))) (if (env-record? record) (full-type-dim-type (env-record-full-type record)) 'NULL)))) (define lookup-base-type-henv (lambda (name henv) (let ((record (lookup-var-henv name henv))) (if (env-record? record) (env-record-base-type record) 'NULL)))) (define coerce-type (lambda (t1 t2) (cond ((eq? t1 t2) t1) ((and (or (equal? t1 'CHAR) (equal? t2 'CHAR)) (not (equal? t1 t2))) 'NULL) ((or (equal? t1 'FLOAT) (equal? t2 'FLOAT)) 'FLOAT) (else 'INT)))) (define expr-type-henv (lambda (expr henv) (cond ((equal? 'CASE (car expr)) (cadr expr)) ((equal? 'INT (car expr)) 'INT) ((equal? 'FLOAT (car expr)) 'FLOAT) ((equal? 'CHAR (car expr)) 'CHAR) ((equal? 'STR (car expr)) 'STR) ((equal? 'VAR (car expr)) (lookup-base-type-henv (cadr expr) henv)) ((equal? 'CALL (car expr)) (lookup-base-type-henv (cadr expr) henv)) ((or (equal? 'AND (car expr)) (equal? 'NOT (car expr)) (equal? 'OR (car expr)) (equal? 'LE (car expr)) (equal? 'LT (car expr)) (equal? 'GE (car expr)) (equal? 'GT (car expr)) (equal? 'EQ (car expr)) (equal? 'NE (car expr))) 'INT) ((null? (cddr expr)) (expr-type-henv (cadr expr) henv)) (else (coerce-type (expr-type-henv (cadr expr) henv) (expr-type-henv (caddr expr) henv)))))) (define annotate-call-f (lambda (f fer henv) (lambda (l c) (cond ((null? l) l) ((equal? 'VAR (car l)) (let ((er (lookup-var-henv (cadr l) henv))) (cons 'VAR (cons (if (env-record? er) (env-record-base-type er) 'NULL) (cdr l))))) (else (let ((expr (f l henv)) (type (nth (full-type-param-types (env-record-full-type fer)) c))) (list 'STORE type (list 'CAST type expr)))))))) (define annotate-expr-henv (lambda (expr henv) (cond ((null? expr) expr) ((equal? 'VAR (car expr)) (let ((type (expr-type-henv expr henv))) (list 'LOAD type (list (car expr) type (cadr expr) (if (null? (caddr expr)) '() (list 'CAST (lookup-array-dim-type (cadr expr) henv) (annotate-expr-henv (caddr expr) henv))))))) ((equal? 'CONST (car expr)) (let ((er (lookup-const-henv (cadr expr) henv))) (if (env-record? er) (if (equal? 'FLOAT (env-record-base-type er)) (list 'LOAD (list 'CONST 'FLOAT (env-record-name er))) (list 'CONST (env-record-name er))) (list 'CONST-VAL (cadr expr))))) ((equal? 'CALL (car expr)) (list 'CALL (expr-type-henv expr henv) (cadr expr) (map (annotate-call-f annotate-expr-henv (lookup-var-henv (cadr expr) henv) henv) (caddr expr) (count-list (length (caddr expr)))))) ((or (equal? 'INT (car expr)) (equal? 'CHAR (car expr)) (equal? 'FLOAT (car expr)) (equal? 'STR (car expr))) (let ((res (annotate-expr-henv (cadr expr) henv))) (append (list (car res) (car expr)) (cdr res)))) ((or (equal? 'LE (car expr)) (equal? 'LT (car expr)) (equal? 'EQ (car expr)) (equal? 'NE (car expr)) (equal? 'GE (car expr)) (equal? 'GT (car expr))) (list 'CAST 'INT (let ((type (coerce-type (expr-type-henv (cadr expr) henv) (expr-type-henv (caddr expr) henv)))) (append (list (car expr) type (list 'CAST type (annotate-expr-henv (cadr expr) henv)) (list 'CAST type (annotate-expr-henv (caddr expr) henv))))))) ((or (equal? 'OR (car expr)) (equal? 'AND (car expr)) (equal? 'NOT (car expr))) (list (expr-type-henv expr henv) (cons (car expr) (map (lambda (x) (list 'CAST 'INT (annotate-expr-henv x henv))) (cdr expr))))) ((or (equal? 'ADD (car expr)) (equal? 'SUB (car expr)) (equal? 'MUL (car expr)) (equal? 'MOD (car expr))) (let ((type (expr-type-henv expr henv))) (append (list (car expr) type) (map (lambda (x) (list 'CAST type (annotate-expr-henv x henv))) (cdr expr))))) (else expr)))) (define annotate-func-henv (lambda (text henv name) (letrec ( (func-er (lookup-var-henv name henv)) (annotate-stmt (lambda (stmt) (cond ((null? stmt) stmt) ((list? (car stmt)) (map annotate-stmt stmt)) ((equal? 'ASSIGN (car stmt)) (let ((dst (list (car (cadr stmt)) (expr-type-henv (cadr stmt) henv) (cadr (cadr stmt)) (annotate-expr-henv (caddr (cadr stmt)) henv))) (src (annotate-expr-henv (caddr stmt) henv))) (list 'ASSIGN dst (list 'CAST (cadr dst) src)))) ((equal? 'CALL (car stmt)) (annotate-expr-henv stmt henv)) ((equal? 'IF (car stmt)) (list 'IF (list 'CAST 'INT (annotate-expr-henv (cadr stmt) henv)) (annotate-stmt (caddr stmt)) (annotate-stmt (cadddr stmt)))) ((equal? 'READ (car stmt)) (list 'READ (list (car (cadr stmt)) (expr-type-henv (cadr stmt) henv) (cadr (cadr stmt)) (annotate-expr-henv (caddr (cadr stmt)) henv)))) ((equal? 'RETURN (car stmt)) (if (equal? 'main name) (list 'RETURN (annotate-expr-henv (cadr stmt) henv)) (let ((type (env-record-base-type func-er))) (list 'RETURN (list 'CAST type (annotate-expr-henv (cadr stmt) henv)))))) ((equal? 'WHILE (car stmt)) (list 'WHILE (list 'CAST 'INT (annotate-expr-henv (cadr stmt) henv)) (annotate-stmt (caddr stmt)))) ((equal? 'WRITE (car stmt)) (list 'WRITE (annotate-expr-henv (cadr stmt) henv))) (else stmt))))) (map annotate-stmt text)))) (define annotate-ast (lambda (ast) (letrec ( (cadddar (lambda (l) (car (cdr (cdr (cdr (car l))))))) (caddddr (lambda (l) (car (cdr (cdr (cdr (cdr l))))))) (caddddar (lambda (l) (car (cdr (cdr (cdr (cdr (car l)))))))) (find-consts (lambda (stmts) (letrec ( (find-consts-tr (lambda (l globs) (cond ((null? l) globs) ((not (list? l)) globs) ((and (or (equal? 'STR (car l)) (equal? 'FLOAT (car l))) (not (null? (cdr l))) (not (null? (cadr l))) (equal? 'CONST (caadr l))) (cons (list (car l) (cadadr l)) globs)) (else (find-consts-tr (cdr l) (find-consts-tr (car l) globs)))))) ) (find-consts-tr stmts '())))) (annotate-funcs (lambda (funcs l) (if (null? funcs) l (let ((henv (make-henv (cadr (cadar funcs)) (cadddar funcs) (caddar funcs) (caddr ast) (find-consts (caddddar funcs)) (cadddr ast)))) (annotate-funcs (cdr funcs) (append l (list (list (caar funcs) (cadar funcs) henv (annotate-func-henv (caddddar funcs) henv (cadr (cadar funcs))) (cadr (cadar funcs)))))))))) (ghenv (make-henv '() (caddr ast) '() '() (find-consts (caddddr ast)) (cadddr ast))) ) (list 'PROG (cadr ast) ghenv (annotate-funcs (cadddr ast) '()) (annotate-func-henv (caddddr ast) ghenv 'main))))) (define ast-data->iloc (lambda (ast) (letrec ( (all-consts (lambda (l c) (if (null? l) c (all-consts (cdr l) (append c (hash-table-map (hash-env-env (caddar l)) (lambda (x y) (if (full-type-const? (env-record-full-type y)) y '())))))))) (gen-consts (lambda () (letrec ((consts (all-consts (cadddr ast) (hash-table-map (hash-env-env (caddr ast)) (lambda (x y) (if (full-type-const? (env-record-full-type y)) y '()))))) (decl-consts (lambda (l c) (if (null? l) c (decl-consts (cdr l) (append c (list (data-const (car l)))))))) ) (decl-consts (delete-duplicates consts) '())))) ) (append (gen-consts) (if (not (null? (cadddr ast))) (list data-main_fp) '()) )))) (define iloc-vr-table (make-hash-table 'equal)) (define iloc-vr-base 4) (define iloc-n-while 0) (define iloc-n-if 0) (define next-avail-vr (lambda () (number->reg (+ (hash-table-count iloc-vr-table) iloc-vr-base)))) (define get-dummy-vr (lambda () (let ((vr (next-avail-vr))) (hash-table-put! iloc-vr-table (list 'i2i vr '=> vr) vr) vr))) (define next-while (lambda () (let ((n iloc-n-while)) (set! iloc-n-while (+ n 1)) n))) (define next-if (lambda () (let ((n iloc-n-if)) (set! iloc-n-if (+ n 1)) n))) (define ast-text->iloc (lambda (ast) (letrec ( (caadadr (lambda (l) (car (car (cdr (car (cdr l))))))) (cadaddr (lambda (l) (car (cdr (car (cdr (cdr l))))))) (caddddr (lambda (l) (car (cdr (cdr (cdr (cdr l))))))) (caddadr (lambda (l) (car (cdr (cdr (car (cdr l))))))) (cadadadr (lambda (l) (car (cdr (car (cdr (car (cdr l)))))))) (func-body->iloc (lambda (stmts henv name) (letrec ( (get-last-dst-vr (lambda (l) ;(display l) (newline) (letrec ((get-dst (lambda (l) (cond ((null? l) '%vrNULL) ((null? (cdr l)) (car l)) (else (get-dst (cdr l))))))) (cond ((null? l) '%vrNULL) ((null? (cdr l)) (get-dst (car l))) (else (get-last-dst-vr (cdr l))))))) (iloc-add-dst (lambda (iloc) (append iloc (let ((vr (hash-table-get iloc-vr-table iloc '()))) (if (null? vr) (let ((nvr (next-avail-vr))) (begin (hash-table-put! iloc-vr-table iloc nvr) (list nvr))) (list vr)))))) (expr->iloc (lambda (expr) ;(display expr)(newline) (cond ((null? expr) '(nop)) ((equal? 'VAR (car expr)) (let ((er (lookup-var-henv (caddr expr) henv))) (cond ((not (env-record? er)) (raise-user-error (string-append "AST->ILOC Error: Could not find variable " (symbol->string (cadr expr)) " in current scope!"))) ((not (null? (cadddr expr))) (let* ((idx-expr (cadddr expr)) (idx-iloc (expr->iloc idx-expr)) (idx-vr (get-last-dst-vr idx-iloc))) (append idx-iloc (env-record-load-addr-iloc er) (list (iloc-add-dst (list 'add (env-record-addr-vr er) idx-vr '=>)))))) (else (env-record-load-addr-iloc er))))) ((equal? 'LOAD (car expr)) (let* ((inst (if (equal? 'FLOAT (cadr expr)) 'fload 'load)) (addr-iloc (expr->iloc (caddr expr))) (addr-vr (get-last-dst-vr addr-iloc))) (append addr-iloc (list (iloc-add-dst (list inst addr-vr '=>)))))) ((equal? 'STORE (car expr)) (let* ((src-iloc (expr->iloc (caddr expr))) (src-vr (get-last-dst-vr src-iloc)) (addr-vr (get-dummy-vr))) (append src-iloc (list (list 'subI stackptr 4 '=> stackptr) (list 'i2i stackptr '=> addr-vr) (list (if (equal? 'FLOAT (cadr expr)) 'fstore 'store) src-vr '=> addr-vr))))) ((equal? 'CONST (car expr)) (let ((er (lookup-var-henv (caddr expr) henv))) (if (not (env-record? er)) (raise-user-error (string-append "AST->ILOC Error: Could not find constant" (symbol->string (cadr expr)) " in current scope!")) (env-record-load-addr-iloc er)))) ((equal? 'CONST-VAL (car expr)) (let ((val (if (char? (caddr expr)) (char->integer (caddr expr)) (caddr expr)))) (list (iloc-add-dst (list 'loadI val '=>))))) ((equal? 'CALL (car expr)) (letrec ((count-stores (lambda (l c) (cond ((null? l) c) ((equal? 'STORE (caar l)) (count-stores (cdr l) (+ c 1))) (else (count-stores (cdr l) c))))) (n-stores (count-stores (cadddr expr) 0)) (build-src-list (lambda (expr-l l) (if (null? expr-l) l (let* ((src-iloc (expr->iloc (car expr-l))) (src-vr (get-last-dst-vr src-iloc)) (iloc-l (if (null? l) l (car l))) (vr-l (if (null? l) l (cdr l)))) (build-src-list (cdr expr-l) (cons (append iloc-l src-iloc) (cons src-vr vr-l))))))) (src-list (build-src-list (cadddr expr) '())) (src-iloc (if (null? src-list) '() (car src-list))) (src-vrs (reverse (if (null? src-list) '() (cdr src-list)))) (no-dst? (equal? 'NULL (cadr expr))) (name (caddr expr)) (inst (cond (no-dst? 'call) ((equal? 'FLOAT (cadr expr)) 'fcall) (else 'icall))) (iloc-inst (cons inst (cons name src-vrs)))) (append src-iloc (list (if no-dst? iloc-inst (iloc-add-dst (append iloc-inst (list '=>))))) (list (list 'addI stackptr (* n-stores 4) '=> stackptr))))) ((equal? 'CAST (car expr)) (let ((src-type (cadaddr expr)) (dst-type (cadr expr))) (cond ((equal? src-type dst-type) (expr->iloc (caddr expr))) ((equal? 'NULL src-type) (raise-user-error "AST->ILOC Error: Cannot determine type of cast source!")) ((equal? 'NULL dst-type) (raise-user-error "AST->ILOC Error: Cannot determine type of cast dest!")) ((or (equal? 'CHAR src-type) (equal? 'CHAR dst-type)) (raise-user-error (string-append "AST->ILOC Error: Cannot cast from " (symbol->string src-type) " to " (symbol->string dst-type) "!"))) (else (let* ((src-iloc (expr->iloc (caddr expr))) (src-vr (get-last-dst-vr src-iloc)) (inst (if (equal? 'INT src-type) 'i2f 'f2i))) (append src-iloc (list (iloc-add-dst (list inst src-vr '=>))))))))) ((or (or (equal? 'EQ (car expr)) (equal? 'NE (car expr))) (or (or (equal? 'LE (car expr)) (equal? 'LT (car expr))) (or (equal? 'GE (car expr)) (equal? 'GT (car expr))))) (let* ((src1-iloc (expr->iloc (caddr expr))) (src2-iloc (expr->iloc (cadddr expr))) (src1-vr (get-last-dst-vr src1-iloc)) (src2-vr (get-last-dst-vr src2-iloc)) (cinst (if (equal? 'FLOAT (cadr expr)) 'fcomp 'comp)) (tinst (cond ((equal? 'LE (car expr)) 'testle) ((equal? 'LT (car expr)) 'testlt) ((equal? 'GE (car expr)) 'testge) ((equal? 'GT (car expr)) 'testgt) ((equal? 'EQ (car expr)) 'testeq) ((equal? 'NE (car expr)) 'testne))) (ciloc (iloc-add-dst (list cinst src1-vr src2-vr '=>))) (tiloc (iloc-add-dst (list tinst (caddddr ciloc) '=>)))) (append src1-iloc src2-iloc (list ciloc tiloc)))) ((or (equal? 'OR (car expr)) (equal? 'AND (car expr))) (let* ((src1-iloc (expr->iloc (caddr expr))) (src2-iloc (expr->iloc (cadddr expr))) (src1-vr (get-last-dst-vr src1-iloc)) (src2-vr (get-last-dst-vr src2-iloc)) (zero-iloc (list (iloc-add-dst (list 'loadI 0 '=>)))) (zero-vr (get-last-dst-vr zero-iloc)) (comp1-iloc (list (iloc-add-dst (list 'testne src1-vr zero-vr '=>)))) (comp1-vr (get-last-dst-vr comp1-iloc)) (comp2-iloc (list (iloc-add-dst (list 'testne src2-vr zero-vr '=>)))) (comp2-vr (get-last-dst-vr comp2-iloc)) (inst (if (equal? 'OR (car expr)) 'or 'and))) (list (iloc-add-dst (list inst comp1-vr comp2-vr '=>))))) ((equal? 'NOT (car expr)) (let* ((src-iloc (expr->iloc (caddr expr))) (src-vr (get-last-dst-vr src-iloc)) (zero-iloc (list (iloc-add-dst (list 'loadI 0 '=>)))) (zero-vr (get-last-dst-vr zero-iloc)) (comp-iloc (list (iloc-add-dst (list 'testne src-vr zero-vr '=>)))) (comp-vr (get-last-dst-vr comp-iloc)) (inst 'not)) (list (iloc-add-dst (list inst comp-vr '=>))))) ((equal? 'ADD (car expr)) (let* ((src1-iloc (expr->iloc (caddr expr))) (src2-iloc (expr->iloc (cadddr expr))) (src1-vr (get-last-dst-vr src1-iloc)) (src2-vr (get-last-dst-vr src2-iloc)) (inst (if (equal? 'FLOAT (car expr)) 'fadd 'add))) (append src1-iloc src2-iloc (list (iloc-add-dst (list inst src1-vr src2-vr '=>)))))) ((equal? 'SUB (car expr)) (let* ((src1-iloc (expr->iloc (caddr expr))) (src2-iloc (expr->iloc (cadddr expr))) (src1-vr (get-last-dst-vr src1-iloc)) (src2-vr (get-last-dst-vr src2-iloc)) (inst (if (equal? 'FLOAT (car expr)) 'fsub 'sub))) (append src1-iloc src2-iloc (list (iloc-add-dst (list inst src1-vr src2-vr '=>)))))) ((equal? 'MUL (car expr)) (let* ((src1-iloc (expr->iloc (caddr expr))) (src2-iloc (expr->iloc (cadddr expr))) (src1-vr (get-last-dst-vr src1-iloc)) (src2-vr (get-last-dst-vr src2-iloc)) (inst (if (equal? 'FLOAT (car expr)) 'fmul 'mul))) (append src1-iloc src2-iloc (list (iloc-add-dst (list inst src1-vr src2-vr '=>)))))) ((equal? 'MOD (car expr)) (let* ((src1-iloc (expr->iloc (caddr expr))) (src2-iloc (expr->iloc (cadddr expr))) (src1-vr (get-last-dst-vr src1-iloc)) (src2-vr (get-last-dst-vr src2-iloc)) (inst (if (equal? 'INT (car expr)) 'mod (raise-user-error "AST->ILOC Error: Cannot apply MOD operator to non-integer values!")))) (append src1-iloc src2-iloc (list (iloc-add-dst (list inst src1-vr src2-vr '=>)))))) (else '(nop))))) (append-l (lambda (l c) (if (null? l) c (append-l (cdr l) (append c (car l)))))) (stmt->iloc (lambda (stmt l) (cond ((null? stmt) '((nop))) ((list? (car stmt)) (append l (append-l (map (lambda (s) (stmt->iloc s '())) stmt) '()))) ((equal? 'ASSIGN (car stmt)) (let* ((dst-addr-iloc (expr->iloc (cadr stmt))) (dst-addr-vr (get-last-dst-vr dst-addr-iloc)) (src-iloc (expr->iloc (caddr stmt))) (src-vr (get-last-dst-vr src-iloc)) (type (cadadr stmt)) (inst (if (equal? 'FLOAT type) 'fstore 'store))) (append src-iloc dst-addr-iloc (list (list inst src-vr '=> dst-addr-vr))))) ((equal? 'CALL (car stmt)) (expr->iloc stmt)) ((equal? 'IF (car stmt)) (let* ((src-iloc (expr->iloc (cadr stmt))) (src-vr (get-last-dst-vr src-iloc)) (zero-iloc (list (iloc-add-dst (list 'loadI 0 '=>)))) (zero-vr (get-last-dst-vr zero-iloc)) (comp-iloc (list (iloc-add-dst (list 'testne src-vr zero-vr '=>)))) (comp-vr (get-last-dst-vr comp-iloc)) (n (next-if)) (make-lbl (lambda (s) (string->symbol (string-append (symbol->string name) s (number->string n))))) (make-hdr (lambda (l) (list (list l 'nop)))) (end-lbl (make-lbl "_if_e_")) (end-hdr (make-hdr end-lbl)) (true-lbl (make-lbl "_if_t_")) (true-hdr (make-hdr true-lbl)) (true-ftr (list (list 'jumpI '=> end-lbl))) (true-iloc (append true-hdr (stmt->iloc (caddr stmt) '()) true-ftr)) (false-lbl (make-lbl "_if_f_")) (false-hdr (make-hdr false-lbl)) (false-ftr (list (list 'jumpI '=> end-lbl))) (false-iloc (append false-hdr (stmt->iloc (cadddr stmt) '()) false-ftr)) (branch-iloc (list (list 'cbrne comp-vr '=> false-lbl) (list 'jumpI '=> true-lbl)))) (append src-iloc zero-iloc comp-iloc branch-iloc true-iloc false-iloc end-hdr))) ((equal? 'READ (car stmt)) (cond ((null? (cdr stmt)) (raise-user-error "AST->ILOC Error: Encountered READ statement with no arguments!")) ((equal? 'VAR (caadr stmt)) (append (expr->iloc (cadr stmt)) (let* ((er (lookup-var-henv (caddadr stmt) henv)) (type (cadadr stmt)) (inst (cond ((equal? 'INT type) 'iread) ((equal? 'FLOAT type) 'fread) ((equal? 'CHAR type) 'cread) (else (raise-user-error "AST->ILOC Error: Must read a primitive type!"))))) (if (and (env-record? er) (equal? type (env-record-base-type er))) (list (list inst (env-record-addr-vr er))) (raise-user-error (string-append "AST->ILOC Error: Could not find variable " (symbol->string (caddadr stmt)) " to read into!")))))) (else (raise-user-error "AST->ILOC Error: Encountered READ statement with invalid arguments!")))) ((equal? 'RETURN (car stmt)) (cond ((null? (cdr stmt)) '((ret))) ((null? (cadr stmt)) '((ret))) (else (let* ((src-iloc (expr->iloc (cadr stmt))) (src-vr (get-last-dst-vr src-iloc)) (inst (if (equal? 'FLOAT (cadadr stmt)) 'fret 'iret))) (append src-iloc (list (list inst src-vr))))))) ((equal? 'WHILE (car stmt)) (let* ((src-iloc (expr->iloc (cadr stmt))) (src-vr (get-last-dst-vr src-iloc)) (zero-iloc (list (iloc-add-dst (list 'loadI 0 '=>)))) (zero-vr (get-last-dst-vr zero-iloc)) (comp-iloc (list (iloc-add-dst (list 'testne src-vr zero-vr '=>)))) (comp-vr (get-last-dst-vr comp-iloc)) (n (next-while)) (make-lbl (lambda (s) (string->symbol (string-append (symbol->string name) s (number->string n))))) (make-hdr (lambda (l) (list (list l 'nop)))) (end-lbl (make-lbl "_while_e_")) (end-hdr (make-hdr end-lbl)) (test-lbl (make-lbl "_while_t_")) (test-hdr (make-hdr test-lbl)) (loop-lbl (make-lbl "_while_l_")) (loop-hdr (append (make-hdr loop-lbl) src-iloc zero-iloc comp-iloc)) (loop-ftr (list (list 'jumpI '=> test-lbl))) (loop-iloc (append loop-hdr (stmt->iloc (caddr stmt) '()) loop-ftr)) (test-ftr (list (list 'cbrne comp-vr '=> end-lbl) (list 'jumpI '=> loop-lbl))) (test-iloc (append test-hdr test-ftr))) (append test-iloc loop-iloc end-hdr))) ((equal? 'WRITE (car stmt)) (if (null? (cdr stmt)) (raise-user-error "AST->ILOC Error: Encountered WRITE statement with no arguments!") (let* ((src-iloc (expr->iloc (cadr stmt))) (src-vr (get-last-dst-vr src-iloc)) (inst (let ((type (if (equal? 'VAR (caadr stmt)) (lookup-base-type-henv (cadadr stmt) henv) (cadadr stmt)))) (cond ((equal? 'INT type) 'iwrite) ((equal? 'FLOAT type) 'fwrite) ((equal? 'CHAR type) 'cwrite) ((equal? 'STR type) 'swrite) (else (raise-user-error "AST->ILOC Error: Encountered WRITE with invalid arguments!")))))) (append src-iloc (list (list inst src-vr)))))) (else '((nop))))))) (begin (set! iloc-vr-base (+ 1 (hash-env-max-vr henv))) (set! iloc-vr-table (make-hash-table 'equal)) (set! iloc-n-if 0) (set! iloc-n-while 0) (let ((res (append (stmt->iloc stmts '()) '((ret))))) ;(display "Used ") ;(display (hash-table-count iloc-vr-table)) ;(display " temporary registers in ") ;(display name) ;(display ".\n") res))))) (func->iloc (lambda (l) (append (list (text-frame (cadadr l) (hash-env-local-size (caddr l)) (length (full-type-param-types (env-record-full-type (hash-table-get (hash-env-env (caddr l)) (cadadr l) 0)))))) (func-body->iloc (cadddr l) (caddr l) (cadadr l))))) (funcs->iloc (lambda (fl il) (if (null? fl) il (funcs->iloc (cdr fl) (append il (func->iloc (car fl))))))) ) (append (list (text-frame 'main (hash-env-local-size (caddr ast)) 0)) (if (not (null? (cadddr ast))) text-store-main_fp '()) (func-body->iloc (caddddr ast) (caddr ast) 'main) (funcs->iloc (cadddr ast) '()))))) (define ast->iloc (lambda (ast) (append data-header (ast-data->iloc ast) text-header (ast-text->iloc ast)))) (define display-henvs (lambda (ast) (letrec ( (main-henv (caddr ast)) (funcs (cadddr ast)) (cadadar (lambda (l) (car (cdr (car (cdr (car l))))))) (display-func (lambda (name henv) (begin (display name) (display "-") (display-henv henv)))) (display-funcs (lambda (l) (if (not (null? l)) (begin (display-func (cadadar l) (caddar l)) (display-funcs (cdr l)))))) ) (begin (display-func 'main main-henv) (display-funcs funcs))))) (define nolife-annotate-ast annotate-ast) (define nolife-ast->iloc (lambda (x) (ast->iloc (annotate-ast x)))) (define nolife-display-henvs (lambda (x) (display-henvs (annotate-ast x)))) (provide nolife-ast->iloc nolife-annotate-ast nolife-display-henvs) )