Merge remote branch 'origin/master'
This commit is contained in:
Danny Yoo
commit
79074ccecb
228
assemble.rkt
228
assemble.rkt
|
|
@ -1,5 +1,5 @@
|
|||
#lang racket/base
|
||||
(require "structs.rkt"
|
||||
#lang typed/racket/base
|
||||
(require "typed-structs.rkt"
|
||||
racket/string
|
||||
racket/list)
|
||||
|
||||
|
|
@ -7,43 +7,46 @@
|
|||
|
||||
|
||||
;; 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")
|
||||
(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)))))
|
||||
|
||||
|
||||
|
||||
|
||||
;; fracture: (listof stmt) -> (listof basic-block)
|
||||
(: fracture ((Listof Statement) -> (Listof BasicBlock)))
|
||||
(define (fracture stmts)
|
||||
(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 UnlabeledStatement) '()]
|
||||
[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 `((goto (label ,(car stmts))))
|
||||
(reverse (append `(,(make-GotoStatement (make-Label (car stmts))))
|
||||
acc))))
|
||||
basic-blocks)
|
||||
(cdr stmts)
|
||||
|
|
@ -59,37 +62,39 @@
|
|||
(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)])
|
||||
(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)
|
||||
;; 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])
|
||||
|
|
@ -100,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))))]))))
|
||||
|
||||
|
||||
|
|
@ -135,7 +137,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,70 +199,75 @@
|
|||
|
||||
|
||||
;; 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)
|
||||
(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")))
|
||||
|
||||
|
||||
;; assemble-stmt: stmt -> string
|
||||
(: assemble-stmt (UnlabeledStatement -> 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 (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
|
||||
|
|
@ -280,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"]
|
||||
|
|
@ -311,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
|
||||
|
|
@ -341,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)))
|
||||
(symbol->string (Label-name a-label)))
|
||||
|
|
@ -1,7 +1,6 @@
|
|||
#lang typed/racket/base
|
||||
|
||||
(require "typed-structs.rkt"
|
||||
#;"assemble.rkt"
|
||||
racket/list)
|
||||
|
||||
(provide compile)
|
||||
|
|
@ -19,6 +18,8 @@
|
|||
(define-type CompileTimeEnvironment (Listof (Listof Symbol)))
|
||||
(define-type LexicalAddress (U (List Number Number) 'not-found))
|
||||
|
||||
|
||||
|
||||
;; find-variable: symbol compile-time-environment -> lexical-address
|
||||
;; Find where the variable should be located.
|
||||
(: find-variable (Symbol CompileTimeEnvironment -> LexicalAddress))
|
||||
|
|
@ -80,12 +81,12 @@
|
|||
(define (compile-linkage linkage)
|
||||
(cond
|
||||
[(eq? linkage 'return)
|
||||
(make-instruction-sequence '(cont) '() '((goto (reg cont))))]
|
||||
(make-instruction-sequence '(cont) '() `(,(make-GotoStatement (make-Reg 'cont))))]
|
||||
[(eq? linkage 'next)
|
||||
empty-instruction-sequence]
|
||||
[else
|
||||
(make-instruction-sequence '() '()
|
||||
`((goto (label ,linkage))))]))
|
||||
`(,(make-GotoStatement (make-Label linkage))))]))
|
||||
|
||||
(: end-with-linkage (Linkage InstructionSequence -> InstructionSequence))
|
||||
(define (end-with-linkage linkage instruction-sequence)
|
||||
|
|
@ -99,7 +100,7 @@
|
|||
(make-instruction-sequence
|
||||
'()
|
||||
(list target)
|
||||
`((assign ,target (const ,exp))))))
|
||||
`(,(make-AssignImmediateStatement target (make-Const exp))))))
|
||||
|
||||
(: compile-quoted (Quote CompileTimeEnvironment Target Linkage -> InstructionSequence))
|
||||
(define (compile-quoted exp cenv target linkage)
|
||||
|
|
@ -107,7 +108,7 @@
|
|||
(make-instruction-sequence
|
||||
'()
|
||||
(list target)
|
||||
`((assign ,target (const ,(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)
|
||||
|
|
@ -120,23 +121,23 @@
|
|||
(list target)
|
||||
;; Slight modification: explicitly testing for
|
||||
;; global variable binding before lookup.
|
||||
`((perform (op check-bound-global!)
|
||||
(const ,(Var-id exp))
|
||||
(reg env))
|
||||
(assign ,target
|
||||
(op lookup-variable-value)
|
||||
(const ,(Var-id exp))
|
||||
(reg env)))))]
|
||||
`(,(make-PerformStatement 'check-bound-global!
|
||||
(list (make-Const (Var-id exp))
|
||||
(make-Reg 'env)))
|
||||
,(make-AssignPrimOpStatement target
|
||||
'lookup-variable-value
|
||||
(list (make-Const (Var-id exp))
|
||||
(make-Reg 'env))))))]
|
||||
[else
|
||||
(end-with-linkage linkage
|
||||
(make-instruction-sequence
|
||||
'(env)
|
||||
(list target)
|
||||
`((assign ,target
|
||||
(op lexical-address-lookup)
|
||||
(const ,(first lexical-pos))
|
||||
(const ,(second lexical-pos))
|
||||
(reg env)))))])))
|
||||
`(,(make-AssignPrimOpStatement target
|
||||
'lexical-address-lookup
|
||||
(list (make-Const (first lexical-pos))
|
||||
(make-Const (second lexical-pos))
|
||||
(make-Reg 'env))))))])))
|
||||
|
||||
|
||||
(: compile-assignment (Assign CompileTimeEnvironment Target Linkage -> InstructionSequence))
|
||||
|
|
@ -155,11 +156,11 @@
|
|||
(make-instruction-sequence
|
||||
'(env val)
|
||||
(list target)
|
||||
`((perform (op set-variable-value!)
|
||||
(const ,var)
|
||||
(reg val)
|
||||
(reg env))
|
||||
(assign ,target (const ok))))))]
|
||||
`(,(make-PerformStatement 'set-variable-value!
|
||||
(list (make-Const var)
|
||||
(make-Reg 'val)
|
||||
(make-Reg 'env)))
|
||||
,(make-AssignImmediateStatement target (make-Const 'ok))))))]
|
||||
[else
|
||||
(end-with-linkage
|
||||
linkage
|
||||
|
|
@ -168,12 +169,12 @@
|
|||
(make-instruction-sequence
|
||||
'(env val)
|
||||
(list target)
|
||||
`((perform (op lexical-address-set!)
|
||||
(const ,(first lexical-address))
|
||||
(const ,(second lexical-address))
|
||||
(reg env)
|
||||
(reg val))
|
||||
(assign ,target (const ok))))))])))
|
||||
`(,(make-PerformStatement 'lexical-address-set!
|
||||
(list (make-Const (first lexical-address))
|
||||
(make-Const (second lexical-address))
|
||||
(make-Reg 'env)
|
||||
(make-Reg 'val)))
|
||||
,(make-AssignImmediateStatement target (make-Const 'ok))))))])))
|
||||
|
||||
|
||||
;; FIXME: exercise 5.43
|
||||
|
|
@ -190,11 +191,11 @@
|
|||
(make-instruction-sequence
|
||||
'(env val)
|
||||
(list target)
|
||||
`((perform (op define-variable!)
|
||||
(const ,var)
|
||||
(reg val)
|
||||
(reg env))
|
||||
(assign ,target (const ok))))))))
|
||||
`(,(make-PerformStatement 'define-variable!
|
||||
(list (make-Const var)
|
||||
(make-Reg 'val)
|
||||
(make-Reg 'env)))
|
||||
,(make-AssignImmediateStatement target (make-Const 'ok))))))))
|
||||
|
||||
|
||||
(: compile-if (Branch CompileTimeEnvironment Target Linkage -> InstructionSequence))
|
||||
|
|
@ -215,8 +216,8 @@
|
|||
(make-instruction-sequence
|
||||
'(val)
|
||||
'()
|
||||
`((test (op false?) (reg val))
|
||||
(branch (label ,f-branch))))
|
||||
`(,(make-TestStatement 'false? 'val)
|
||||
,(make-BranchLabelStatement f-branch)))
|
||||
(parallel-instruction-sequences
|
||||
(append-instruction-sequences t-branch c-code)
|
||||
(append-instruction-sequences f-branch a-code))
|
||||
|
|
@ -246,16 +247,16 @@
|
|||
(make-instruction-sequence
|
||||
'(env)
|
||||
(list target)
|
||||
`((assign ,target
|
||||
(op make-compiled-procedure)
|
||||
(label ,proc-entry)
|
||||
;; TODO: rather than capture the whole
|
||||
;; environment, we may instead
|
||||
;; just capture the free variables.
|
||||
;; But that requires that we box
|
||||
;; up all set!-ed variables, in order
|
||||
;; to preserve semantics of set!
|
||||
(reg env)))))
|
||||
`(,(make-AssignPrimOpStatement target
|
||||
'make-compiled-procedure
|
||||
(list (make-Label proc-entry)
|
||||
;; TODO: rather than capture the whole
|
||||
;; environment, we may instead
|
||||
;; just capture the free variables.
|
||||
;; But that requires that we box
|
||||
;; up all set!-ed variables, in order
|
||||
;; to preserve semantics of set!
|
||||
(make-Reg 'env))))))
|
||||
(compile-lambda-body exp cenv
|
||||
proc-entry))
|
||||
after-lambda))))
|
||||
|
|
@ -269,11 +270,13 @@
|
|||
'(env proc argl)
|
||||
'(env)
|
||||
`(,proc-entry
|
||||
(assign env (op compiled-procedure-env) (reg proc))
|
||||
(assign env
|
||||
(op extend-environment)
|
||||
(reg argl)
|
||||
(reg env))))
|
||||
,(make-AssignPrimOpStatement 'env
|
||||
'compiled-procedure-env
|
||||
(list (make-Reg 'proc)))
|
||||
,(make-AssignPrimOpStatement 'env
|
||||
'extend-environment
|
||||
(list (make-Reg 'argl)
|
||||
(make-Reg 'env)))))
|
||||
(compile-sequence (Lam-body exp) extended-cenv 'val 'return))))
|
||||
|
||||
(: compile-application (App CompileTimeEnvironment Target Linkage -> InstructionSequence))
|
||||
|
|
@ -294,12 +297,13 @@
|
|||
(if (null? operand-codes)
|
||||
(make-instruction-sequence '()
|
||||
'(argl)
|
||||
'((assign argl (const ()))))
|
||||
`(,(make-AssignImmediateStatement 'argl (make-Const '()))))
|
||||
(let ([code-to-get-last-arg
|
||||
(append-instruction-sequences
|
||||
(car operand-codes)
|
||||
(make-instruction-sequence '(val) '(argl)
|
||||
'((assign argl (op list) (reg val)))))])
|
||||
`(,(make-AssignPrimOpStatement 'argl 'list
|
||||
(list (make-Reg 'val))))))])
|
||||
(if (null? (cdr operand-codes))
|
||||
code-to-get-last-arg
|
||||
(preserving '(env)
|
||||
|
|
@ -314,7 +318,10 @@
|
|||
(make-instruction-sequence
|
||||
'(val argl)
|
||||
'(argl)
|
||||
'((assign argl (op cons) (reg val) (reg argl)))))])
|
||||
`(,(make-AssignPrimOpStatement 'argl
|
||||
'cons
|
||||
(list (make-Reg 'val)
|
||||
(make-Reg 'argl))))))])
|
||||
(if (null? (cdr operand-codes))
|
||||
code-for-next-arg
|
||||
(preserving '(env)
|
||||
|
|
@ -330,8 +337,8 @@
|
|||
(if (eq? linkage 'next) after-call linkage)])
|
||||
(append-instruction-sequences
|
||||
(make-instruction-sequence '(proc) '()
|
||||
`((test (op primitive-procedure?) (reg proc))
|
||||
(branch (label ,primitive-branch))))
|
||||
`(,(make-TestStatement 'primitive-procedure? 'proc)
|
||||
,(make-BranchLabelStatement primitive-branch)))
|
||||
(parallel-instruction-sequences
|
||||
(append-instruction-sequences
|
||||
compiled-branch
|
||||
|
|
@ -342,10 +349,10 @@
|
|||
(make-instruction-sequence
|
||||
'(proc argl)
|
||||
(list target)
|
||||
`((assign ,target
|
||||
(op apply-primitive-procedure)
|
||||
(reg proc)
|
||||
(reg argl)))))))
|
||||
`(,(make-AssignPrimOpStatement target
|
||||
'apply-primitive-procedure
|
||||
(list (make-Reg 'proc)
|
||||
(make-Reg 'argl))))))))
|
||||
after-call))))
|
||||
|
||||
(: compile-proc-appl (Target Linkage -> InstructionSequence))
|
||||
|
|
@ -355,31 +362,31 @@
|
|||
(make-instruction-sequence
|
||||
'(proc)
|
||||
all-regs
|
||||
`((assign cont (label ,linkage))
|
||||
(assign val (op compiled-procedure-entry)
|
||||
(reg proc))
|
||||
(goto (reg val))))]
|
||||
`(,(make-AssignImmediateStatement 'cont (make-Label linkage))
|
||||
,(make-AssignPrimOpStatement 'val 'compiled-procedure-entry
|
||||
(list (make-Reg 'proc)))
|
||||
,(make-GotoStatement (make-Reg 'val))))]
|
||||
[(and (not (eq? target 'val))
|
||||
(not (eq? linkage 'return)))
|
||||
(let ([proc-return (make-label 'procReturn)])
|
||||
(make-instruction-sequence
|
||||
'(proc)
|
||||
all-regs
|
||||
`((assign cont (label ,proc-return))
|
||||
(assign val (op compiled-procedure-entry)
|
||||
(reg proc))
|
||||
(goto (reg val))
|
||||
`(,(make-AssignImmediateStatement 'cont (make-Label proc-return))
|
||||
,(make-AssignPrimOpStatement 'val 'compiled-procedure-entry
|
||||
(list (make-Reg 'proc)))
|
||||
,(make-GotoStatement (make-Reg 'val))
|
||||
,proc-return
|
||||
(assign ,target (reg val))
|
||||
(goto (label ,linkage)))))]
|
||||
,(make-AssignImmediateStatement target (make-Reg 'val))
|
||||
,(make-GotoStatement (make-Label linkage)))))]
|
||||
[(and (eq? target 'val)
|
||||
(eq? linkage 'return))
|
||||
(make-instruction-sequence
|
||||
'(proc cont)
|
||||
all-regs
|
||||
'((assign val (op compiled-procedure-entry)
|
||||
(reg proc))
|
||||
(goto (reg val))))]
|
||||
`(,(make-AssignPrimOpStatement 'val 'compiled-procedure-entry
|
||||
(list (make-Reg 'proc)))
|
||||
,(make-GotoStatement (make-Reg 'val))))]
|
||||
[(and (not (eq? target 'val))
|
||||
(eq? linkage 'return))
|
||||
(error 'compile "return linkage, target not val: ~s" target)]))
|
||||
|
|
@ -413,9 +420,9 @@
|
|||
(registers-needed seq1))
|
||||
(list-difference (registers-modified seq1)
|
||||
(list first-reg))
|
||||
(append `((save ,first-reg))
|
||||
(append `(,(make-SaveStatement first-reg))
|
||||
(statements seq1)
|
||||
`((restore ,first-reg))))
|
||||
`(,(make-RestoreStatement first-reg))))
|
||||
seq2)
|
||||
(preserving (cdr regs) seq1 seq2)))))
|
||||
|
||||
|
|
@ -30,11 +30,50 @@
|
|||
|
||||
|
||||
|
||||
|
||||
;; instruction sequences
|
||||
(define-type UnlabeledStatement (U
|
||||
AssignImmediateStatement
|
||||
AssignPrimOpStatement
|
||||
PerformStatement
|
||||
TestStatement
|
||||
BranchLabelStatement
|
||||
GotoStatement
|
||||
SaveStatement
|
||||
RestoreStatement))
|
||||
(define-type Statement (U UnlabeledStatement
|
||||
Symbol ;; label
|
||||
))
|
||||
(define-struct: AssignImmediateStatement ([target : Symbol]
|
||||
[value : (U Const Reg Label)])
|
||||
#:transparent)
|
||||
(define-struct: AssignPrimOpStatement ([target : Symbol]
|
||||
[op : Symbol]
|
||||
[rands : (Listof (U Label Reg Const))])
|
||||
#:transparent)
|
||||
(define-struct: PerformStatement ([op : Symbol]
|
||||
[rands : (Listof (U Label Reg Const))]) #:transparent)
|
||||
(define-struct: TestStatement ([op : (U 'false? 'primitive-procedure?)]
|
||||
[register-rand : Symbol]) #:transparent)
|
||||
(define-struct: BranchLabelStatement ([label : Symbol]) #:transparent)
|
||||
(define-struct: GotoStatement ([target : (U Label Reg)]) #:transparent)
|
||||
(define-struct: SaveStatement ([reg : Symbol]) #:transparent)
|
||||
(define-struct: RestoreStatement ([reg : Symbol]) #:transparent)
|
||||
|
||||
(define-struct: Label ([name : Symbol]))
|
||||
(define-struct: Reg ([name : Symbol]))
|
||||
(define-struct: Const ([const : Any]))
|
||||
|
||||
(define-type OpArg (U Const Label Reg))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
(define-type InstructionSequence (U Symbol instruction-sequence))
|
||||
(define-struct: instruction-sequence ([needs : (Listof Symbol)]
|
||||
[modifies : (Listof Symbol)]
|
||||
[statements : (Listof Any)]) #:transparent)
|
||||
[statements : (Listof Statement)]) #:transparent)
|
||||
(define empty-instruction-sequence (make-instruction-sequence '() '() '()))
|
||||
|
||||
(: make-label (Symbol -> Symbol))
|
||||
|
|
@ -53,7 +92,7 @@
|
|||
(define (registers-modified s)
|
||||
(if (symbol? s) '() (instruction-sequence-modifies s)))
|
||||
|
||||
(: statements (InstructionSequence -> (Listof Any)))
|
||||
(: statements (InstructionSequence -> (Listof Statement)))
|
||||
(define (statements s)
|
||||
(if (symbol? s) (list s) (instruction-sequence-statements s)))
|
||||
|
||||
|
|
@ -63,4 +102,9 @@
|
|||
(define-type Target Symbol)
|
||||
|
||||
;; Linkage
|
||||
(define-type Linkage (U 'return 'next Symbol))
|
||||
(define-type Linkage (U 'return 'next Symbol))
|
||||
|
||||
|
||||
|
||||
(define-struct: BasicBlock ([name : Symbol]
|
||||
[stmts : (Listof UnlabeledStatement)]) #:transparent)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user