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

adjusted compile to typecheck

Browse Source
This commit is contained in:
Danny Yoo 2011-02-20 16:09:33 -05:00
parent 03b2a0eae8
commit d29a96022c
2 changed files with 112 additions and 82 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

142
compile.rkt
View File

@ -18,6 +18,8 @@
(define-type CompileTimeEnvironment (Listof (Listof Symbol))) (define-type CompileTimeEnvironment (Listof (Listof Symbol)))
(define-type LexicalAddress (U (List Number Number) 'not-found)) (define-type LexicalAddress (U (List Number Number) 'not-found))
;; find-variable: symbol compile-time-environment -> lexical-address ;; find-variable: symbol compile-time-environment -> lexical-address
;; Find where the variable should be located. ;; Find where the variable should be located.
(: find-variable (Symbol CompileTimeEnvironment -> LexicalAddress)) (: find-variable (Symbol CompileTimeEnvironment -> LexicalAddress))
@ -79,12 +81,12 @@
(define (compile-linkage linkage) (define (compile-linkage linkage)
(cond (cond
[(eq? linkage 'return) [(eq? linkage 'return)
(make-instruction-sequence '(cont) '() '((goto (reg cont))))] (make-instruction-sequence '(cont) '() `(,(make-GotoStatement (make-Reg 'cont))))]
[(eq? linkage 'next) [(eq? linkage 'next)
empty-instruction-sequence] empty-instruction-sequence]
[else [else
(make-instruction-sequence '() '() (make-instruction-sequence '() '()
`((goto (label ,linkage))))])) `(,(make-GotoStatement (make-Label linkage))))]))
(: end-with-linkage (Linkage InstructionSequence -> InstructionSequence)) (: end-with-linkage (Linkage InstructionSequence -> InstructionSequence))
(define (end-with-linkage linkage instruction-sequence) (define (end-with-linkage linkage instruction-sequence)
@ -98,7 +100,7 @@
(make-instruction-sequence (make-instruction-sequence
'() '()
(list target) (list target)
`((assign ,target (const ,exp)))))) `(,(make-AssignConstantStatement target 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)
@ -106,7 +108,7 @@
(make-instruction-sequence (make-instruction-sequence
'() '()
(list target) (list target)
`((assign ,target (const ,(Quote-text exp))))))) `(,(make-AssignConstantStatement target (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)
@ -119,23 +121,23 @@
(list target) (list target)
;; Slight modification: explicitly testing for ;; Slight modification: explicitly testing for
;; global variable binding before lookup. ;; global variable binding before lookup.
`((perform (op check-bound-global!) `(,(make-PerformStatement 'check-bound-global!
(const ,(Var-id exp)) (list (make-Const (Var-id exp))
(reg env)) (make-Reg 'env)))
(assign ,target ,(make-AssignPrimOpStatement target
(op lookup-variable-value) 'lookup-variable-value
(const ,(Var-id exp)) (list (make-Const (Var-id exp))
(reg env)))))] (make-Reg 'env))))))]
[else [else
(end-with-linkage linkage (end-with-linkage linkage
(make-instruction-sequence (make-instruction-sequence
'(env) '(env)
(list target) (list target)
`((assign ,target `(,(make-AssignPrimOpStatement target
(op lexical-address-lookup) 'lexical-address-lookup
(const ,(first lexical-pos)) (list (make-Const (first lexical-pos))
(const ,(second lexical-pos)) (make-Const (second lexical-pos))
(reg env)))))]))) (make-Reg 'env))))))])))
(: compile-assignment (Assign CompileTimeEnvironment Target Linkage -> InstructionSequence)) (: compile-assignment (Assign CompileTimeEnvironment Target Linkage -> InstructionSequence))
@ -154,11 +156,11 @@
(make-instruction-sequence (make-instruction-sequence
'(env val) '(env val)
(list target) (list target)
`((perform (op set-variable-value!) `(,(make-PerformStatement 'set-variable-value!
(const ,var) (list (make-Const var)
(reg val) (make-Reg 'val)
(reg env)) (make-Reg 'env)))
(assign ,target (const ok))))))] ,(make-AssignConstantStatement target 'ok)))))]
[else [else
(end-with-linkage (end-with-linkage
linkage linkage
@ -167,12 +169,12 @@
(make-instruction-sequence (make-instruction-sequence
'(env val) '(env val)
(list target) (list target)
`((perform (op lexical-address-set!) `(,(make-PerformStatement 'lexical-address-set!
(const ,(first lexical-address)) (list (make-Const (first lexical-address))
(const ,(second lexical-address)) (make-Const (second lexical-address))
(reg env) (make-Reg 'env)
(reg val)) (make-Reg 'val)))
(assign ,target (const ok))))))]))) ,(make-AssignConstantStatement target 'ok)))))])))
;; FIXME: exercise 5.43 ;; FIXME: exercise 5.43
@ -189,11 +191,11 @@
(make-instruction-sequence (make-instruction-sequence
'(env val) '(env val)
(list target) (list target)
`((perform (op define-variable!) `(,(make-PerformStatement 'define-variable!
(const ,var) (list (make-Const var)
(reg val) (make-Reg 'val)
(reg env)) (make-Reg 'env)))
(assign ,target (const ok)))))))) ,(make-AssignConstantStatement target 'ok)))))))
(: compile-if (Branch CompileTimeEnvironment Target Linkage -> InstructionSequence)) (: compile-if (Branch CompileTimeEnvironment Target Linkage -> InstructionSequence))
@ -214,8 +216,8 @@
(make-instruction-sequence (make-instruction-sequence
'(val) '(val)
'() '()
`((test (op false?) (reg val)) `(,(make-TestStatement 'false? 'val)
(branch (label ,f-branch)))) ,(make-BranchLabelStatement f-branch)))
(parallel-instruction-sequences (parallel-instruction-sequences
(append-instruction-sequences t-branch c-code) (append-instruction-sequences t-branch c-code)
(append-instruction-sequences f-branch a-code)) (append-instruction-sequences f-branch a-code))
@ -245,16 +247,16 @@
(make-instruction-sequence (make-instruction-sequence
'(env) '(env)
(list target) (list target)
`((assign ,target `(,(make-AssignPrimOpStatement target
(op make-compiled-procedure) 'make-compiled-procedure
(label ,proc-entry) (list (make-Label proc-entry)
;; TODO: rather than capture the whole ;; TODO: rather than capture the whole
;; environment, we may instead ;; environment, we may instead
;; just capture the free variables. ;; just capture the free variables.
;; But that requires that we box ;; But that requires that we box
;; up all set!-ed variables, in order ;; up all set!-ed variables, in order
;; to preserve semantics of set! ;; to preserve semantics of set!
(reg env))))) (make-Reg 'env))))))
(compile-lambda-body exp cenv (compile-lambda-body exp cenv
proc-entry)) proc-entry))
after-lambda)))) after-lambda))))
@ -268,11 +270,13 @@
'(env proc argl) '(env proc argl)
'(env) '(env)
`(,proc-entry `(,proc-entry
(assign env (op compiled-procedure-env) (reg proc)) ,(make-AssignPrimOpStatement 'env
(assign env 'compiled-procedure-env
(op extend-environment) (list (make-Reg 'proc)))
(reg argl) ,(make-AssignPrimOpStatement 'env
(reg env)))) 'extend-environment
(list (make-Reg 'argl)
(make-Reg 'env)))))
(compile-sequence (Lam-body exp) extended-cenv 'val 'return)))) (compile-sequence (Lam-body exp) extended-cenv 'val 'return))))
(: compile-application (App CompileTimeEnvironment Target Linkage -> InstructionSequence)) (: compile-application (App CompileTimeEnvironment Target Linkage -> InstructionSequence))
@ -293,12 +297,13 @@
(if (null? operand-codes) (if (null? operand-codes)
(make-instruction-sequence '() (make-instruction-sequence '()
'(argl) '(argl)
'((assign argl (const ())))) `(,(make-AssignConstantStatement 'argl '())))
(let ([code-to-get-last-arg (let ([code-to-get-last-arg
(append-instruction-sequences (append-instruction-sequences
(car operand-codes) (car operand-codes)
(make-instruction-sequence '(val) '(argl) (make-instruction-sequence '(val) '(argl)
'((assign argl (op list) (reg val)))))]) `(,(make-AssignPrimOpStatement 'argl 'list
(list (make-Reg 'val))))))])
(if (null? (cdr operand-codes)) (if (null? (cdr operand-codes))
code-to-get-last-arg code-to-get-last-arg
(preserving '(env) (preserving '(env)
@ -313,7 +318,10 @@
(make-instruction-sequence (make-instruction-sequence
'(val argl) '(val argl)
'(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)) (if (null? (cdr operand-codes))
code-for-next-arg code-for-next-arg
(preserving '(env) (preserving '(env)
@ -329,8 +337,8 @@
(if (eq? linkage 'next) after-call linkage)]) (if (eq? linkage 'next) after-call linkage)])
(append-instruction-sequences (append-instruction-sequences
(make-instruction-sequence '(proc) '() (make-instruction-sequence '(proc) '()
`((test (op primitive-procedure?) (reg proc)) `(,(make-TestStatement 'primitive-procedure? 'proc)
(branch (label ,primitive-branch)))) ,(make-BranchLabelStatement primitive-branch)))
(parallel-instruction-sequences (parallel-instruction-sequences
(append-instruction-sequences (append-instruction-sequences
compiled-branch compiled-branch
@ -341,10 +349,10 @@
(make-instruction-sequence (make-instruction-sequence
'(proc argl) '(proc argl)
(list target) (list target)
`((assign ,target `(,(make-AssignPrimOpStatement target
(op apply-primitive-procedure) 'apply-primitive-procedure
(reg proc) (list (make-Reg 'proc)
(reg argl))))))) (make-Reg 'argl))))))))
after-call)))) after-call))))
(: compile-proc-appl (Target Linkage -> InstructionSequence)) (: compile-proc-appl (Target Linkage -> InstructionSequence))
@ -354,31 +362,31 @@
(make-instruction-sequence (make-instruction-sequence
'(proc) '(proc)
all-regs all-regs
`((assign cont (label ,linkage)) `(,(make-AssignLabelStatement 'cont linkage)
(assign val (op compiled-procedure-entry) ,(make-AssignPrimOpStatement 'val 'compiled-procedure-entry
(reg proc)) (list (make-Reg 'proc)))
(goto (reg val))))] ,(make-GotoStatement (make-Reg 'val))))]
[(and (not (eq? target 'val)) [(and (not (eq? target 'val))
(not (eq? linkage 'return))) (not (eq? linkage 'return)))
(let ([proc-return (make-label 'procReturn)]) (let ([proc-return (make-label 'procReturn)])
(make-instruction-sequence (make-instruction-sequence
'(proc) '(proc)
all-regs all-regs
`((assign cont (label ,proc-return)) `(,(make-AssignLabelStatement 'cont proc-return)
(assign val (op compiled-procedure-entry) ,(make-AssignPrimOpStatement 'val 'compiled-procedure-entry
(reg proc)) (list (make-Reg 'proc)))
(goto (reg val)) ,(make-GotoStatement (make-Reg 'val))
,proc-return ,proc-return
(assign ,target (reg val)) ,(make-AssignRegisterStatement target 'val)
(goto (label ,linkage)))))] ,(make-GotoStatement (make-Label linkage)))))]
[(and (eq? target 'val) [(and (eq? target 'val)
(eq? linkage 'return)) (eq? linkage 'return))
(make-instruction-sequence (make-instruction-sequence
'(proc cont) '(proc cont)
all-regs all-regs
'((assign val (op compiled-procedure-entry) `(,(make-AssignPrimOpStatement 'val 'compiled-procedure-entry
(reg proc)) (list (make-Reg 'proc)))
(goto (reg val))))] ,(make-GotoStatement (make-Reg 'val))))]
[(and (not (eq? target 'val)) [(and (not (eq? target 'val))
(eq? linkage 'return)) (eq? linkage 'return))
(error 'compile "return linkage, target not val: ~s" target)])) (error 'compile "return linkage, target not val: ~s" target)]))
@ -412,9 +420,9 @@
(registers-needed seq1)) (registers-needed seq1))
(list-difference (registers-modified seq1) (list-difference (registers-modified seq1)
(list first-reg)) (list first-reg))
(append `((save ,first-reg)) (append `(,(make-SaveStatement first-reg))
(statements seq1) (statements seq1)
`((restore ,first-reg)))) `(,(make-RestoreStatement first-reg))))
seq2) seq2)
(preserving (cdr regs) seq1 seq2))))) (preserving (cdr regs) seq1 seq2)))))

40
typed-structs.rkt
View File

@ -32,21 +32,43 @@
;; instruction sequences ;; instruction sequences
(define-type Statement (U Symbol ;; label (define-type Statement (U Symbol ;; label
AssignStatement AssignConstantStatement
AssignLabelStatement
AssignRegisterStatement
AssignPrimOpStatement
PerformStatement PerformStatement
TestStatement TestStatement
BranchStatement BranchLabelStatement
GotoStatement GotoStatement
SaveStatement SaveStatement
RestoreStatement)) RestoreStatement))
(define-struct: AssignStatement () #:transparent) (define-struct: AssignConstantStatement ([target : Symbol]
(define-struct: PerformStatement () #:transparent) [value : Any])
(define-struct: TestStatement () #:transparent) #:transparent)
(define-struct: BranchStatement () #:transparent) (define-struct: AssignRegisterStatement ([target : Symbol]
(define-struct: GotoStatement () #:transparent) [reg : Symbol])
(define-struct: SaveStatement () #:transparent) #:transparent)
(define-struct: RestoreStatement () #:transparent) (define-struct: AssignLabelStatement ([target : Symbol]
[label : Symbol])
#: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))