suzanne.soy/whalesong
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

trying to type assembly

Browse Source
This commit is contained in:
Danny Yoo 2011-02-20 17:03:14 -05:00
parent c9066c2654
commit 0d74f2f9f1
2 changed files with 103 additions and 102 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

198
assemble.rkt
View File

@ -11,13 +11,13 @@
(define (assemble/write-invoke stmts op) (define (assemble/write-invoke stmts op)
(let ([basic-blocks (fracture stmts)]) (let ([basic-blocks (fracture stmts)])
(fprintf op "function(k) {\n") (fprintf op "function(k) {\n")
(for-each (lambda (basic-block) (for-each (lambda: ([basic-block : BasicBlock])
(displayln (assemble-basic-block basic-block) op) (displayln (assemble-basic-block basic-block) op)
(newline op)) (newline op))
basic-blocks) basic-blocks)
(fprintf op "MACHINE.cont = k;\n") (fprintf op "MACHINE.cont = k;\n")
(fprintf op "trampoline(~a, function() {}); }" (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)] (let* ([first-block-label (make-label 'start)]
[jump-targets [jump-targets
(cons first-block-label (collect-general-jump-targets stmts))]) (cons first-block-label (collect-general-jump-targets stmts))])
(let loop ([name first-block-label] (let: loop : (Listof BasicBlock)
[acc '()] ([name : Symbol first-block-label]
[basic-blocks '()] [acc : (Listof Statement) '()]
[stmts stmts] [basic-blocks : (Listof BasicBlock) '()]
[last-stmt-goto? #f]) [stmts : (Listof Statement) stmts]
[last-stmt-goto? : Boolean #f])
(cond (cond
[(null? stmts) [(null? stmts)
(reverse (cons (make-basic-block name (reverse acc)) (reverse (cons (make-BasicBlock name (reverse acc))
basic-blocks))] basic-blocks))]
[(symbol? (car stmts)) [(symbol? (car stmts))
(cond (cond
[(member (car stmts) jump-targets) [(member (car stmts) jump-targets)
(loop (car stmts) (loop (car stmts)
'() '()
(cons (make-basic-block name (cons (make-BasicBlock name
(if last-stmt-goto? (if last-stmt-goto?
(reverse acc) (reverse acc)
(reverse (append `(,(make-GotoStatement (make-Label (car stmts)))) (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))) (: unique ((Listof Symbol) -> (Listof Symbol)))
(define (unique los) (define (unique los)
(let ([ht (make-hasheq)]) (let: ([ht : (HashTable Symbol Boolean) (make-hasheq)])
(for ([l los]) (for ([l los])
(hash-set! ht l #t)) (hash-set! ht l #t))
(for/list ([k (in-hash-keys ht)]) (hash-map ht (lambda: ([k : Symbol] [v : Boolean]) k))))
k)))
;; collect-general-jump-targets: (listof stmt) -> (listof label) ;; collect-general-jump-targets: (listof stmt) -> (listof label)
@ -104,32 +105,29 @@
(append (cond (append (cond
[(symbol? stmt) [(symbol? stmt)
empty] empty]
[(tagged-list? stmt 'assign) [(AssignImmediateStatement? stmt)
(cond (let ([v (AssignImmediateStatement-value stmt)])
[(reg? (caddr stmt)) (cond
empty] [(Reg? v)
[(label? (caddr stmt)) empty]
(list (label-name (caddr stmt)))] [(Label? v)
[(const? (caddr stmt)) (list (Label-name v))]
empty] [(Const? v)
[(op? (caddr stmt)) empty]))]
(apply append (map collect-input (cdddr stmt)))] [(AssignPrimOpStatement? stmt)
[else (apply append (map collect-input (AssignPrimOpStatement-rands stmt)))]
(error 'assemble "~a" stmt)])] [(PerformStatement? stmt)
[(tagged-list? stmt 'perform) (apply append (map collect-input (PerformStatement-rands stmt)))]
(apply append (map collect-input (cddr stmt)))] [(TestStatement? 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)
empty] empty]
[(tagged-list? stmt 'restore) [(BranchLabelStatement? stmt)
(list (BranchLabelStatement-label stmt))]
[(GotoStatement? stmt)
(collect-location (GotoStatement-target stmt))]
[(SaveStatement? stmt)
empty] empty]
[else [(RestoreStatement? stmt)
(error 'assemble "~a" stmt)]) empty])
(loop (rest stmts))))])))) (loop (rest stmts))))]))))
@ -204,9 +202,9 @@
(: assemble-basic-block (BasicBlock -> String)) (: assemble-basic-block (BasicBlock -> String))
(define (assemble-basic-block a-basic-block) (define (assemble-basic-block a-basic-block)
(format "var ~a=function(){\nif(--MACHINE.callsBeforeTrampoline < 0) { throw ~a; }\n~a};" (format "var ~a=function(){\nif(--MACHINE.callsBeforeTrampoline < 0) { throw ~a; }\n~a};"
(basic-block-name a-basic-block) (BasicBlock-name a-basic-block)
(basic-block-name a-basic-block) (BasicBlock-name a-basic-block)
(string-join (map assemble-stmt (basic-block-stmts a-basic-block)) (string-join (map assemble-stmt (BasicBlock-stmts a-basic-block))
"\n"))) "\n")))
@ -214,60 +212,62 @@
(: assemble-stmt (Statement -> String)) (: assemble-stmt (Statement -> String))
(define (assemble-stmt stmt) (define (assemble-stmt stmt)
(cond (cond
[(tagged-list? stmt 'assign) [(AssignImmediateStatement? stmt)
(cond (let ([v (AssignImmediateStatement-value stmt)])
[(reg? (caddr stmt)) (cond
(format "MACHINE.~a=~a" [(Reg? v)
(cadr stmt) (format "MACHINE.~a=~a"
(assemble-reg (caddr stmt)))] (AssignImmediateStatement-target stmt)
[(label? (caddr stmt)) (assemble-reg v))]
(format "MACHINE.~a=~a;" (cadr stmt) [(Label? v)
(assemble-label (caddr stmt)))] (format "MACHINE.~a=~a;"
[(const? (caddr stmt)) (AssignImmediateStatement-target stmt)
(format "MACHINE.~a=~a;" (assemble-label v))]
(cadr stmt) [(Const? v)
(assemble-const (caddr stmt)))] (format "MACHINE.~a=~a;"
[(op? (caddr stmt)) (AssignImmediateStatement-target stmt)
(format "MACHINE.~a=~a;" (assemble-const v))]))]
(cadr stmt)
(assemble-op-expression (op-name (caddr stmt)) [(AssignPrimOpStatement? stmt)
(cdddr stmt)))] (format "MACHINE.~a=~a;"
[else (AssignPrimOpStatement-target stmt)
(error 'assemble "~a" stmt)])] (assemble-op-expression (AssignPrimOpStatement-op stmt)
[(tagged-list? stmt 'perform) (AssignPrimOpStatement-rands stmt)))]
(assemble-op-statement (op-name (cadr stmt)) [(PerformStatement? stmt)
(cddr stmt))] (assemble-op-statement (PerformStatement-op stmt)
[(tagged-list? stmt 'test) (PerformStatement-rands stmt))]
[(TestStatement? stmt)
(format "if(~a){" (format "if(~a){"
(assemble-op-expression (op-name (cadr stmt)) (assemble-op-expression (TestStatement-op stmt)
(cddr stmt)))] (list (make-Reg (TestStatement-register-rand stmt)))))]
[(tagged-list? stmt 'branch) [(BranchLabelStatement? stmt)
;; the unbalanced } is deliberate: test and branch always follow each other. ;; the unbalanced } is deliberate: test and branch always follow each other.
(format "return ~a();}" (format "return ~a();}"
(assemble-location (cadr stmt)))] (assemble-location (make-Label (BranchLabelStatement-label stmt))))]
[(tagged-list? stmt 'goto) [(GotoStatement? stmt)
(format "return ~a();" (format "return ~a();"
(assemble-location (cadr stmt)))] (assemble-location (GotoStatement-target stmt)))]
[(tagged-list? stmt 'save) [(SaveStatement? stmt)
(format "MACHINE.stack.push(MACHINE.~a);" (format "MACHINE.stack.push(MACHINE.~a);"
(cadr stmt))] (SaveStatement-reg stmt))]
[(tagged-list? stmt 'restore) [(RestoreStatement? stmt)
(format "MACHINE.~a=MACHINE.stack.pop();" (format "MACHINE.~a=MACHINE.stack.pop();"
(cadr stmt))] (RestoreStatement-reg stmt))]))
[else (error 'assemble "~a" stmt)]))
;; fixme: use js->string ;; fixme: use js->string
(: Assemble-Const (Any -> String)) (: assemble-const (Const -> String))
(define (assemble-const stmt) (define (assemble-const stmt)
(let loop ([val (cadr stmt)]) (let: loop : String ([val : Any (Const-const stmt)])
(cond [(symbol? val) (cond [(symbol? val)
(format "~s" (symbol->string val))] (format "~s" (symbol->string val))]
[(list? val) [(list? val)
(format "_list(~a)" (string-join (map loop val) (format "_list(~a)" (string-join (map loop val)
","))] ","))]
[else [else
(format "~s" val)]))) (format "~s" val)])))
(: assemble-op-expression (Symbol (Listof OpArg) -> String))
(define (assemble-op-expression op-name inputs) (define (assemble-op-expression op-name inputs)
(let ([assembled-inputs (map assemble-input inputs)]) (let ([assembled-inputs (map assemble-input inputs)])
(case op-name (case op-name
@ -288,7 +288,7 @@
(cond [(empty? inputs) (cond [(empty? inputs)
"undefined"] "undefined"]
[else [else
(let loop ([assembled-inputs assembled-inputs]) (let: loop : String ([assembled-inputs : (Listof String) assembled-inputs])
(cond (cond
[(empty? assembled-inputs) [(empty? assembled-inputs)
"undefined"] "undefined"]
@ -319,7 +319,7 @@
[else [else
(error 'assemble "~e" op-name)]))) (error 'assemble "~e" op-name)])))
(: assemble-op-statement (Symbol (Listof OpArg) -> String))
(define (assemble-op-statement op-name inputs) (define (assemble-op-statement op-name inputs)
(let ([assembled-inputs (map assemble-input inputs)]) (let ([assembled-inputs (map assemble-input inputs)])
(case op-name (case op-name
@ -349,28 +349,28 @@
(: assemble-input ((U Reg Const Label) -> String))
(define (assemble-input an-input) (define (assemble-input an-input)
(cond (cond
[(reg? an-input) [(Reg? an-input)
(assemble-reg an-input)] (assemble-reg an-input)]
[(const? an-input) [(Const? an-input)
(assemble-const an-input)] (assemble-const an-input)]
[(label? an-input) [(Label? an-input)
(assemble-label an-input)] (assemble-label an-input)]))
[else (error 'assemble-input "~e" an-input)]))
(: assemble-location ((U Reg Label) -> String))
(define (assemble-location a-location) (define (assemble-location a-location)
(cond (cond
[(reg? a-location) [(Reg? a-location)
(assemble-reg a-location)] (assemble-reg a-location)]
[(label? a-location) [(Label? a-location)
(assemble-label a-location)] (assemble-label a-location)]))
[else (error 'assemble-location "~e" a-location)]))
(: assemble-reg (Reg -> String))
(define (assemble-reg a-reg) (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) (define (assemble-label a-label)
(symbol->string (label-name a-label))) (symbol->string (Label-name a-label)))

5
typed-structs.rkt
View File

@ -30,6 +30,7 @@
;; instruction sequences ;; instruction sequences
(define-type Statement (U Symbol ;; label (define-type Statement (U Symbol ;; label
AssignImmediateStatement AssignImmediateStatement
@ -102,5 +103,5 @@
(define-struct: basic-block ([name : Symbol] (define-struct: BasicBlock ([name : Symbol]
[stmts : (Listof Statement)]) #:transparent) [stmts : (Listof Statement)]) #:transparent)