diff --git a/bootstrapped-primitives.rkt b/bootstrapped-primitives.rkt index d4f2442..8aa8b87 100644 --- a/bootstrapped-primitives.rkt +++ b/bootstrapped-primitives.rkt @@ -61,7 +61,7 @@ ,(make-PerformStatement (make-RestoreControl! default-continuation-prompt-tag)) ,(make-PerformStatement (make-RestoreEnvironment!)) - ,(make-AssignPrimOpStatement 'proc (make-GetControlStackLabel)) + ,(make-AssignImmediateStatement 'proc (make-ControlStackLabel)) ,(make-PopControlFrame) ,(make-GotoStatement (make-Reg 'proc))))))) @@ -174,11 +174,11 @@ ,(make-TestAndBranchStatement 'one? 'argcount on-single-value) ;; values simply keeps the values on the stack, preserves the argcount, and does a return ;; to the multiple-value-return address. - ,(make-AssignPrimOpStatement 'proc (make-GetControlStackLabel/MultipleValueReturn)) + ,(make-AssignImmediateStatement 'proc (make-ControlStackLabel/MultipleValueReturn)) ,(make-PopControlFrame) ,(make-GotoStatement (make-Reg 'proc)) ,on-single-value - ,(make-AssignPrimOpStatement 'proc (make-GetControlStackLabel)) + ,(make-AssignImmediateStatement 'proc (make-ControlStackLabel)) ,(make-AssignImmediateStatement 'val (make-EnvLexicalReference 0 #f)) ,(make-PopEnvironment (make-Const 1) (make-Const 0)) ,(make-PopControlFrame) diff --git a/simulator-structs.rkt b/simulator-structs.rkt index e0cc474..7914a5b 100644 --- a/simulator-structs.rkt +++ b/simulator-structs.rkt @@ -66,7 +66,7 @@ #:transparent) -(define-struct: CallFrame ([return : (U Symbol LinkedLabel)] +(define-struct: CallFrame ([return : LinkedLabel] ;; The procedure being called. Used to optimize self-application [proc : (U closure #f)] ;; TODO: add continuation marks @@ -76,7 +76,7 @@ #:mutable) ;; mutable because we want to allow mutation of proc. (define-struct: PromptFrame ([tag : ContinuationPromptTagValue] - [return : (U Symbol LinkedLabel)] + [return : LinkedLabel] [env-depth : Natural] [temps : (HashTable Symbol PrimitiveValue)] [marks : (HashTable PrimitiveValue PrimitiveValue)]) diff --git a/simulator.rkt b/simulator.rkt index d0f09a5..6de51f7 100644 --- a/simulator.rkt +++ b/simulator.rkt @@ -516,46 +516,6 @@ [else (error 'apply-primitive-procedure)]))] - [(GetControlStackLabel? op) - (target-updater! m (let ([frame (ensure-frame (first (machine-control m)))]) - (cond - [(GenericFrame? frame) - (error 'GetControlStackLabel)] - [(PromptFrame? frame) - (let ([label (PromptFrame-return frame)]) - (cond - [(symbol? label) - label] - [(LinkedLabel? label) - (LinkedLabel-label label)]))] - [(CallFrame? frame) - (let ([label (CallFrame-return frame)]) - (cond - [(symbol? label) - label] - [(LinkedLabel? label) - (LinkedLabel-label label)]))])))] - - [(GetControlStackLabel/MultipleValueReturn? op) - (target-updater! m (let ([frame (ensure-frame (first (machine-control m)))]) - (cond - [(GenericFrame? frame) - (error 'GetControlStackLabel/MultipleValueReturn)] - [(PromptFrame? frame) - (let ([label (PromptFrame-return frame)]) - (cond - [(symbol? label) - (error 'GetControlStackLabel/MultipleValueReturn)] - [(LinkedLabel? label) - (LinkedLabel-linked-to label)]))] - [(CallFrame? frame) - (let ([label (CallFrame-return frame)]) - (cond - [(symbol? label) - (error 'GetControlStackLabel/MultipleValueReturn)] - [(LinkedLabel? label) - (LinkedLabel-linked-to label)]))])))] - [(CaptureEnvironment? op) (target-updater! m (make-CapturedEnvironment (drop (machine-env m) (CaptureEnvironment-skip op))))] @@ -755,7 +715,33 @@ [(SubtractArg? an-oparg) (- (ensure-number (evaluate-oparg m (SubtractArg-lhs an-oparg))) - (ensure-number (evaluate-oparg m (SubtractArg-rhs an-oparg))))])) + (ensure-number (evaluate-oparg m (SubtractArg-rhs an-oparg))))] + + + + [(ControlStackLabel? an-oparg) + (let ([frame (ensure-frame (first (machine-control m)))]) + (cond + [(GenericFrame? frame) + (error 'GetControlStackLabel)] + [(PromptFrame? frame) + (let ([label (PromptFrame-return frame)]) + (LinkedLabel-label label))] + [(CallFrame? frame) + (let ([label (CallFrame-return frame)]) + (LinkedLabel-label label))]))] + + [(ControlStackLabel/MultipleValueReturn? an-oparg) + (let ([frame (ensure-frame (first (machine-control m)))]) + (cond + [(GenericFrame? frame) + (error 'GetControlStackLabel/MultipleValueReturn)] + [(PromptFrame? frame) + (let ([label (PromptFrame-return frame)]) + (LinkedLabel-linked-to label))] + [(CallFrame? frame) + (let ([label (CallFrame-return frame)]) + (LinkedLabel-linked-to label))]))])) (: ensure-closure-or-false (SlotValue -> (U closure #f))) diff --git a/test-simulator.rkt b/test-simulator.rkt index 8d86df3..b6253e0 100644 --- a/test-simulator.rkt +++ b/test-simulator.rkt @@ -485,19 +485,19 @@ (list 126389 42 (make-toplevel '(+) (list (lookup-primitive '+)))))) -;; GetControlStackLabel +;; ControlStackLabel (let ([m (new-machine `(,(make-AssignImmediateStatement 'proc (make-Const #f)) foo ,(make-PushControlFrame/Call (make-LinkedLabel 'foo 'foo)) - ,(make-AssignPrimOpStatement 'proc (make-GetControlStackLabel))))]) + ,(make-AssignImmediateStatement 'proc (make-ControlStackLabel))))]) (test (machine-proc (run! m)) 'foo)) -;; GetControlStackLabel +;; ControlStackLabel (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-AssignImmediateStatement 'proc (make-ControlStackLabel)) ,(make-GotoStatement (make-Reg 'proc)) foo-single ,(make-AssignImmediateStatement 'val (make-Const "single")) @@ -510,7 +510,7 @@ "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-AssignImmediateStatement 'proc (make-ControlStackLabel/MultipleValueReturn)) ,(make-GotoStatement (make-Reg 'proc)) foo-single ,(make-AssignImmediateStatement 'val (make-Const "single")) @@ -526,7 +526,7 @@ (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-AssignImmediateStatement 'proc (make-ControlStackLabel)) ,(make-GotoStatement (make-Reg 'proc)) foo-single ,(make-AssignImmediateStatement 'val (make-Const "single")) @@ -540,7 +540,7 @@ (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-AssignImmediateStatement 'proc (make-ControlStackLabel/MultipleValueReturn)) ,(make-GotoStatement (make-Reg 'proc)) foo-single ,(make-AssignImmediateStatement 'val (make-Const "single"))