From 0d74f2f9f1d620ffc4eaebfcc07c45e8177d592f Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Sun, 20 Feb 2011 17:03:14 -0500 Subject: [PATCH] trying to type assembly --- assemble.rkt | 200 +++++++++++++++++++++++----------------------- typed-structs.rkt | 5 +- 2 files changed, 103 insertions(+), 102 deletions(-) diff --git a/assemble.rkt b/assemble.rkt index 8b8db51..721421e 100644 --- a/assemble.rkt +++ b/assemble.rkt @@ -11,13 +11,13 @@ (define (assemble/write-invoke stmts op) (let ([basic-blocks (fracture stmts)]) (fprintf op "function(k) {\n") - (for-each (lambda (basic-block) + (for-each (lambda: ([basic-block : BasicBlock]) (displayln (assemble-basic-block basic-block) op) (newline op)) basic-blocks) (fprintf op "MACHINE.cont = k;\n") (fprintf op "trampoline(~a, function() {}); }" - (basic-block-name (first basic-blocks))))) + (BasicBlock-name (first basic-blocks))))) @@ -28,21 +28,22 @@ (let* ([first-block-label (make-label 'start)] [jump-targets (cons first-block-label (collect-general-jump-targets stmts))]) - (let loop ([name first-block-label] - [acc '()] - [basic-blocks '()] - [stmts stmts] - [last-stmt-goto? #f]) + (let: loop : (Listof BasicBlock) + ([name : Symbol first-block-label] + [acc : (Listof Statement) '()] + [basic-blocks : (Listof BasicBlock) '()] + [stmts : (Listof Statement) stmts] + [last-stmt-goto? : Boolean #f]) (cond [(null? stmts) - (reverse (cons (make-basic-block name (reverse acc)) + (reverse (cons (make-BasicBlock name (reverse acc)) basic-blocks))] [(symbol? (car stmts)) (cond [(member (car stmts) jump-targets) (loop (car stmts) '() - (cons (make-basic-block name + (cons (make-BasicBlock name (if last-stmt-goto? (reverse acc) (reverse (append `(,(make-GotoStatement (make-Label (car stmts)))) @@ -66,13 +67,13 @@ ;; unique: (listof symbol -> listof symbol) -(: unique ((Listof symbol) -> (Listof Symbol))) +(: unique ((Listof Symbol) -> (Listof Symbol))) (define (unique los) - (let ([ht (make-hasheq)]) + (let: ([ht : (HashTable Symbol Boolean) (make-hasheq)]) (for ([l los]) (hash-set! ht l #t)) - (for/list ([k (in-hash-keys ht)]) - k))) + (hash-map ht (lambda: ([k : Symbol] [v : Boolean]) k)))) + ;; collect-general-jump-targets: (listof stmt) -> (listof label) @@ -104,32 +105,29 @@ (append (cond [(symbol? stmt) empty] - [(tagged-list? stmt 'assign) - (cond - [(reg? (caddr stmt)) - empty] - [(label? (caddr stmt)) - (list (label-name (caddr stmt)))] - [(const? (caddr stmt)) - empty] - [(op? (caddr stmt)) - (apply append (map collect-input (cdddr stmt)))] - [else - (error 'assemble "~a" stmt)])] - [(tagged-list? stmt 'perform) - (apply append (map collect-input (cddr stmt)))] - [(tagged-list? stmt 'test) - (apply append (map collect-input (cddr stmt)))] - [(tagged-list? stmt 'branch) - (collect-location (cadr stmt))] - [(tagged-list? stmt 'goto) - (collect-location (cadr stmt))] - [(tagged-list? stmt 'save) + [(AssignImmediateStatement? stmt) + (let ([v (AssignImmediateStatement-value stmt)]) + (cond + [(Reg? v) + empty] + [(Label? v) + (list (Label-name v))] + [(Const? v) + empty]))] + [(AssignPrimOpStatement? stmt) + (apply append (map collect-input (AssignPrimOpStatement-rands stmt)))] + [(PerformStatement? stmt) + (apply append (map collect-input (PerformStatement-rands stmt)))] + [(TestStatement? stmt) empty] - [(tagged-list? stmt 'restore) + [(BranchLabelStatement? stmt) + (list (BranchLabelStatement-label stmt))] + [(GotoStatement? stmt) + (collect-location (GotoStatement-target stmt))] + [(SaveStatement? stmt) empty] - [else - (error 'assemble "~a" stmt)]) + [(RestoreStatement? stmt) + empty]) (loop (rest stmts))))])))) @@ -204,9 +202,9 @@ (: assemble-basic-block (BasicBlock -> String)) (define (assemble-basic-block a-basic-block) (format "var ~a=function(){\nif(--MACHINE.callsBeforeTrampoline < 0) { throw ~a; }\n~a};" - (basic-block-name a-basic-block) - (basic-block-name a-basic-block) - (string-join (map assemble-stmt (basic-block-stmts a-basic-block)) + (BasicBlock-name a-basic-block) + (BasicBlock-name a-basic-block) + (string-join (map assemble-stmt (BasicBlock-stmts a-basic-block)) "\n"))) @@ -214,60 +212,62 @@ (: assemble-stmt (Statement -> String)) (define (assemble-stmt stmt) (cond - [(tagged-list? stmt 'assign) - (cond - [(reg? (caddr stmt)) - (format "MACHINE.~a=~a" - (cadr stmt) - (assemble-reg (caddr stmt)))] - [(label? (caddr stmt)) - (format "MACHINE.~a=~a;" (cadr stmt) - (assemble-label (caddr stmt)))] - [(const? (caddr stmt)) - (format "MACHINE.~a=~a;" - (cadr stmt) - (assemble-const (caddr stmt)))] - [(op? (caddr stmt)) - (format "MACHINE.~a=~a;" - (cadr stmt) - (assemble-op-expression (op-name (caddr stmt)) - (cdddr stmt)))] - [else - (error 'assemble "~a" stmt)])] - [(tagged-list? stmt 'perform) - (assemble-op-statement (op-name (cadr stmt)) - (cddr stmt))] - [(tagged-list? stmt 'test) + [(AssignImmediateStatement? stmt) + (let ([v (AssignImmediateStatement-value stmt)]) + (cond + [(Reg? v) + (format "MACHINE.~a=~a" + (AssignImmediateStatement-target stmt) + (assemble-reg v))] + [(Label? v) + (format "MACHINE.~a=~a;" + (AssignImmediateStatement-target stmt) + (assemble-label v))] + [(Const? v) + (format "MACHINE.~a=~a;" + (AssignImmediateStatement-target stmt) + (assemble-const v))]))] + + [(AssignPrimOpStatement? stmt) + (format "MACHINE.~a=~a;" + (AssignPrimOpStatement-target stmt) + (assemble-op-expression (AssignPrimOpStatement-op stmt) + (AssignPrimOpStatement-rands stmt)))] + [(PerformStatement? stmt) + (assemble-op-statement (PerformStatement-op stmt) + (PerformStatement-rands stmt))] + [(TestStatement? stmt) (format "if(~a){" - (assemble-op-expression (op-name (cadr stmt)) - (cddr stmt)))] - [(tagged-list? stmt 'branch) + (assemble-op-expression (TestStatement-op stmt) + (list (make-Reg (TestStatement-register-rand stmt)))))] + [(BranchLabelStatement? stmt) ;; the unbalanced } is deliberate: test and branch always follow each other. (format "return ~a();}" - (assemble-location (cadr stmt)))] - [(tagged-list? stmt 'goto) + (assemble-location (make-Label (BranchLabelStatement-label stmt))))] + [(GotoStatement? stmt) (format "return ~a();" - (assemble-location (cadr stmt)))] - [(tagged-list? stmt 'save) + (assemble-location (GotoStatement-target stmt)))] + [(SaveStatement? stmt) (format "MACHINE.stack.push(MACHINE.~a);" - (cadr stmt))] - [(tagged-list? stmt 'restore) + (SaveStatement-reg stmt))] + [(RestoreStatement? stmt) (format "MACHINE.~a=MACHINE.stack.pop();" - (cadr stmt))] - [else (error 'assemble "~a" stmt)])) + (RestoreStatement-reg stmt))])) + ;; fixme: use js->string -(: Assemble-Const (Any -> String)) +(: assemble-const (Const -> String)) (define (assemble-const stmt) - (let loop ([val (cadr stmt)]) - (cond [(symbol? val) - (format "~s" (symbol->string val))] - [(list? val) - (format "_list(~a)" (string-join (map loop val) - ","))] - [else - (format "~s" val)]))) + (let: loop : String ([val : Any (Const-const stmt)]) + (cond [(symbol? val) + (format "~s" (symbol->string val))] + [(list? val) + (format "_list(~a)" (string-join (map loop val) + ","))] + [else + (format "~s" val)]))) +(: assemble-op-expression (Symbol (Listof OpArg) -> String)) (define (assemble-op-expression op-name inputs) (let ([assembled-inputs (map assemble-input inputs)]) (case op-name @@ -288,7 +288,7 @@ (cond [(empty? inputs) "undefined"] [else - (let loop ([assembled-inputs assembled-inputs]) + (let: loop : String ([assembled-inputs : (Listof String) assembled-inputs]) (cond [(empty? assembled-inputs) "undefined"] @@ -319,7 +319,7 @@ [else (error 'assemble "~e" op-name)]))) - +(: assemble-op-statement (Symbol (Listof OpArg) -> String)) (define (assemble-op-statement op-name inputs) (let ([assembled-inputs (map assemble-input inputs)]) (case op-name @@ -349,28 +349,28 @@ - +(: assemble-input ((U Reg Const Label) -> String)) (define (assemble-input an-input) (cond - [(reg? an-input) + [(Reg? an-input) (assemble-reg an-input)] - [(const? an-input) + [(Const? an-input) (assemble-const an-input)] - [(label? an-input) - (assemble-label an-input)] - [else (error 'assemble-input "~e" an-input)])) - + [(Label? an-input) + (assemble-label an-input)])) + +(: assemble-location ((U Reg Label) -> String)) (define (assemble-location a-location) (cond - [(reg? a-location) + [(Reg? a-location) (assemble-reg a-location)] - [(label? a-location) - (assemble-label a-location)] - [else (error 'assemble-location "~e" a-location)])) + [(Label? a-location) + (assemble-label a-location)])) +(: assemble-reg (Reg -> String)) (define (assemble-reg a-reg) - (string-append "MACHINE." (symbol->string (cadr a-reg)))) - + (string-append "MACHINE." (symbol->string (Reg-name a-reg)))) +(: assemble-label (Label -> String)) (define (assemble-label a-label) - (symbol->string (label-name a-label))) \ No newline at end of file + (symbol->string (Label-name a-label))) \ No newline at end of file diff --git a/typed-structs.rkt b/typed-structs.rkt index 673c394..0f8b7cc 100644 --- a/typed-structs.rkt +++ b/typed-structs.rkt @@ -30,6 +30,7 @@ + ;; instruction sequences (define-type Statement (U Symbol ;; label AssignImmediateStatement @@ -102,5 +103,5 @@ -(define-struct: basic-block ([name : Symbol] - [stmts : (Listof Statement)]) #:transparent) +(define-struct: BasicBlock ([name : Symbol] + [stmts : (Listof Statement)]) #:transparent)