From 3cb40ab499ce8de38e98a341c51ebd23bb58a420 Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Sat, 16 Apr 2011 15:26:01 -0400 Subject: [PATCH] restricting the prompt and call frames to ensure they are always using linkedlabels, to guarantee good things when we do multiple value returns --- compiler.rkt | 8 +++-- il-structs.rkt | 4 +-- test-simulator.rkt | 80 ++++++++++++++++++++++++++++++++++++++++------ 3 files changed, 78 insertions(+), 14 deletions(-) diff --git a/compiler.rkt b/compiler.rkt index 7abfb65..5c7deea 100644 --- a/compiler.rkt +++ b/compiler.rkt @@ -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] diff --git a/il-structs.rkt b/il-structs.rkt index 07a1d43..2cc9c5c 100644 --- a/il-structs.rkt +++ b/il-structs.rkt @@ -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) diff --git a/test-simulator.rkt b/test-simulator.rkt index cca578d..8d86df3 100644 --- a/test-simulator.rkt +++ b/test-simulator.rkt @@ -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)