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) (let: loop : (Listof lam+cenv)
([exp : ExpressionCore exp] ([exp : ExpressionCore exp]
[cenv : CompileTimeEnvironment '()]) [cenv : CompileTimeEnvironment '()])
(cond (cond
[(Top? exp) [(Top? exp)
(loop (Top-code exp) (cons (Top-prefix exp) cenv))] (loop (Top-code exp) (cons (Top-prefix exp) cenv))]
@ -98,11 +98,11 @@
'()] '()]
[(LetRec? exp) [(LetRec? exp)
(let ([new-cenv (append (map (lambda: ([p : Lam]) (let ([new-cenv (append (map (lambda: ([p : Lam])
(extract-static-knowledge (extract-static-knowledge
p p
(append (build-list (length (LetRec-procs exp)) (append (build-list (length (LetRec-procs exp))
(lambda: ([i : Natural]) '?)) (lambda: ([i : Natural]) '?))
cenv))) cenv)))
(reverse (LetRec-procs exp))) (reverse (LetRec-procs exp)))
cenv)]) cenv)])
(append (apply append (append (apply append
@ -110,8 +110,8 @@
(loop lam new-cenv)) (loop lam new-cenv))
(LetRec-procs exp))) (LetRec-procs exp)))
(loop (LetRec-body exp) new-cenv)))]))) (loop (LetRec-body exp) new-cenv)))])))
(: extract-lambda-cenv (Lam CompileTimeEnvironment -> CompileTimeEnvironment)) (: extract-lambda-cenv (Lam CompileTimeEnvironment -> CompileTimeEnvironment))
(define (extract-lambda-cenv lam cenv) (define (extract-lambda-cenv lam cenv)
@ -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))))
@ -344,7 +343,7 @@
(make-instruction-sequence (make-instruction-sequence
`(,(Lam-entry-label exp))) `(,(Lam-entry-label exp)))
(if (not (empty? (Lam-closure-map exp))) (if (not (empty? (Lam-closure-map exp)))
(make-instruction-sequence `(,(make-PerformStatement (make-InstallClosureValues!)))) (make-instruction-sequence `(,(make-PerformStatement (make-InstallClosureValues!))))
empty-instruction-sequence) empty-instruction-sequence)
@ -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
@ -535,7 +534,7 @@
(StaticallyKnownLam-name static-knowledge) (StaticallyKnownLam-name static-knowledge)
(StaticallyKnownLam-arity static-knowledge) (StaticallyKnownLam-arity static-knowledge)
(length (App-operands exp)))) (length (App-operands exp))))
(let ([proc-code (compile (App-operator exp) (let ([proc-code (compile (App-operator exp)
extended-cenv extended-cenv
(if (empty? (App-operands exp)) (if (empty? (App-operands exp))
@ -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])
@ -595,25 +594,25 @@
(: compile-general-procedure-call (CompileTimeEnvironment CompileTimeEnvironment (: compile-general-procedure-call (CompileTimeEnvironment CompileTimeEnvironment
Natural Target Linkage Natural Target Linkage
-> ->
InstructionSequence)) InstructionSequence))
;; Assumes the procedure value has been loaded into the proc register. ;; Assumes the procedure value has been loaded into the proc register.
;; n is the number of arguments passed in. ;; n is the number of arguments passed in.
;; 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,62 +653,86 @@
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. ;; This case happens when we're in tail position.
(make-instruction-sequence ;; We clean up the stack right before the jump, and do not add
`(,(make-PushControlFrame linkage) ;; to the control stack.
,(make-AssignPrimOpStatement 'val (make-GetCompiledProcedureEntry)) (let: ([num-slots-to-delete : Natural (ensure-natural (- (length cenv-with-args) n))])
,(make-GotoStatement entry-point)))] (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))) [(NextLinkage? linkage)
;; This case happens for evaluating arguments, since the (cond [(eq? target 'val)
;; arguments are being installed into the scratch space. ;; This case happens for a function call that isn't in
(let ([proc-return (make-label 'procReturn)]) ;; tail position.
(make-instruction-sequence (let ([proc-return (make-label 'procReturn)])
`(,(make-PushControlFrame proc-return) (make-instruction-sequence
,(make-AssignPrimOpStatement 'val (make-GetCompiledProcedureEntry)) `(,(make-PushControlFrame proc-return)
,(make-GotoStatement entry-point) ,(make-AssignPrimOpStatement 'val (make-GetCompiledProcedureEntry))
,proc-return ,(make-GotoStatement entry-point)
,(make-AssignImmediateStatement target (make-Reg 'val)) ,proc-return)))]
,(make-GotoStatement (make-Label linkage)))))]
[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) [(LabelLinkage? linkage)
(eq? linkage 'return)) (cond [(eq? target 'val)
;; This case happens when we're in tail position. ;; This case happens for a function call that isn't in
;; We clean up the stack right before the jump, and do not add ;; tail position.
;; to the control stack. (make-instruction-sequence
(let: ([num-slots-to-delete : Natural (ensure-natural (- (length cenv-with-args) n))]) `(,(make-PushControlFrame (LabelLinkage-label linkage))
(append-instruction-sequences ,(make-AssignPrimOpStatement 'val (make-GetCompiledProcedureEntry))
(make-instruction-sequence ,(make-GotoStatement entry-point)))]
`(,(make-AssignPrimOpStatement 'val
(make-GetCompiledProcedureEntry)))) [else
(if (> num-slots-to-delete 0) ;; This case happens for evaluating arguments, since the
(make-instruction-sequence `(,(make-PopEnvironment num-slots-to-delete n))) ;; arguments are being installed into the scratch space.
empty-instruction-sequence) (let ([proc-return (make-label 'procReturn)])
(make-instruction-sequence (make-instruction-sequence
`(,(make-GotoStatement entry-point)))))] `(,(make-PushControlFrame proc-return)
,(make-AssignPrimOpStatement 'val (make-GetCompiledProcedureEntry))
[(and (not (eq? target 'val)) ,(make-GotoStatement entry-point)
(eq? linkage 'return)) ,proc-return
;; This case should be impossible: return linkage should only ,(make-AssignImmediateStatement target (make-Reg 'val))
;; occur when we're in tail position, and we're in tail position ,(make-GotoStatement (make-Label (LabelLinkage-label linkage))))))])]))
;; only when the target is the val register.
(error 'compile "return linkage, target not val: ~s" target)]))
(: extract-static-knowledge (ExpressionCore CompileTimeEnvironment -> (: extract-static-knowledge (ExpressionCore CompileTimeEnvironment ->
@ -741,26 +764,26 @@
[else [else
'?])) '?]))
(: compile-let1 (Let1 CompileTimeEnvironment Target Linkage -> InstructionSequence)) (: compile-let1 (Let1 CompileTimeEnvironment Target Linkage -> InstructionSequence))
(define (compile-let1 exp cenv target linkage) (define (compile-let1 exp cenv target linkage)
(let*: ([rhs-code : InstructionSequence (let*: ([rhs-code : InstructionSequence
(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)
@ -825,52 +848,52 @@
cenv))) cenv)))
(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
extended-cenv extended-cenv
(append-instruction-sequences (append-instruction-sequences
(if (> n 0) (if (> n 0)
(make-instruction-sequence `(,(make-PushEnvironment n #f))) (make-instruction-sequence `(,(make-PushEnvironment n #f)))
empty-instruction-sequence) empty-instruction-sequence)
;; Install each of the closure shells ;; Install each of the closure shells
(apply append-instruction-sequences (apply append-instruction-sequences
(map (lambda: ([lam : Lam] (map (lambda: ([lam : Lam]
[i : Natural]) [i : Natural])
(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))))))
;; Fix the closure maps of each ;; Fix the closure maps of each
(apply append-instruction-sequences (apply append-instruction-sequences
(map (lambda: ([lam : Lam] (map (lambda: ([lam : Lam]
[i : Natural]) [i : Natural])
(make-instruction-sequence (make-instruction-sequence
`(,(make-PerformStatement `(,(make-PerformStatement
(make-FixClosureShellMap! i (Lam-closure-map lam)))))) (make-FixClosureShellMap! i (Lam-closure-map lam))))))
(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))))))
;; 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)))))
(: compile-install-value (InstallValue CompileTimeEnvironment Target Linkage -> InstructionSequence)) (: compile-install-value (InstallValue CompileTimeEnvironment Target Linkage -> InstructionSequence))
@ -884,11 +907,11 @@
(: compile-box-environment-value (BoxEnv CompileTimeEnvironment Target Linkage -> InstructionSequence)) (: compile-box-environment-value (BoxEnv CompileTimeEnvironment Target Linkage -> InstructionSequence))
(define (compile-box-environment-value exp cenv target linkage) (define (compile-box-environment-value exp cenv target linkage)
(append-instruction-sequences (append-instruction-sequences
(make-instruction-sequence (make-instruction-sequence
`(,(make-AssignPrimOpStatement (make-EnvLexicalReference (BoxEnv-depth exp) #f) `(,(make-AssignPrimOpStatement (make-EnvLexicalReference (BoxEnv-depth exp) #f)
(make-MakeBoxedEnvironmentValue (BoxEnv-depth exp))))) (make-MakeBoxedEnvironmentValue (BoxEnv-depth exp)))))
(compile (BoxEnv-body exp) cenv target linkage))) (compile (BoxEnv-body exp) cenv target linkage)))
(: append-instruction-sequences (InstructionSequence * -> InstructionSequence)) (: append-instruction-sequences (InstructionSequence * -> InstructionSequence))

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))