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

359
compile.rkt
View File

@ -54,7 +54,7 @@
(let: loop : (Listof lam+cenv)
([exp : ExpressionCore exp]
[cenv : CompileTimeEnvironment '()])
(cond
[(Top? exp)
(loop (Top-code exp) (cons (Top-prefix exp) cenv))]
@ -98,11 +98,11 @@
'()]
[(LetRec? exp)
(let ([new-cenv (append (map (lambda: ([p : Lam])
(extract-static-knowledge
p
(append (build-list (length (LetRec-procs exp))
(lambda: ([i : Natural]) '?))
cenv)))
(extract-static-knowledge
p
(append (build-list (length (LetRec-procs exp))
(lambda: ([i : Natural]) '?))
cenv)))
(reverse (LetRec-procs exp)))
cenv)])
(append (apply append
@ -110,8 +110,8 @@
(loop lam new-cenv))
(LetRec-procs exp)))
(loop (LetRec-body exp) new-cenv)))])))
(: extract-lambda-cenv (Lam CompileTimeEnvironment -> CompileTimeEnvironment))
(define (extract-lambda-cenv lam cenv)
@ -192,32 +192,32 @@
(: compile-linkage (CompileTimeEnvironment Linkage -> InstructionSequence))
(define (compile-linkage cenv linkage)
(cond
[(eq? linkage 'return)
[(ReturnLinkage? linkage)
(make-instruction-sequence `(,(make-AssignPrimOpStatement 'proc
(make-GetControlStackLabel))
,(make-PopEnvironment (length cenv) 0)
,(make-PopControlFrame)
,(make-GotoStatement (make-Reg 'proc))))]
[(eq? linkage 'next)
[(NextLinkage? linkage)
empty-instruction-sequence]
[(symbol? linkage)
(make-instruction-sequence `(,(make-GotoStatement (make-Label linkage))))]))
[(LabelLinkage? linkage)
(make-instruction-sequence `(,(make-GotoStatement (make-Label (LabelLinkage-label linkage)))))]))
(: 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.
(define (compile-application-linkage cenv linkage)
(cond
[(eq? linkage 'return)
[(ReturnLinkage? linkage)
(make-instruction-sequence `(,(make-AssignPrimOpStatement 'proc (make-GetControlStackLabel))
,(make-PopControlFrame)
,(make-GotoStatement (make-Reg 'proc))))]
[(eq? linkage 'next)
[(NextLinkage? linkage)
(make-instruction-sequence `(,(make-PopEnvironment (length cenv) 0)))]
[(symbol? linkage)
[(LabelLinkage? linkage)
(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))])
(let ([get-value-code
(compile (ToplevelSet-value exp) cenv lexical-pos
'next)])
next-linkage)])
(end-with-linkage
linkage
cenv
@ -273,14 +273,14 @@
(: compile-branch (Branch CompileTimeEnvironment Target Linkage -> InstructionSequence))
(define (compile-branch exp cenv target linkage)
(let ([t-branch (make-label 'trueBranch)]
[f-branch (make-label 'falseBranch)]
[after-if (make-label 'afterIf)])
(let: ([t-branch : LabelLinkage (make-LabelLinkage (make-label 'trueBranch))]
[f-branch : LabelLinkage (make-LabelLinkage (make-label 'falseBranch))]
[after-if : LabelLinkage (make-LabelLinkage (make-label 'afterIf))])
(let ([consequent-linkage
(if (eq? linkage 'next)
(if (eq? linkage next-linkage)
after-if
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)]
[a-code (compile (Branch-alternative exp) cenv target linkage)])
(append-instruction-sequences p-code
@ -288,20 +288,19 @@
(make-instruction-sequence
`(,(make-TestAndBranchStatement 'false?
'val
f-branch)
))
(LabelLinkage-label f-branch))))
(append-instruction-sequences
(append-instruction-sequences t-branch c-code)
(append-instruction-sequences f-branch a-code))
after-if))))))
(append-instruction-sequences (LabelLinkage-label t-branch) c-code)
(append-instruction-sequences (LabelLinkage-label f-branch) a-code))
(LabelLinkage-label after-if)))))))
(: compile-sequence ((Listof Expression) CompileTimeEnvironment Target Linkage -> InstructionSequence))
(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)
(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))))
@ -344,7 +343,7 @@
(make-instruction-sequence
`(,(Lam-entry-label exp)))
(if (not (empty? (Lam-closure-map exp)))
(make-instruction-sequence `(,(make-PerformStatement (make-InstallClosureValues!))))
empty-instruction-sequence)
@ -356,7 +355,7 @@
;; fixme: We need to capture the cenv so we can maintain static knowledge
(build-list (Lam-num-parameters exp) (lambda: ([i : Natural]) '?)))
'val
'return)))
return-linkage)))
@ -422,10 +421,10 @@
(make-EnvLexicalReference
(ensure-natural (sub1 (length (App-operands exp))))
#f))
'next)]
next-linkage)]
[operand-codes (map (lambda: ([operand : Expression]
[target : Target])
(compile operand extended-cenv target 'next))
(compile operand extended-cenv target next-linkage))
(App-operands exp)
(build-list (length (App-operands exp))
(lambda: ([i : Natural])
@ -457,7 +456,7 @@
(make-EnvLexicalReference i #f)))]
[operand-codes (map (lambda: ([operand : Expression]
[target : Target])
(compile operand extended-cenv target 'next))
(compile operand extended-cenv target next-linkage))
(App-operands exp)
operand-poss)])
(cond
@ -535,7 +534,7 @@
(StaticallyKnownLam-name static-knowledge)
(StaticallyKnownLam-arity static-knowledge)
(length (App-operands exp))))
(let ([proc-code (compile (App-operator exp)
extended-cenv
(if (empty? (App-operands exp))
@ -543,10 +542,10 @@
(make-EnvLexicalReference
(ensure-natural (sub1 (length (App-operands exp))))
#f))
'next)]
next-linkage)]
[operand-codes (map (lambda: ([operand : Expression]
[target : Target])
(compile operand extended-cenv target 'next))
(compile operand extended-cenv target next-linkage))
(App-operands exp)
(build-list (length (App-operands exp))
(lambda: ([i : Natural])
@ -595,25 +594,25 @@
(: compile-general-procedure-call (CompileTimeEnvironment CompileTimeEnvironment
Natural Target Linkage
->
InstructionSequence))
Natural Target Linkage
->
InstructionSequence))
;; Assumes the procedure value has been loaded into the proc register.
;; n is the number of arguments passed 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.
(define (compile-general-procedure-call cenv extended-cenv n target linkage)
(let ([primitive-branch (make-label 'primitiveBranch)]
[compiled-branch (make-label 'compiledBranch)]
[after-call (make-label 'afterCall)])
(let ([compiled-linkage (if (eq? linkage 'next) after-call linkage)])
(let: ([primitive-branch : LabelLinkage (make-LabelLinkage (make-label 'primitiveBranch))]
[compiled-branch : LabelLinkage (make-LabelLinkage (make-label 'compiledBranch))]
[after-call : LabelLinkage (make-LabelLinkage (make-label 'afterCall))])
(let: ([compiled-linkage : Linkage (if (eq? linkage next-linkage) after-call linkage)])
(append-instruction-sequences
(make-instruction-sequence
`(,(make-TestAndBranchStatement 'primitive-procedure?
'proc
primitive-branch)))
(LabelLinkage-label primitive-branch))))
compiled-branch
(LabelLinkage-label compiled-branch)
(make-instruction-sequence
`(,(make-PerformStatement (make-CheckClosureArity! n))))
(end-with-compiled-application-linkage
@ -621,7 +620,7 @@
extended-cenv
(compile-proc-appl extended-cenv (make-Reg 'val) n target compiled-linkage))
primitive-branch
(LabelLinkage-label primitive-branch)
(end-with-linkage
linkage
cenv
@ -637,14 +636,14 @@
(make-instruction-sequence
`(,(make-PopEnvironment n 0)))
empty-instruction-sequence)))
after-call))))
(LabelLinkage-label after-call)))))
(: compile-procedure-call/statically-known-lam
(StaticallyKnownLam CompileTimeEnvironment Natural Target Linkage -> InstructionSequence))
(define (compile-procedure-call/statically-known-lam static-knowledge extended-cenv n target linkage)
(let* ([after-call (make-label 'afterCall)]
[compiled-linkage (if (eq? linkage 'next) after-call linkage)])
(let*: ([after-call : LabelLinkage (make-LabelLinkage (make-label 'afterCall))]
[compiled-linkage : Linkage (if (eq? linkage next-linkage) after-call linkage)])
(append-instruction-sequences
(end-with-compiled-application-linkage
compiled-linkage
@ -654,62 +653,86 @@
n
target
compiled-linkage))
after-call)))
(LabelLinkage-label after-call))))
(: compile-proc-appl (CompileTimeEnvironment (U Label Reg) Natural Target Linkage -> InstructionSequence))
;; Three fundamental cases for general compiled-procedure application.
;; 1. Non-tail calls that write to val
;; 2. Calls in argument position that write to the environment
;; 3. Tail calls.
;; The Other cases should be excluded.
;; 1. Tail calls.
;; 2. Non-tail calls (next/label linkage) that write to val
;; 3. Calls in argument position (next/label linkage) that write to the stack.
(define (compile-proc-appl cenv-with-args entry-point n target linkage)
(cond [(and (eq? target 'val)
(not (eq? linkage 'return)))
;; This case happens for a function call that isn't in
;; tail position.
(make-instruction-sequence
`(,(make-PushControlFrame linkage)
,(make-AssignPrimOpStatement 'val (make-GetCompiledProcedureEntry))
,(make-GotoStatement entry-point)))]
(cond [(ReturnLinkage? linkage)
(cond
[(eq? target 'val)
;; This case happens when we're in tail position.
;; We clean up the stack right before the jump, and do not add
;; to the control stack.
(let: ([num-slots-to-delete : Natural (ensure-natural (- (length cenv-with-args) n))])
(append-instruction-sequences
(make-instruction-sequence
`(,(make-AssignPrimOpStatement 'val
(make-GetCompiledProcedureEntry))))
(if (> num-slots-to-delete 0)
(make-instruction-sequence `(,(make-PopEnvironment num-slots-to-delete n)))
empty-instruction-sequence)
(make-instruction-sequence
`(,(make-GotoStatement entry-point)))))]
[else
;; This case should be impossible: return linkage should only
;; occur when we're in tail position, and we should be in tail position
;; only when the target is the val register.
(error 'compile "return linkage, target not val: ~s" target)])]
[(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)))))]
[(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)))))])]
[(and (eq? target 'val)
(eq? linkage 'return))
;; This case happens when we're in tail position.
;; We clean up the stack right before the jump, and do not add
;; to the control stack.
(let: ([num-slots-to-delete : Natural (ensure-natural (- (length cenv-with-args) n))])
(append-instruction-sequences
(make-instruction-sequence
`(,(make-AssignPrimOpStatement 'val
(make-GetCompiledProcedureEntry))))
(if (> num-slots-to-delete 0)
(make-instruction-sequence `(,(make-PopEnvironment num-slots-to-delete n)))
empty-instruction-sequence)
(make-instruction-sequence
`(,(make-GotoStatement entry-point)))))]
[(and (not (eq? target 'val))
(eq? linkage 'return))
;; This case should be impossible: return linkage should only
;; occur when we're in tail position, and we're in tail position
;; only when the target is the val register.
(error 'compile "return linkage, target not val: ~s" target)]))
[(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))))))])]))
(: extract-static-knowledge (ExpressionCore CompileTimeEnvironment ->
@ -741,26 +764,26 @@
[else
'?]))
(: compile-let1 (Let1 CompileTimeEnvironment Target Linkage -> InstructionSequence))
(define (compile-let1 exp cenv target linkage)
(let*: ([rhs-code : InstructionSequence
(compile (Let1-rhs exp)
(cons '? cenv)
(make-EnvLexicalReference 0 #f)
'next)]
next-linkage)]
[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)
(cons '? cenv))
cenv)]
[let-linkage : Linkage
(cond
[(eq? linkage 'next)
'next]
[(eq? linkage 'return)
'return]
[(symbol? linkage)
[(NextLinkage? linkage)
linkage]
[(ReturnLinkage? linkage)
linkage]
[(LabelLinkage? linkage)
after-body-code])]
[body-target : Target (adjust-target-depth target 1)]
[body-code : InstructionSequence
@ -772,7 +795,7 @@
(make-instruction-sequence `(,(make-PushEnvironment 1 #f)))
rhs-code
body-code
after-body-code
(LabelLinkage-label after-body-code)
(make-instruction-sequence `(,(make-PopEnvironment 1 0)))
after-let1))))
@ -782,17 +805,17 @@
(define (compile-let-void exp cenv target linkage)
(let*: ([n : Natural (LetVoid-count exp)]
[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)
(lambda: ([i : Natural]) '?))
cenv)]
cenv)]
[let-linkage : Linkage
(cond
[(eq? linkage 'next)
'next]
[(eq? linkage 'return)
'return]
[(symbol? linkage)
[(NextLinkage? linkage)
linkage]
[(ReturnLinkage? linkage)
linkage]
[(LabelLinkage? linkage)
after-body-code])]
[body-target : Target (adjust-target-depth target n)]
[body-code : InstructionSequence
@ -805,7 +828,7 @@
(make-instruction-sequence `(,(make-PushEnvironment n (LetVoid-boxes? exp))))
empty-instruction-sequence)
body-code
after-body-code
(LabelLinkage-label after-body-code)
(if (> n 0)
(make-instruction-sequence `(,(make-PopEnvironment n 0)))
empty-instruction-sequence)
@ -825,52 +848,52 @@
cenv)))
(reverse (LetRec-procs exp)))
cenv)]
[n : Natural (length (LetRec-procs exp))]
[after-body-code : Linkage (make-label 'afterBodyCode)]
[letrec-linkage : Linkage (cond
[(eq? linkage 'next)
'next]
[(eq? linkage 'return)
'return]
[(symbol? linkage)
after-body-code])])
(end-with-linkage
linkage
extended-cenv
(append-instruction-sequences
(if (> n 0)
(make-instruction-sequence `(,(make-PushEnvironment n #f)))
empty-instruction-sequence)
;; Install each of the closure shells
(apply append-instruction-sequences
(map (lambda: ([lam : Lam]
[i : Natural])
(compile-lambda-shell lam
extended-cenv
(make-EnvLexicalReference i #f)
'next))
(LetRec-procs exp)
(build-list n (lambda: ([i : Natural]) (ensure-natural (- n 1 i))))))
;; Fix the closure maps of each
(apply append-instruction-sequences
(map (lambda: ([lam : Lam]
[i : Natural])
(make-instruction-sequence
`(,(make-PerformStatement
(make-FixClosureShellMap! i (Lam-closure-map lam))))))
(LetRec-procs exp)
(build-list n (lambda: ([i : Natural]) (ensure-natural (- n 1 i))))))
;; Compile the body
(compile (LetRec-body exp) extended-cenv (adjust-target-depth target n) letrec-linkage)
after-body-code
(if (> n 0)
(make-instruction-sequence `(,(make-PopEnvironment n 0)))
empty-instruction-sequence)))))
[n : Natural (length (LetRec-procs exp))]
[after-body-code : LabelLinkage (make-LabelLinkage (make-label 'afterBodyCode))]
[letrec-linkage : Linkage (cond
[(NextLinkage? linkage)
linkage]
[(ReturnLinkage? linkage)
linkage]
[(LabelLinkage? linkage)
after-body-code])])
(end-with-linkage
linkage
extended-cenv
(append-instruction-sequences
(if (> n 0)
(make-instruction-sequence `(,(make-PushEnvironment n #f)))
empty-instruction-sequence)
;; Install each of the closure shells
(apply append-instruction-sequences
(map (lambda: ([lam : Lam]
[i : Natural])
(compile-lambda-shell lam
extended-cenv
(make-EnvLexicalReference i #f)
next-linkage))
(LetRec-procs exp)
(build-list n (lambda: ([i : Natural]) (ensure-natural (- n 1 i))))))
;; Fix the closure maps of each
(apply append-instruction-sequences
(map (lambda: ([lam : Lam]
[i : Natural])
(make-instruction-sequence
`(,(make-PerformStatement
(make-FixClosureShellMap! i (Lam-closure-map lam))))))
(LetRec-procs exp)
(build-list n (lambda: ([i : Natural]) (ensure-natural (- n 1 i))))))
;; Compile the body
(compile (LetRec-body exp) extended-cenv (adjust-target-depth target n) letrec-linkage)
(LabelLinkage-label after-body-code)
(if (> n 0)
(make-instruction-sequence `(,(make-PopEnvironment n 0)))
empty-instruction-sequence)))))
(: compile-install-value (InstallValue CompileTimeEnvironment Target Linkage -> InstructionSequence))
@ -884,11 +907,11 @@
(: compile-box-environment-value (BoxEnv CompileTimeEnvironment Target Linkage -> InstructionSequence))
(define (compile-box-environment-value exp cenv target linkage)
(append-instruction-sequences
(make-instruction-sequence
`(,(make-AssignPrimOpStatement (make-EnvLexicalReference (BoxEnv-depth exp) #f)
(make-MakeBoxedEnvironmentValue (BoxEnv-depth exp)))))
(compile (BoxEnv-body exp) cenv target linkage)))
(append-instruction-sequences
(make-instruction-sequence
`(,(make-AssignPrimOpStatement (make-EnvLexicalReference (BoxEnv-depth exp) #f)
(make-MakeBoxedEnvironmentValue (BoxEnv-depth exp)))))
(compile (BoxEnv-body exp) cenv target linkage)))
(: append-instruction-sequences (InstructionSequence * -> InstructionSequence))

15
il-structs.rkt
View File

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