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

simplifying structure a little

Browse Source
This commit is contained in:
Danny Yoo 2011-02-20 16:32:12 -05:00
parent d29a96022c
commit c9066c2654
3 changed files with 32 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
assemble.rkt
View File

@ -7,6 +7,7 @@
;; assemble/write-invoke: (listof statement) output-port -> void ;; assemble/write-invoke: (listof statement) output-port -> void
(: assemble/write-invoke ((Listof Statement) Output-Port -> Void))
(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")
@ -22,6 +23,7 @@
;; fracture: (listof stmt) -> (listof basic-block) ;; fracture: (listof stmt) -> (listof basic-block)
(: fracture ((Listof Statement) -> (Listof BasicBlock)))
(define (fracture stmts) (define (fracture stmts)
(let* ([first-block-label (make-label 'start)] (let* ([first-block-label (make-label 'start)]
[jump-targets [jump-targets
@ -43,7 +45,7 @@
(cons (make-basic-block name (cons (make-basic-block name
(if last-stmt-goto? (if last-stmt-goto?
(reverse acc) (reverse acc)
(reverse (append `((goto (label ,(car stmts)))) (reverse (append `(,(make-GotoStatement (make-Label (car stmts))))
acc)))) acc))))
basic-blocks) basic-blocks)
(cdr stmts) (cdr stmts)
@ -59,11 +61,12 @@
(cons (car stmts) acc) (cons (car stmts) acc)
basic-blocks basic-blocks
(cdr stmts) (cdr stmts)
(tagged-list? (car stmts) 'goto))])))) (GotoStatement? (car stmts)))]))))
;; 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 (make-hasheq)])
(for ([l los]) (for ([l los])
@ -74,22 +77,23 @@
;; collect-general-jump-targets: (listof stmt) -> (listof label) ;; collect-general-jump-targets: (listof stmt) -> (listof label)
;; collects all the labels that are potential targets for GOTOs or branches. ;; collects all the labels that are potential targets for GOTOs or branches.
(: collect-general-jump-targets ((Listof Statement) -> (Listof Symbol)))
(define (collect-general-jump-targets stmts) (define (collect-general-jump-targets stmts)
(define (collect-input an-input) (define (collect-input an-input)
(cond (cond
[(reg? an-input) [(Reg? an-input)
empty] empty]
[(const? an-input) [(Const? an-input)
empty] empty]
[(label? an-input) [(Label? an-input)
(list (label-name an-input))] (list (Label-name an-input))]
[else (error 'collect-input "~e" an-input)])) [else (error 'collect-input "~e" an-input)]))
(define (collect-location a-location) (define (collect-location a-location)
(cond (cond
[(reg? a-location) [(Reg? a-location)
empty] empty]
[(label? a-location) [(Label? a-location)
(list (label-name a-location))] (list (Label-name a-location))]
[else (error 'collect-location "~e" a-location)])) [else (error 'collect-location "~e" a-location)]))
(unique (unique
(let loop ([stmts stmts]) (let loop ([stmts stmts])
@ -135,7 +139,8 @@
;; indirect jumps. ;; indirect jumps.
;; The only interesting case should be where there's a register assignment ;; The only interesting case should be where there's a register assignment
;; whose value is a label. ;; whose value is a label.
(define (collect-indirect-jump-targets stmts) #;(: collect-indirect-jump-targets ((Listof Statement) -> (Listof Symbol)))
#;(define (collect-indirect-jump-targets stmts)
(define (collect-input an-input) (define (collect-input an-input)
(cond (cond
[(reg? an-input) [(reg? an-input)
@ -196,6 +201,7 @@
;; assemble-basic-block: basic-block -> string ;; assemble-basic-block: basic-block -> 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) (basic-block-name a-basic-block)
@ -205,6 +211,7 @@
;; assemble-stmt: stmt -> string ;; assemble-stmt: stmt -> string
(: assemble-stmt (Statement -> String))
(define (assemble-stmt stmt) (define (assemble-stmt stmt)
(cond (cond
[(tagged-list? stmt 'assign) [(tagged-list? stmt 'assign)
@ -250,6 +257,7 @@
[else (error 'assemble "~a" stmt)])) [else (error 'assemble "~a" stmt)]))
;; fixme: use js->string ;; fixme: use js->string
(: Assemble-Const (Any -> String))
(define (assemble-const stmt) (define (assemble-const stmt)
(let loop ([val (cadr stmt)]) (let loop ([val (cadr stmt)])
(cond [(symbol? val) (cond [(symbol? val)

18
compile.rkt
View File

@ -100,7 +100,7 @@
(make-instruction-sequence (make-instruction-sequence
'() '()
(list target) (list target)
`(,(make-AssignConstantStatement target exp))))) `(,(make-AssignImmediateStatement target (make-Const exp))))))
(: compile-quoted (Quote CompileTimeEnvironment Target Linkage -> InstructionSequence)) (: compile-quoted (Quote CompileTimeEnvironment Target Linkage -> InstructionSequence))
(define (compile-quoted exp cenv target linkage) (define (compile-quoted exp cenv target linkage)
@ -108,7 +108,7 @@
(make-instruction-sequence (make-instruction-sequence
'() '()
(list target) (list target)
`(,(make-AssignConstantStatement target (Quote-text exp)))))) `(,(make-AssignImmediateStatement target (make-Const (Quote-text exp)))))))
(: compile-variable (Var CompileTimeEnvironment Target Linkage -> InstructionSequence)) (: compile-variable (Var CompileTimeEnvironment Target Linkage -> InstructionSequence))
(define (compile-variable exp cenv target linkage) (define (compile-variable exp cenv target linkage)
@ -160,7 +160,7 @@
(list (make-Const var) (list (make-Const var)
(make-Reg 'val) (make-Reg 'val)
(make-Reg 'env))) (make-Reg 'env)))
,(make-AssignConstantStatement target 'ok)))))] ,(make-AssignImmediateStatement target (make-Const 'ok))))))]
[else [else
(end-with-linkage (end-with-linkage
linkage linkage
@ -174,7 +174,7 @@
(make-Const (second lexical-address)) (make-Const (second lexical-address))
(make-Reg 'env) (make-Reg 'env)
(make-Reg 'val))) (make-Reg 'val)))
,(make-AssignConstantStatement target 'ok)))))]))) ,(make-AssignImmediateStatement target (make-Const 'ok))))))])))
;; FIXME: exercise 5.43 ;; FIXME: exercise 5.43
@ -195,7 +195,7 @@
(list (make-Const var) (list (make-Const var)
(make-Reg 'val) (make-Reg 'val)
(make-Reg 'env))) (make-Reg 'env)))
,(make-AssignConstantStatement target 'ok))))))) ,(make-AssignImmediateStatement target (make-Const 'ok))))))))
(: compile-if (Branch CompileTimeEnvironment Target Linkage -> InstructionSequence)) (: compile-if (Branch CompileTimeEnvironment Target Linkage -> InstructionSequence))
@ -297,7 +297,7 @@
(if (null? operand-codes) (if (null? operand-codes)
(make-instruction-sequence '() (make-instruction-sequence '()
'(argl) '(argl)
`(,(make-AssignConstantStatement 'argl '()))) `(,(make-AssignImmediateStatement 'argl (make-Const '()))))
(let ([code-to-get-last-arg (let ([code-to-get-last-arg
(append-instruction-sequences (append-instruction-sequences
(car operand-codes) (car operand-codes)
@ -362,7 +362,7 @@
(make-instruction-sequence (make-instruction-sequence
'(proc) '(proc)
all-regs all-regs
`(,(make-AssignLabelStatement 'cont linkage) `(,(make-AssignImmediateStatement 'cont (make-Label linkage))
,(make-AssignPrimOpStatement 'val 'compiled-procedure-entry ,(make-AssignPrimOpStatement 'val 'compiled-procedure-entry
(list (make-Reg 'proc))) (list (make-Reg 'proc)))
,(make-GotoStatement (make-Reg 'val))))] ,(make-GotoStatement (make-Reg 'val))))]
@ -372,12 +372,12 @@
(make-instruction-sequence (make-instruction-sequence
'(proc) '(proc)
all-regs all-regs
`(,(make-AssignLabelStatement 'cont proc-return) `(,(make-AssignImmediateStatement 'cont (make-Label proc-return))
,(make-AssignPrimOpStatement 'val 'compiled-procedure-entry ,(make-AssignPrimOpStatement 'val 'compiled-procedure-entry
(list (make-Reg 'proc))) (list (make-Reg 'proc)))
,(make-GotoStatement (make-Reg 'val)) ,(make-GotoStatement (make-Reg 'val))
,proc-return ,proc-return
,(make-AssignRegisterStatement target 'val) ,(make-AssignImmediateStatement target (make-Reg 'val))
,(make-GotoStatement (make-Label linkage)))))] ,(make-GotoStatement (make-Label linkage)))))]
[(and (eq? target 'val) [(and (eq? target 'val)
(eq? linkage 'return)) (eq? linkage 'return))

17
typed-structs.rkt
View File

@ -32,9 +32,7 @@
;; instruction sequences ;; instruction sequences
(define-type Statement (U Symbol ;; label (define-type Statement (U Symbol ;; label
AssignConstantStatement AssignImmediateStatement
AssignLabelStatement
AssignRegisterStatement
AssignPrimOpStatement AssignPrimOpStatement
PerformStatement PerformStatement
TestStatement TestStatement
@ -42,14 +40,8 @@
GotoStatement GotoStatement
SaveStatement SaveStatement
RestoreStatement)) RestoreStatement))
(define-struct: AssignConstantStatement ([target : Symbol] (define-struct: AssignImmediateStatement ([target : Symbol]
[value : Any]) [value : (U Const Reg Label)])
#:transparent)
(define-struct: AssignRegisterStatement ([target : Symbol]
[reg : Symbol])
#:transparent)
(define-struct: AssignLabelStatement ([target : Symbol]
[label : Symbol])
#:transparent) #:transparent)
(define-struct: AssignPrimOpStatement ([target : Symbol] (define-struct: AssignPrimOpStatement ([target : Symbol]
[op : Symbol] [op : Symbol]
@ -110,4 +102,5 @@
(define-struct: basic-block ([name : Symbol] [stmts : (Listof Statement)]) #:transparent) (define-struct: basic-block ([name : Symbol]
[stmts : (Listof Statement)]) #:transparent)