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

changing types for linkage, to help catch more type errors.

Browse Source
This commit is contained in:
Danny Yoo 2011-03-28 17:46:56 -04:00
parent 89c58808de
commit 74fd786921
2 changed files with 203 additions and 171 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

211
compile.rkt
View File

@ -192,32 +192,32 @@
(: compile-linkage (CompileTimeEnvironment Linkage -> InstructionSequence)) (: compile-linkage (CompileTimeEnvironment Linkage -> InstructionSequence))
(define (compile-linkage cenv linkage) (define (compile-linkage cenv linkage)
(cond (cond
[(eq? linkage 'return) [(ReturnLinkage? linkage)
(make-instruction-sequence `(,(make-AssignPrimOpStatement 'proc (make-instruction-sequence `(,(make-AssignPrimOpStatement 'proc
(make-GetControlStackLabel)) (make-GetControlStackLabel))
,(make-PopEnvironment (length cenv) 0) ,(make-PopEnvironment (length cenv) 0)
,(make-PopControlFrame) ,(make-PopControlFrame)
,(make-GotoStatement (make-Reg 'proc))))] ,(make-GotoStatement (make-Reg 'proc))))]
[(eq? linkage 'next) [(NextLinkage? linkage)
empty-instruction-sequence] empty-instruction-sequence]
[(symbol? linkage) [(LabelLinkage? linkage)
(make-instruction-sequence `(,(make-GotoStatement (make-Label linkage))))])) (make-instruction-sequence `(,(make-GotoStatement (make-Label (LabelLinkage-label linkage)))))]))
(: compile-application-linkage (CompileTimeEnvironment Linkage -> InstructionSequence)) (: compile-application-linkage (CompileTimeEnvironment Linkage -> InstructionSequence))
;; Like compile-linkage, but the special case for 'return linkage already assumes ;; Like compile-linkage, but the special case for return-linkage linkage already assumes
;; the stack has been appropriately popped. ;; the stack has been appropriately popped.
(define (compile-application-linkage cenv linkage) (define (compile-application-linkage cenv linkage)
(cond (cond
[(eq? linkage 'return) [(ReturnLinkage? linkage)
(make-instruction-sequence `(,(make-AssignPrimOpStatement 'proc (make-GetControlStackLabel)) (make-instruction-sequence `(,(make-AssignPrimOpStatement 'proc (make-GetControlStackLabel))
,(make-PopControlFrame) ,(make-PopControlFrame)
,(make-GotoStatement (make-Reg 'proc))))] ,(make-GotoStatement (make-Reg 'proc))))]
[(eq? linkage 'next) [(NextLinkage? linkage)
(make-instruction-sequence `(,(make-PopEnvironment (length cenv) 0)))] (make-instruction-sequence `(,(make-PopEnvironment (length cenv) 0)))]
[(symbol? linkage) [(LabelLinkage? linkage)
(make-instruction-sequence `(,(make-PopEnvironment (length cenv) 0) (make-instruction-sequence `(,(make-PopEnvironment (length cenv) 0)
,(make-GotoStatement (make-Label linkage))))])) ,(make-GotoStatement (make-Label (LabelLinkage-label linkage)))))]))
@ -262,7 +262,7 @@
(ToplevelSet-pos exp))]) (ToplevelSet-pos exp))])
(let ([get-value-code (let ([get-value-code
(compile (ToplevelSet-value exp) cenv lexical-pos (compile (ToplevelSet-value exp) cenv lexical-pos
'next)]) next-linkage)])
(end-with-linkage (end-with-linkage
linkage linkage
cenv cenv
@ -273,14 +273,14 @@
(: compile-branch (Branch CompileTimeEnvironment Target Linkage -> InstructionSequence)) (: compile-branch (Branch CompileTimeEnvironment Target Linkage -> InstructionSequence))
(define (compile-branch exp cenv target linkage) (define (compile-branch exp cenv target linkage)
(let ([t-branch (make-label 'trueBranch)] (let: ([t-branch : LabelLinkage (make-LabelLinkage (make-label 'trueBranch))]
[f-branch (make-label 'falseBranch)] [f-branch : LabelLinkage (make-LabelLinkage (make-label 'falseBranch))]
[after-if (make-label 'afterIf)]) [after-if : LabelLinkage (make-LabelLinkage (make-label 'afterIf))])
(let ([consequent-linkage (let ([consequent-linkage
(if (eq? linkage 'next) (if (eq? linkage next-linkage)
after-if after-if
linkage)]) linkage)])
(let ([p-code (compile (Branch-predicate exp) cenv 'val 'next)] (let ([p-code (compile (Branch-predicate exp) cenv 'val next-linkage)]
[c-code (compile (Branch-consequent exp) cenv target consequent-linkage)] [c-code (compile (Branch-consequent exp) cenv target consequent-linkage)]
[a-code (compile (Branch-alternative exp) cenv target linkage)]) [a-code (compile (Branch-alternative exp) cenv target linkage)])
(append-instruction-sequences p-code (append-instruction-sequences p-code
@ -288,20 +288,19 @@
(make-instruction-sequence (make-instruction-sequence
`(,(make-TestAndBranchStatement 'false? `(,(make-TestAndBranchStatement 'false?
'val 'val
f-branch) (LabelLinkage-label f-branch))))
))
(append-instruction-sequences (append-instruction-sequences
(append-instruction-sequences t-branch c-code) (append-instruction-sequences (LabelLinkage-label t-branch) c-code)
(append-instruction-sequences f-branch a-code)) (append-instruction-sequences (LabelLinkage-label f-branch) a-code))
after-if)))))) (LabelLinkage-label after-if)))))))
(: compile-sequence ((Listof Expression) CompileTimeEnvironment Target Linkage -> InstructionSequence)) (: compile-sequence ((Listof Expression) CompileTimeEnvironment Target Linkage -> InstructionSequence))
(define (compile-sequence seq cenv target linkage) (define (compile-sequence seq cenv target linkage)
;; All but the last will use 'next linkage. ;; All but the last will use next-linkage linkage.
(if (last-exp? seq) (if (last-exp? seq)
(compile (first-exp seq) cenv target linkage) (compile (first-exp seq) cenv target linkage)
(append-instruction-sequences (compile (first-exp seq) cenv target 'next) (append-instruction-sequences (compile (first-exp seq) cenv target next-linkage)
(compile-sequence (rest-exps seq) cenv target linkage)))) (compile-sequence (rest-exps seq) cenv target linkage))))
@ -356,7 +355,7 @@
;; fixme: We need to capture the cenv so we can maintain static knowledge ;; fixme: We need to capture the cenv so we can maintain static knowledge
(build-list (Lam-num-parameters exp) (lambda: ([i : Natural]) '?))) (build-list (Lam-num-parameters exp) (lambda: ([i : Natural]) '?)))
'val 'val
'return))) return-linkage)))
@ -422,10 +421,10 @@
(make-EnvLexicalReference (make-EnvLexicalReference
(ensure-natural (sub1 (length (App-operands exp)))) (ensure-natural (sub1 (length (App-operands exp))))
#f)) #f))
'next)] next-linkage)]
[operand-codes (map (lambda: ([operand : Expression] [operand-codes (map (lambda: ([operand : Expression]
[target : Target]) [target : Target])
(compile operand extended-cenv target 'next)) (compile operand extended-cenv target next-linkage))
(App-operands exp) (App-operands exp)
(build-list (length (App-operands exp)) (build-list (length (App-operands exp))
(lambda: ([i : Natural]) (lambda: ([i : Natural])
@ -457,7 +456,7 @@
(make-EnvLexicalReference i #f)))] (make-EnvLexicalReference i #f)))]
[operand-codes (map (lambda: ([operand : Expression] [operand-codes (map (lambda: ([operand : Expression]
[target : Target]) [target : Target])
(compile operand extended-cenv target 'next)) (compile operand extended-cenv target next-linkage))
(App-operands exp) (App-operands exp)
operand-poss)]) operand-poss)])
(cond (cond
@ -543,10 +542,10 @@
(make-EnvLexicalReference (make-EnvLexicalReference
(ensure-natural (sub1 (length (App-operands exp)))) (ensure-natural (sub1 (length (App-operands exp))))
#f)) #f))
'next)] next-linkage)]
[operand-codes (map (lambda: ([operand : Expression] [operand-codes (map (lambda: ([operand : Expression]
[target : Target]) [target : Target])
(compile operand extended-cenv target 'next)) (compile operand extended-cenv target next-linkage))
(App-operands exp) (App-operands exp)
(build-list (length (App-operands exp)) (build-list (length (App-operands exp))
(lambda: ([i : Natural]) (lambda: ([i : Natural])
@ -603,17 +602,17 @@
;; cenv is the compile-time enviroment before arguments have been shifted in. ;; cenv is the compile-time enviroment before arguments have been shifted in.
;; extended-cenv is the compile-time environment after arguments have been shifted in. ;; extended-cenv is the compile-time environment after arguments have been shifted in.
(define (compile-general-procedure-call cenv extended-cenv n target linkage) (define (compile-general-procedure-call cenv extended-cenv n target linkage)
(let ([primitive-branch (make-label 'primitiveBranch)] (let: ([primitive-branch : LabelLinkage (make-LabelLinkage (make-label 'primitiveBranch))]
[compiled-branch (make-label 'compiledBranch)] [compiled-branch : LabelLinkage (make-LabelLinkage (make-label 'compiledBranch))]
[after-call (make-label 'afterCall)]) [after-call : LabelLinkage (make-LabelLinkage (make-label 'afterCall))])
(let ([compiled-linkage (if (eq? linkage 'next) after-call linkage)]) (let: ([compiled-linkage : Linkage (if (eq? linkage next-linkage) after-call linkage)])
(append-instruction-sequences (append-instruction-sequences
(make-instruction-sequence (make-instruction-sequence
`(,(make-TestAndBranchStatement 'primitive-procedure? `(,(make-TestAndBranchStatement 'primitive-procedure?
'proc 'proc
primitive-branch))) (LabelLinkage-label primitive-branch))))
compiled-branch (LabelLinkage-label compiled-branch)
(make-instruction-sequence (make-instruction-sequence
`(,(make-PerformStatement (make-CheckClosureArity! n)))) `(,(make-PerformStatement (make-CheckClosureArity! n))))
(end-with-compiled-application-linkage (end-with-compiled-application-linkage
@ -621,7 +620,7 @@
extended-cenv extended-cenv
(compile-proc-appl extended-cenv (make-Reg 'val) n target compiled-linkage)) (compile-proc-appl extended-cenv (make-Reg 'val) n target compiled-linkage))
primitive-branch (LabelLinkage-label primitive-branch)
(end-with-linkage (end-with-linkage
linkage linkage
cenv cenv
@ -637,14 +636,14 @@
(make-instruction-sequence (make-instruction-sequence
`(,(make-PopEnvironment n 0))) `(,(make-PopEnvironment n 0)))
empty-instruction-sequence))) empty-instruction-sequence)))
after-call)))) (LabelLinkage-label after-call)))))
(: compile-procedure-call/statically-known-lam (: compile-procedure-call/statically-known-lam
(StaticallyKnownLam CompileTimeEnvironment Natural Target Linkage -> InstructionSequence)) (StaticallyKnownLam CompileTimeEnvironment Natural Target Linkage -> InstructionSequence))
(define (compile-procedure-call/statically-known-lam static-knowledge extended-cenv n target linkage) (define (compile-procedure-call/statically-known-lam static-knowledge extended-cenv n target linkage)
(let* ([after-call (make-label 'afterCall)] (let*: ([after-call : LabelLinkage (make-LabelLinkage (make-label 'afterCall))]
[compiled-linkage (if (eq? linkage 'next) after-call linkage)]) [compiled-linkage : Linkage (if (eq? linkage next-linkage) after-call linkage)])
(append-instruction-sequences (append-instruction-sequences
(end-with-compiled-application-linkage (end-with-compiled-application-linkage
compiled-linkage compiled-linkage
@ -654,41 +653,19 @@
n n
target target
compiled-linkage)) compiled-linkage))
after-call))) (LabelLinkage-label after-call))))
(: compile-proc-appl (CompileTimeEnvironment (U Label Reg) Natural Target Linkage -> InstructionSequence)) (: compile-proc-appl (CompileTimeEnvironment (U Label Reg) Natural Target Linkage -> InstructionSequence))
;; Three fundamental cases for general compiled-procedure application. ;; Three fundamental cases for general compiled-procedure application.
;; 1. Non-tail calls that write to val ;; 1. Tail calls.
;; 2. Calls in argument position that write to the environment ;; 2. Non-tail calls (next/label linkage) that write to val
;; 3. Tail calls. ;; 3. Calls in argument position (next/label linkage) that write to the stack.
;; The Other cases should be excluded.
(define (compile-proc-appl cenv-with-args entry-point n target linkage) (define (compile-proc-appl cenv-with-args entry-point n target linkage)
(cond [(and (eq? target 'val) (cond [(ReturnLinkage? linkage)
(not (eq? linkage 'return))) (cond
;; This case happens for a function call that isn't in [(eq? target 'val)
;; tail position.
(make-instruction-sequence
`(,(make-PushControlFrame linkage)
,(make-AssignPrimOpStatement 'val (make-GetCompiledProcedureEntry))
,(make-GotoStatement entry-point)))]
[(and (not (eq? target 'val))
(not (eq? linkage 'return)))
;; This case happens for evaluating arguments, since the
;; arguments are being installed into the scratch space.
(let ([proc-return (make-label 'procReturn)])
(make-instruction-sequence
`(,(make-PushControlFrame proc-return)
,(make-AssignPrimOpStatement 'val (make-GetCompiledProcedureEntry))
,(make-GotoStatement entry-point)
,proc-return
,(make-AssignImmediateStatement target (make-Reg 'val))
,(make-GotoStatement (make-Label linkage)))))]
[(and (eq? target 'val)
(eq? linkage 'return))
;; This case happens when we're in tail position. ;; This case happens when we're in tail position.
;; We clean up the stack right before the jump, and do not add ;; We clean up the stack right before the jump, and do not add
;; to the control stack. ;; to the control stack.
@ -703,12 +680,58 @@
(make-instruction-sequence (make-instruction-sequence
`(,(make-GotoStatement entry-point)))))] `(,(make-GotoStatement entry-point)))))]
[(and (not (eq? target 'val)) [else
(eq? linkage 'return))
;; This case should be impossible: return linkage should only ;; This case should be impossible: return linkage should only
;; occur when we're in tail position, and we're in tail position ;; occur when we're in tail position, and we should be in tail position
;; only when the target is the val register. ;; only when the target is the val register.
(error 'compile "return linkage, target not val: ~s" target)])) (error 'compile "return linkage, target not val: ~s" target)])]
[(NextLinkage? linkage)
(cond [(eq? target 'val)
;; This case happens for a function call that isn't in
;; tail position.
(let ([proc-return (make-label 'procReturn)])
(make-instruction-sequence
`(,(make-PushControlFrame proc-return)
,(make-AssignPrimOpStatement 'val (make-GetCompiledProcedureEntry))
,(make-GotoStatement entry-point)
,proc-return)))]
[else
;; This case happens for evaluating arguments, since the
;; arguments are being installed into the scratch space.
(let ([proc-return (make-label 'procReturn)])
(make-instruction-sequence
`(,(make-PushControlFrame proc-return)
,(make-AssignPrimOpStatement 'val (make-GetCompiledProcedureEntry))
,(make-GotoStatement entry-point)
,proc-return
,(make-AssignImmediateStatement target (make-Reg 'val)))))])]
[(LabelLinkage? linkage)
(cond [(eq? target 'val)
;; This case happens for a function call that isn't in
;; tail position.
(make-instruction-sequence
`(,(make-PushControlFrame (LabelLinkage-label linkage))
,(make-AssignPrimOpStatement 'val (make-GetCompiledProcedureEntry))
,(make-GotoStatement entry-point)))]
[else
;; This case happens for evaluating arguments, since the
;; arguments are being installed into the scratch space.
(let ([proc-return (make-label 'procReturn)])
(make-instruction-sequence
`(,(make-PushControlFrame proc-return)
,(make-AssignPrimOpStatement 'val (make-GetCompiledProcedureEntry))
,(make-GotoStatement entry-point)
,proc-return
,(make-AssignImmediateStatement target (make-Reg 'val))
,(make-GotoStatement (make-Label (LabelLinkage-label linkage))))))])]))
@ -748,19 +771,19 @@
(compile (Let1-rhs exp) (compile (Let1-rhs exp)
(cons '? cenv) (cons '? cenv)
(make-EnvLexicalReference 0 #f) (make-EnvLexicalReference 0 #f)
'next)] next-linkage)]
[after-let1 : Symbol (make-label 'afterLetOne)] [after-let1 : Symbol (make-label 'afterLetOne)]
[after-body-code : Symbol (make-label 'afterLetBody)] [after-body-code : LabelLinkage (make-LabelLinkage (make-label 'afterLetBody))]
[extended-cenv : CompileTimeEnvironment (cons (extract-static-knowledge (Let1-rhs exp) [extended-cenv : CompileTimeEnvironment (cons (extract-static-knowledge (Let1-rhs exp)
(cons '? cenv)) (cons '? cenv))
cenv)] cenv)]
[let-linkage : Linkage [let-linkage : Linkage
(cond (cond
[(eq? linkage 'next) [(NextLinkage? linkage)
'next] linkage]
[(eq? linkage 'return) [(ReturnLinkage? linkage)
'return] linkage]
[(symbol? linkage) [(LabelLinkage? linkage)
after-body-code])] after-body-code])]
[body-target : Target (adjust-target-depth target 1)] [body-target : Target (adjust-target-depth target 1)]
[body-code : InstructionSequence [body-code : InstructionSequence
@ -772,7 +795,7 @@
(make-instruction-sequence `(,(make-PushEnvironment 1 #f))) (make-instruction-sequence `(,(make-PushEnvironment 1 #f)))
rhs-code rhs-code
body-code body-code
after-body-code (LabelLinkage-label after-body-code)
(make-instruction-sequence `(,(make-PopEnvironment 1 0))) (make-instruction-sequence `(,(make-PopEnvironment 1 0)))
after-let1)))) after-let1))))
@ -782,17 +805,17 @@
(define (compile-let-void exp cenv target linkage) (define (compile-let-void exp cenv target linkage)
(let*: ([n : Natural (LetVoid-count exp)] (let*: ([n : Natural (LetVoid-count exp)]
[after-let : Symbol (make-label 'afterLet)] [after-let : Symbol (make-label 'afterLet)]
[after-body-code : Symbol (make-label 'afterLetBody)] [after-body-code : LabelLinkage (make-LabelLinkage (make-label 'afterLetBody))]
[extended-cenv : CompileTimeEnvironment (append (build-list (LetVoid-count exp) [extended-cenv : CompileTimeEnvironment (append (build-list (LetVoid-count exp)
(lambda: ([i : Natural]) '?)) (lambda: ([i : Natural]) '?))
cenv)] cenv)]
[let-linkage : Linkage [let-linkage : Linkage
(cond (cond
[(eq? linkage 'next) [(NextLinkage? linkage)
'next] linkage]
[(eq? linkage 'return) [(ReturnLinkage? linkage)
'return] linkage]
[(symbol? linkage) [(LabelLinkage? linkage)
after-body-code])] after-body-code])]
[body-target : Target (adjust-target-depth target n)] [body-target : Target (adjust-target-depth target n)]
[body-code : InstructionSequence [body-code : InstructionSequence
@ -805,7 +828,7 @@
(make-instruction-sequence `(,(make-PushEnvironment n (LetVoid-boxes? exp)))) (make-instruction-sequence `(,(make-PushEnvironment n (LetVoid-boxes? exp))))
empty-instruction-sequence) empty-instruction-sequence)
body-code body-code
after-body-code (LabelLinkage-label after-body-code)
(if (> n 0) (if (> n 0)
(make-instruction-sequence `(,(make-PopEnvironment n 0))) (make-instruction-sequence `(,(make-PopEnvironment n 0)))
empty-instruction-sequence) empty-instruction-sequence)
@ -826,13 +849,13 @@
(reverse (LetRec-procs exp))) (reverse (LetRec-procs exp)))
cenv)] cenv)]
[n : Natural (length (LetRec-procs exp))] [n : Natural (length (LetRec-procs exp))]
[after-body-code : Linkage (make-label 'afterBodyCode)] [after-body-code : LabelLinkage (make-LabelLinkage (make-label 'afterBodyCode))]
[letrec-linkage : Linkage (cond [letrec-linkage : Linkage (cond
[(eq? linkage 'next) [(NextLinkage? linkage)
'next] linkage]
[(eq? linkage 'return) [(ReturnLinkage? linkage)
'return] linkage]
[(symbol? linkage) [(LabelLinkage? linkage)
after-body-code])]) after-body-code])])
(end-with-linkage (end-with-linkage
linkage linkage
@ -849,7 +872,7 @@
(compile-lambda-shell lam (compile-lambda-shell lam
extended-cenv extended-cenv
(make-EnvLexicalReference i #f) (make-EnvLexicalReference i #f)
'next)) next-linkage))
(LetRec-procs exp) (LetRec-procs exp)
(build-list n (lambda: ([i : Natural]) (ensure-natural (- n 1 i)))))) (build-list n (lambda: ([i : Natural]) (ensure-natural (- n 1 i))))))
@ -866,7 +889,7 @@
;; Compile the body ;; Compile the body
(compile (LetRec-body exp) extended-cenv (adjust-target-depth target n) letrec-linkage) (compile (LetRec-body exp) extended-cenv (adjust-target-depth target n) letrec-linkage)
after-body-code (LabelLinkage-label after-body-code)
(if (> n 0) (if (> n 0)
(make-instruction-sequence `(,(make-PopEnvironment n 0))) (make-instruction-sequence `(,(make-PopEnvironment n 0)))
empty-instruction-sequence))))) empty-instruction-sequence)))))

15
il-structs.rkt
View File

@ -279,10 +279,19 @@
;; Linkage ;; Linkage
(define-type Linkage (U 'return (define-struct: NextLinkage ())
'next (define next-linkage (make-NextLinkage))
Symbol))
(define-struct: ReturnLinkage ())
(define return-linkage (make-ReturnLinkage))
(define-struct: LabelLinkage ([label : Symbol]))
(define-type Linkage (U NextLinkage
ReturnLinkage
LabelLinkage))