simplifying structure a little
This commit is contained in:
Danny Yoo
parent
d29a96022c
commit
c9066c2654
28
assemble.rkt
28
assemble.rkt
|
|
@ -7,6 +7,7 @@
|
|||
|
||||
|
||||
;; assemble/write-invoke: (listof statement) output-port -> void
|
||||
(: assemble/write-invoke ((Listof Statement) Output-Port -> Void))
|
||||
(define (assemble/write-invoke stmts op)
|
||||
(let ([basic-blocks (fracture stmts)])
|
||||
(fprintf op "function(k) {\n")
|
||||
|
|
@ -22,6 +23,7 @@
|
|||
|
||||
|
||||
;; fracture: (listof stmt) -> (listof basic-block)
|
||||
(: fracture ((Listof Statement) -> (Listof BasicBlock)))
|
||||
(define (fracture stmts)
|
||||
(let* ([first-block-label (make-label 'start)]
|
||||
[jump-targets
|
||||
|
|
@ -43,7 +45,7 @@
|
|||
(cons (make-basic-block name
|
||||
(if last-stmt-goto?
|
||||
(reverse acc)
|
||||
(reverse (append `((goto (label ,(car stmts))))
|
||||
(reverse (append `(,(make-GotoStatement (make-Label (car stmts))))
|
||||
acc))))
|
||||
basic-blocks)
|
||||
(cdr stmts)
|
||||
|
|
@ -59,11 +61,12 @@
|
|||
(cons (car stmts) acc)
|
||||
basic-blocks
|
||||
(cdr stmts)
|
||||
(tagged-list? (car stmts) 'goto))]))))
|
||||
(GotoStatement? (car stmts)))]))))
|
||||
|
||||
|
||||
|
||||
;; unique: (listof symbol -> listof symbol)
|
||||
(: unique ((Listof symbol) -> (Listof Symbol)))
|
||||
(define (unique los)
|
||||
(let ([ht (make-hasheq)])
|
||||
(for ([l los])
|
||||
|
|
@ -74,22 +77,23 @@
|
|||
|
||||
;; collect-general-jump-targets: (listof stmt) -> (listof label)
|
||||
;; 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-input an-input)
|
||||
(cond
|
||||
[(reg? an-input)
|
||||
[(Reg? an-input)
|
||||
empty]
|
||||
[(const? an-input)
|
||||
[(Const? an-input)
|
||||
empty]
|
||||
[(label? an-input)
|
||||
(list (label-name an-input))]
|
||||
[(Label? an-input)
|
||||
(list (Label-name an-input))]
|
||||
[else (error 'collect-input "~e" an-input)]))
|
||||
(define (collect-location a-location)
|
||||
(cond
|
||||
[(reg? a-location)
|
||||
[(Reg? a-location)
|
||||
empty]
|
||||
[(label? a-location)
|
||||
(list (label-name a-location))]
|
||||
[(Label? a-location)
|
||||
(list (Label-name a-location))]
|
||||
[else (error 'collect-location "~e" a-location)]))
|
||||
(unique
|
||||
(let loop ([stmts stmts])
|
||||
|
|
@ -135,7 +139,8 @@
|
|||
;; indirect jumps.
|
||||
;; The only interesting case should be where there's a register assignment
|
||||
;; 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)
|
||||
(cond
|
||||
[(reg? an-input)
|
||||
|
|
@ -196,6 +201,7 @@
|
|||
|
||||
|
||||
;; assemble-basic-block: basic-block -> string
|
||||
(: 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)
|
||||
|
|
@ -205,6 +211,7 @@
|
|||
|
||||
|
||||
;; assemble-stmt: stmt -> string
|
||||
(: assemble-stmt (Statement -> String))
|
||||
(define (assemble-stmt stmt)
|
||||
(cond
|
||||
[(tagged-list? stmt 'assign)
|
||||
|
|
@ -250,6 +257,7 @@
|
|||
[else (error 'assemble "~a" stmt)]))
|
||||
|
||||
;; fixme: use js->string
|
||||
(: Assemble-Const (Any -> String))
|
||||
(define (assemble-const stmt)
|
||||
(let loop ([val (cadr stmt)])
|
||||
(cond [(symbol? val)
|
||||
|
|
|
|||
18
compile.rkt
18
compile.rkt
|
|
@ -100,7 +100,7 @@
|
|||
(make-instruction-sequence
|
||||
'()
|
||||
(list target)
|
||||
`(,(make-AssignConstantStatement target exp)))))
|
||||
`(,(make-AssignImmediateStatement target (make-Const exp))))))
|
||||
|
||||
(: compile-quoted (Quote CompileTimeEnvironment Target Linkage -> InstructionSequence))
|
||||
(define (compile-quoted exp cenv target linkage)
|
||||
|
|
@ -108,7 +108,7 @@
|
|||
(make-instruction-sequence
|
||||
'()
|
||||
(list target)
|
||||
`(,(make-AssignConstantStatement target (Quote-text exp))))))
|
||||
`(,(make-AssignImmediateStatement target (make-Const (Quote-text exp)))))))
|
||||
|
||||
(: compile-variable (Var CompileTimeEnvironment Target Linkage -> InstructionSequence))
|
||||
(define (compile-variable exp cenv target linkage)
|
||||
|
|
@ -160,7 +160,7 @@
|
|||
(list (make-Const var)
|
||||
(make-Reg 'val)
|
||||
(make-Reg 'env)))
|
||||
,(make-AssignConstantStatement target 'ok)))))]
|
||||
,(make-AssignImmediateStatement target (make-Const 'ok))))))]
|
||||
[else
|
||||
(end-with-linkage
|
||||
linkage
|
||||
|
|
@ -174,7 +174,7 @@
|
|||
(make-Const (second lexical-address))
|
||||
(make-Reg 'env)
|
||||
(make-Reg 'val)))
|
||||
,(make-AssignConstantStatement target 'ok)))))])))
|
||||
,(make-AssignImmediateStatement target (make-Const 'ok))))))])))
|
||||
|
||||
|
||||
;; FIXME: exercise 5.43
|
||||
|
|
@ -195,7 +195,7 @@
|
|||
(list (make-Const var)
|
||||
(make-Reg 'val)
|
||||
(make-Reg 'env)))
|
||||
,(make-AssignConstantStatement target 'ok)))))))
|
||||
,(make-AssignImmediateStatement target (make-Const 'ok))))))))
|
||||
|
||||
|
||||
(: compile-if (Branch CompileTimeEnvironment Target Linkage -> InstructionSequence))
|
||||
|
|
@ -297,7 +297,7 @@
|
|||
(if (null? operand-codes)
|
||||
(make-instruction-sequence '()
|
||||
'(argl)
|
||||
`(,(make-AssignConstantStatement 'argl '())))
|
||||
`(,(make-AssignImmediateStatement 'argl (make-Const '()))))
|
||||
(let ([code-to-get-last-arg
|
||||
(append-instruction-sequences
|
||||
(car operand-codes)
|
||||
|
|
@ -362,7 +362,7 @@
|
|||
(make-instruction-sequence
|
||||
'(proc)
|
||||
all-regs
|
||||
`(,(make-AssignLabelStatement 'cont linkage)
|
||||
`(,(make-AssignImmediateStatement 'cont (make-Label linkage))
|
||||
,(make-AssignPrimOpStatement 'val 'compiled-procedure-entry
|
||||
(list (make-Reg 'proc)))
|
||||
,(make-GotoStatement (make-Reg 'val))))]
|
||||
|
|
@ -372,12 +372,12 @@
|
|||
(make-instruction-sequence
|
||||
'(proc)
|
||||
all-regs
|
||||
`(,(make-AssignLabelStatement 'cont proc-return)
|
||||
`(,(make-AssignImmediateStatement 'cont (make-Label proc-return))
|
||||
,(make-AssignPrimOpStatement 'val 'compiled-procedure-entry
|
||||
(list (make-Reg 'proc)))
|
||||
,(make-GotoStatement (make-Reg 'val))
|
||||
,proc-return
|
||||
,(make-AssignRegisterStatement target 'val)
|
||||
,(make-AssignImmediateStatement target (make-Reg 'val))
|
||||
,(make-GotoStatement (make-Label linkage)))))]
|
||||
[(and (eq? target 'val)
|
||||
(eq? linkage 'return))
|
||||
|
|
|
|||
|
|
@ -32,9 +32,7 @@
|
|||
|
||||
;; instruction sequences
|
||||
(define-type Statement (U Symbol ;; label
|
||||
AssignConstantStatement
|
||||
AssignLabelStatement
|
||||
AssignRegisterStatement
|
||||
AssignImmediateStatement
|
||||
AssignPrimOpStatement
|
||||
PerformStatement
|
||||
TestStatement
|
||||
|
|
@ -42,14 +40,8 @@
|
|||
GotoStatement
|
||||
SaveStatement
|
||||
RestoreStatement))
|
||||
(define-struct: AssignConstantStatement ([target : Symbol]
|
||||
[value : Any])
|
||||
#:transparent)
|
||||
(define-struct: AssignRegisterStatement ([target : Symbol]
|
||||
[reg : Symbol])
|
||||
#:transparent)
|
||||
(define-struct: AssignLabelStatement ([target : Symbol]
|
||||
[label : Symbol])
|
||||
(define-struct: AssignImmediateStatement ([target : Symbol]
|
||||
[value : (U Const Reg Label)])
|
||||
#:transparent)
|
||||
(define-struct: AssignPrimOpStatement ([target : 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)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user