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

restricting the prompt and call frames to ensure they are always using linkedlabels, to guarantee good things when we do multiple value returns

Browse Source
This commit is contained in:
Danny Yoo 2011-04-16 15:26:01 -04:00
parent bb2aba98ac
commit 3cb40ab499
3 changed files with 78 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
compiler.rkt
View File

@ -22,21 +22,25 @@
;; Note: the toplevel generates the lambda body streams at the head, and then the
;; rest of the instruction stream.
(define (-compile exp target linkage)
(let ([after-lam-bodies (make-label 'afterLamBodies)]
[before-pop-prompt (make-label 'beforePopPrompt)])
(let* ([after-lam-bodies (make-label 'afterLamBodies)]
[before-pop-prompt-multiple (make-label 'beforePopPromptMultiple)]
[before-pop-prompt (make-LinkedLabel (make-label 'beforePopPrompt) before-pop-prompt-multiple)])
(optimize-il
(statements
(append-instruction-sequences
;; Layout the lambda bodies...
(make-instruction-sequence
`(,(make-GotoStatement (make-Label after-lam-bodies))))
(compile-lambda-bodies (collect-all-lams exp))
after-lam-bodies
;; Begin a prompted evaluation:
(make-instruction-sequence
`(,(make-PushControlFrame/Prompt default-continuation-prompt-tag
before-pop-prompt)))
(compile exp '() target return-linkage/nontail)
before-pop-prompt-multiple
before-pop-prompt)))))
(define-struct: lam+cenv ([lam : Lam]

4
il-structs.rkt
View File

@ -132,11 +132,11 @@
;; Adding a frame for getting back after procedure application.
;; The 'proc register must hold either #f or a closure at the time of
;; this call, as the control frame will hold onto the called procedure record.
(define-struct: PushControlFrame/Call ([label : (U Symbol LinkedLabel)])
(define-struct: PushControlFrame/Call ([label : LinkedLabel])
#:transparent)
(define-struct: PushControlFrame/Prompt ([tag : (U OpArg DefaultContinuationPromptTag)]
[label : (U Symbol LinkedLabel)]
[label : LinkedLabel]
;; TODO: add handler and arguments
)
#:transparent)

80
test-simulator.rkt
View File

@ -167,34 +167,34 @@
;; PushControl
(let ([m (new-machine `(,(make-AssignImmediateStatement 'proc (make-Const #f))
foo
,(make-PushControlFrame/Call 'foo)
,(make-PushControlFrame/Call (make-LinkedLabel 'foo 'foo))
bar
,(make-PushControlFrame/Call 'bar)
,(make-PushControlFrame/Call (make-LinkedLabel 'bar 'bar))
baz
))])
(test (machine-control (run! m))
(list (make-CallFrame 'bar #f (make-hasheq) (make-hasheq))
(make-CallFrame 'foo #f (make-hasheq) (make-hasheq)))))
(list (make-CallFrame (make-LinkedLabel 'bar 'bar) #f (make-hasheq) (make-hasheq))
(make-CallFrame (make-LinkedLabel 'foo 'foo) #f (make-hasheq) (make-hasheq)))))
;; PopControl
(let ([m (new-machine `(,(make-AssignImmediateStatement 'proc (make-Const #f))
foo
,(make-PushControlFrame/Call 'foo)
,(make-PushControlFrame/Call (make-LinkedLabel 'foo 'foo))
bar
,(make-PushControlFrame/Call 'bar)
,(make-PushControlFrame/Call (make-LinkedLabel 'bar 'bar))
baz
,(make-PopControlFrame)
))])
(test (machine-control (run! m))
(list (make-CallFrame 'foo #f (make-hasheq) (make-hasheq)))))
(list (make-CallFrame (make-LinkedLabel 'foo 'foo) #f (make-hasheq) (make-hasheq)))))
(let ([m (new-machine `(,(make-AssignImmediateStatement 'proc (make-Const #f))
foo
,(make-PushControlFrame/Call 'foo)
,(make-PushControlFrame/Call (make-LinkedLabel 'foo 'foo))
bar
,(make-PushControlFrame/Call 'bar)
,(make-PushControlFrame/Call (make-LinkedLabel 'bar 'bar))
baz
,(make-PopControlFrame)
,(make-PopControlFrame)))])
@ -488,12 +488,72 @@
;; GetControlStackLabel
(let ([m (new-machine `(,(make-AssignImmediateStatement 'proc (make-Const #f))
foo
,(make-PushControlFrame/Call 'foo)
,(make-PushControlFrame/Call (make-LinkedLabel 'foo 'foo))
,(make-AssignPrimOpStatement 'proc (make-GetControlStackLabel))))])
(test (machine-proc (run! m))
'foo))
;; GetControlStackLabel
(let ([m (new-machine `(,(make-AssignImmediateStatement 'proc (make-Const #f))
,(make-PushControlFrame/Call (make-LinkedLabel 'foo-single 'foo-multiple))
,(make-AssignPrimOpStatement 'proc (make-GetControlStackLabel))
,(make-GotoStatement (make-Reg 'proc))
foo-single
,(make-AssignImmediateStatement 'val (make-Const "single"))
,(make-GotoStatement (make-Label 'end))
foo-multiple
,(make-AssignImmediateStatement 'val (make-Const "multiple"))
,(make-GotoStatement (make-Label 'end))
end))])
(test (machine-val (run! m))
"single"))
(let ([m (new-machine `(,(make-AssignImmediateStatement 'proc (make-Const #f))
,(make-PushControlFrame/Call (make-LinkedLabel 'foo-single 'foo-multiple))
,(make-AssignPrimOpStatement 'proc (make-GetControlStackLabel/MultipleValueReturn))
,(make-GotoStatement (make-Reg 'proc))
foo-single
,(make-AssignImmediateStatement 'val (make-Const "single"))
,(make-GotoStatement (make-Label 'end))
foo-multiple
,(make-AssignImmediateStatement 'val (make-Const "multiple"))
,(make-GotoStatement (make-Label 'end))
end))])
(test (machine-val (run! m))
"multiple"))
(let ([m (new-machine `(,(make-AssignImmediateStatement 'proc (make-Const #f))
,(make-PushControlFrame/Prompt default-continuation-prompt-tag
(make-LinkedLabel 'foo-single 'foo-multiple))
,(make-AssignPrimOpStatement 'proc (make-GetControlStackLabel))
,(make-GotoStatement (make-Reg 'proc))
foo-single
,(make-AssignImmediateStatement 'val (make-Const "single"))
,(make-GotoStatement (make-Label 'end))
foo-multiple
,(make-AssignImmediateStatement 'val (make-Const "multiple"))
,(make-GotoStatement (make-Label 'end))
end))])
(test (machine-val (run! m))
"single"))
(let ([m (new-machine `(,(make-AssignImmediateStatement 'proc (make-Const #f))
,(make-PushControlFrame/Prompt default-continuation-prompt-tag
(make-LinkedLabel 'foo-single 'foo-multiple))
,(make-AssignPrimOpStatement 'proc (make-GetControlStackLabel/MultipleValueReturn))
,(make-GotoStatement (make-Reg 'proc))
foo-single
,(make-AssignImmediateStatement 'val (make-Const "single"))
,(make-GotoStatement (make-Label 'end))
foo-multiple
,(make-AssignImmediateStatement 'val (make-Const "multiple"))
,(make-GotoStatement (make-Label 'end))
end))])
(test (machine-val (run! m))
"multiple"))
;; Splicing
(let ([m (new-machine `(,(make-PushEnvironment 1 #f)
,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f)