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 ;; Note: the toplevel generates the lambda body streams at the head, and then the
;; rest of the instruction stream. ;; rest of the instruction stream.
(define (-compile exp target linkage) (define (-compile exp target linkage)
(let ([after-lam-bodies (make-label 'afterLamBodies)] (let* ([after-lam-bodies (make-label 'afterLamBodies)]
[before-pop-prompt (make-label 'beforePopPrompt)]) [before-pop-prompt-multiple (make-label 'beforePopPromptMultiple)]
[before-pop-prompt (make-LinkedLabel (make-label 'beforePopPrompt) before-pop-prompt-multiple)])
(optimize-il (optimize-il
(statements (statements
(append-instruction-sequences (append-instruction-sequences
;; Layout the lambda bodies...
(make-instruction-sequence (make-instruction-sequence
`(,(make-GotoStatement (make-Label after-lam-bodies)))) `(,(make-GotoStatement (make-Label after-lam-bodies))))
(compile-lambda-bodies (collect-all-lams exp)) (compile-lambda-bodies (collect-all-lams exp))
after-lam-bodies after-lam-bodies
;; Begin a prompted evaluation:
(make-instruction-sequence (make-instruction-sequence
`(,(make-PushControlFrame/Prompt default-continuation-prompt-tag `(,(make-PushControlFrame/Prompt default-continuation-prompt-tag
before-pop-prompt))) before-pop-prompt)))
(compile exp '() target return-linkage/nontail) (compile exp '() target return-linkage/nontail)
before-pop-prompt-multiple
before-pop-prompt))))) before-pop-prompt)))))
(define-struct: lam+cenv ([lam : Lam] (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. ;; Adding a frame for getting back after procedure application.
;; The 'proc register must hold either #f or a closure at the time of ;; 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. ;; 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) #:transparent)
(define-struct: PushControlFrame/Prompt ([tag : (U OpArg DefaultContinuationPromptTag)] (define-struct: PushControlFrame/Prompt ([tag : (U OpArg DefaultContinuationPromptTag)]
[label : (U Symbol LinkedLabel)] [label : LinkedLabel]
;; TODO: add handler and arguments ;; TODO: add handler and arguments
) )
#:transparent) #:transparent)

80
test-simulator.rkt
View File

@ -167,34 +167,34 @@
;; PushControl ;; PushControl
(let ([m (new-machine `(,(make-AssignImmediateStatement 'proc (make-Const #f)) (let ([m (new-machine `(,(make-AssignImmediateStatement 'proc (make-Const #f))
foo foo
,(make-PushControlFrame/Call 'foo) ,(make-PushControlFrame/Call (make-LinkedLabel 'foo 'foo))
bar bar
,(make-PushControlFrame/Call 'bar) ,(make-PushControlFrame/Call (make-LinkedLabel 'bar 'bar))
baz baz
))]) ))])
(test (machine-control (run! m)) (test (machine-control (run! m))
(list (make-CallFrame 'bar #f (make-hasheq) (make-hasheq)) (list (make-CallFrame (make-LinkedLabel 'bar 'bar) #f (make-hasheq) (make-hasheq))
(make-CallFrame 'foo #f (make-hasheq) (make-hasheq))))) (make-CallFrame (make-LinkedLabel 'foo 'foo) #f (make-hasheq) (make-hasheq)))))
;; PopControl ;; PopControl
(let ([m (new-machine `(,(make-AssignImmediateStatement 'proc (make-Const #f)) (let ([m (new-machine `(,(make-AssignImmediateStatement 'proc (make-Const #f))
foo foo
,(make-PushControlFrame/Call 'foo) ,(make-PushControlFrame/Call (make-LinkedLabel 'foo 'foo))
bar bar
,(make-PushControlFrame/Call 'bar) ,(make-PushControlFrame/Call (make-LinkedLabel 'bar 'bar))
baz baz
,(make-PopControlFrame) ,(make-PopControlFrame)
))]) ))])
(test (machine-control (run! m)) (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)) (let ([m (new-machine `(,(make-AssignImmediateStatement 'proc (make-Const #f))
foo foo
,(make-PushControlFrame/Call 'foo) ,(make-PushControlFrame/Call (make-LinkedLabel 'foo 'foo))
bar bar
,(make-PushControlFrame/Call 'bar) ,(make-PushControlFrame/Call (make-LinkedLabel 'bar 'bar))
baz baz
,(make-PopControlFrame) ,(make-PopControlFrame)
,(make-PopControlFrame)))]) ,(make-PopControlFrame)))])
@ -488,12 +488,72 @@
;; GetControlStackLabel ;; GetControlStackLabel
(let ([m (new-machine `(,(make-AssignImmediateStatement 'proc (make-Const #f)) (let ([m (new-machine `(,(make-AssignImmediateStatement 'proc (make-Const #f))
foo foo
,(make-PushControlFrame/Call 'foo) ,(make-PushControlFrame/Call (make-LinkedLabel 'foo 'foo))
,(make-AssignPrimOpStatement 'proc (make-GetControlStackLabel))))]) ,(make-AssignPrimOpStatement 'proc (make-GetControlStackLabel))))])
(test (machine-proc (run! m)) (test (machine-proc (run! m))
'foo)) '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 ;; Splicing
(let ([m (new-machine `(,(make-PushEnvironment 1 #f) (let ([m (new-machine `(,(make-PushEnvironment 1 #f)
,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f) ,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f)