diff --git a/compiler.rkt b/compiler.rkt index b307258..94df4e2 100644 --- a/compiler.rkt +++ b/compiler.rkt @@ -480,7 +480,7 @@ (: compile-splice ((Listof Expression) CompileTimeEnvironment Target Linkage -> InstructionSequence)) ;; Compiles a sequence of expressions. A continuation prompt wraps around each of the expressions ;; to delimit any continuation captures. -(define (compile-splice seq cenv target linkage) +(define (compile-splice seq cenv target linkage) (cond [(empty? seq) (end-with-linkage linkage cenv empty-instruction-sequence)] [(empty? (rest seq)) @@ -527,78 +527,74 @@ (compile (first seq) cenv target linkage)] [else - (let ([after-first-seq (make-label 'afterFirstSeqEvaluated)] - [after-values-reinstated (make-label 'afterValuesReinstated)]) - - (end-with-linkage - linkage - cenv - (append-instruction-sequences - - ;; Evaluate the first expression in a multiple-value context, and get the values on the stack. - (compile (first seq) - cenv - 'val - next-linkage/keep-multiple-on-stack) - (make-instruction-sequence - `(,(make-TestAndBranchStatement (make-TestZero (make-Reg 'argcount)) after-first-seq) - ,(make-PushImmediateOntoEnvironment (make-Reg 'val) #f))) - after-first-seq - - ;; At this time, the argcount values are on the stack. - ;; Next, we save those values temporarily in a throwaway control frame. - (make-instruction-sequence - `(,(make-PushControlFrame/Generic) - ,(make-AssignImmediateStatement (make-ControlFrameTemporary 'pendingBegin0Count) - (make-Reg 'argcount)) - ,(make-PerformStatement (make-UnspliceRestFromStack! (make-Const 0) (make-Reg 'argcount))) - ,(make-AssignImmediateStatement (make-ControlFrameTemporary 'pendingBegin0Values) - (make-EnvLexicalReference 0 #f)) - ,(make-PopEnvironment (make-Const 1) (make-Const 0)))) - - ;; Evaluate the rest of the sequence, dropping their values. - (compile-sequence (rest seq) cenv target next-linkage/drop-multiple) - - (make-instruction-sequence - `(;; Reinstate the values of the first expression, and drop the throwaway control frame. - ,(make-PushImmediateOntoEnvironment (make-ControlFrameTemporary 'pendingBegin0Values) #f) - ,(make-PerformStatement (make-SpliceListIntoStack! (make-Const 0))) - ,(make-AssignImmediateStatement 'argcount (make-ControlFrameTemporary 'pendingBegin0Count)) - ,(make-PopControlFrame) - ,(make-TestAndBranchStatement (make-TestZero (make-Reg 'argcount)) after-values-reinstated) - ,(make-AssignImmediateStatement 'val (make-EnvLexicalReference 0 #f)) - ,(make-PopEnvironment (make-Const 1) (make-Const 0)) - ,after-values-reinstated)) - - (let ([context (linkage-context linkage)]) - (cond - [(eq? context 'tail) - empty-instruction-sequence] - - [(eq? context 'drop-multiple) - (make-instruction-sequence - `(,(make-PopEnvironment (make-SubtractArg (make-Reg 'argcount) (make-Const 1)) - (make-Const 0))))] - - [(eq? context 'keep-multiple) - empty-instruction-sequence] - - [(natural? context) - ;; Check that the context can accept the argcount values. - (let ([after-check (make-label 'afterCheck)]) + (let ([evaluate-and-save-first-expression + (let ([after-first-seq (make-label 'afterFirstSeqEvaluated)]) + (append-instruction-sequences + ;; Evaluate the first expression in a multiple-value context, and get the values on the stack. + (compile (first seq) cenv 'val next-linkage/keep-multiple-on-stack) (make-instruction-sequence - `(,(make-TestAndBranchStatement (make-TestZero (make-SubtractArg - (make-Reg 'argcount) - (make-Const context))) - after-check) - ,(make-PerformStatement (make-RaiseContextExpectedValuesError! context)) - ,after-check)))])) + `(,(make-TestAndBranchStatement (make-TestZero (make-Reg 'argcount)) after-first-seq) + ,(make-PushImmediateOntoEnvironment (make-Reg 'val) #f))) + after-first-seq + ;; At this time, the argcount values are on the stack. + ;; Next, we save those values temporarily in a throwaway control frame. + (make-instruction-sequence + `(,(make-PushControlFrame/Generic) + ,(make-AssignImmediateStatement (make-ControlFrameTemporary 'pendingBegin0Count) + (make-Reg 'argcount)) + ,(make-PerformStatement (make-UnspliceRestFromStack! (make-Const 0) (make-Reg 'argcount))) + ,(make-AssignImmediateStatement (make-ControlFrameTemporary 'pendingBegin0Values) + (make-EnvLexicalReference 0 #f)) + ,(make-PopEnvironment (make-Const 1) (make-Const 0))))))] + + [reinstate-values-on-stack + (let ([after-values-reinstated (make-label 'afterValuesReinstated)]) + (make-instruction-sequence + `(;; Reinstate the values of the first expression, and drop the throwaway control frame. + ,(make-PushImmediateOntoEnvironment (make-ControlFrameTemporary 'pendingBegin0Values) #f) + ,(make-PerformStatement (make-SpliceListIntoStack! (make-Const 0))) + ,(make-AssignImmediateStatement 'argcount (make-ControlFrameTemporary 'pendingBegin0Count)) + ,(make-PopControlFrame) + ,(make-TestAndBranchStatement (make-TestZero (make-Reg 'argcount)) after-values-reinstated) + ,(make-AssignImmediateStatement 'val (make-EnvLexicalReference 0 #f)) + ,(make-PopEnvironment (make-Const 1) (make-Const 0)) + ,after-values-reinstated)))]) + + (append-instruction-sequences + evaluate-and-save-first-expression + (compile-sequence (rest seq) cenv target next-linkage/drop-multiple) + + reinstate-values-on-stack (make-instruction-sequence `(,(make-AssignImmediateStatement target (make-Reg 'val)))) - )))])) - - + + ;; TODO: context needs check for arguments. + (cond + [(ReturnLinkage? linkage) + (cond + [(ReturnLinkage-tail? linkage) + (make-instruction-sequence + `(,(make-PopEnvironment (make-Const (length cenv)) + (make-SubtractArg (make-Reg 'argcount) + (make-Const 1))) + ,(make-AssignImmediateStatement 'proc (make-ControlStackLabel/MultipleValueReturn)) + ,(make-PopControlFrame) + ,(make-GotoStatement (make-Reg 'proc))))] + [else + (make-instruction-sequence + `(,(make-AssignImmediateStatement 'proc (make-ControlStackLabel/MultipleValueReturn)) + ,(make-PopControlFrame) + ,(make-GotoStatement (make-Reg 'proc))))])] + + [(NextLinkage? linkage) + empty-instruction-sequence] + + [(LabelLinkage? linkage) + (make-instruction-sequence + `(,(make-GotoStatement (make-Label (LabelLinkage-label linkage)))))])))])) + + (: compile-lambda (Lam CompileTimeEnvironment Target Linkage -> InstructionSequence)) diff --git a/test-compiler.rkt b/test-compiler.rkt index 98f90bf..b2b3982 100644 --- a/test-compiler.rkt +++ b/test-compiler.rkt @@ -1338,8 +1338,8 @@ #:with-bootstrapping? #t) (test '(let () (define (f x y z) - (begin0 (values y x z) - (display ""))) + (begin0 (values y x z) + (display ""))) (call-with-values (lambda () (f 3 1 4)) (lambda args (list args)))) '((1 3 4))