diff --git a/bootstrapped-primitives.rkt b/bootstrapped-primitives.rkt index c13a3a1..34c6545 100644 --- a/bootstrapped-primitives.rkt +++ b/bootstrapped-primitives.rkt @@ -34,7 +34,7 @@ ;; Next, capture the envrionment and the current continuation closure,. ,(make-PushEnvironment 2 #f) ,(make-AssignPrimOpStatement (make-EnvLexicalReference 0 #f) - (make-CaptureControl 0)) + (make-CaptureControl 0 default-continuation-prompt-tag)) ,(make-AssignPrimOpStatement (make-EnvLexicalReference 1 #f) ;; When capturing, skip over f and the two slots we just added. (make-CaptureEnvironment 3)) @@ -52,12 +52,13 @@ 'val return-linkage) - ;; The code for the continuation coe follows. It's supposed to + ;; The code for the continuation code follows. It's supposed to ;; abandon the current continuation, initialize the control and environment, and then jump. (make-instruction-sequence `(,call/cc-closure-entry ,(make-AssignImmediateStatement 'val (make-EnvLexicalReference 0 #f)) ,(make-PerformStatement (make-InstallClosureValues!)) - ,(make-PerformStatement (make-RestoreControl!)) + ,(make-PerformStatement + (make-RestoreControl! default-continuation-prompt-tag)) ,(make-PerformStatement (make-RestoreEnvironment!)) ,(make-AssignPrimOpStatement 'proc (make-GetControlStackLabel)) ,(make-PopControlFrame) diff --git a/compile.rkt b/compile.rkt index e5f4a1d..8188d21 100644 --- a/compile.rkt +++ b/compile.rkt @@ -23,14 +23,20 @@ (define (-compile exp target linkage) (let ([after-lam-bodies (make-label 'afterLamBodies)]) (statements - (append-instruction-sequences (make-instruction-sequence - `(,(make-GotoStatement (make-Label after-lam-bodies)))) - (compile-lambda-bodies (collect-all-lams exp)) - after-lam-bodies - (compile exp - '() - target - linkage))))) + (end-with-linkage + linkage '() + (append-instruction-sequences (make-instruction-sequence + `(,(make-GotoStatement (make-Label after-lam-bodies)))) + (compile-lambda-bodies (collect-all-lams exp)) + after-lam-bodies + (make-instruction-sequence + `(,(make-PushControlFrame/Prompt default-continuation-prompt-tag))) + (compile exp + '() + target + next-linkage) + (make-instruction-sequence + `(,(make-PopControlFrame)))))))) (define-struct: lam+cenv ([lam : Lam] [cenv : CompileTimeEnvironment])) diff --git a/il-structs.rkt b/il-structs.rkt index 5e18335..c266275 100644 --- a/il-structs.rkt +++ b/il-structs.rkt @@ -198,7 +198,8 @@ (define-struct: CaptureEnvironment ([skip : Natural])) ;; Capture the control stack, skipping skip frames. -(define-struct: CaptureControl ([skip : Natural])) +(define-struct: CaptureControl ([skip : Natural] + [tag : (U DefaultContinuationPromptTag OpArg)])) @@ -245,7 +246,7 @@ #:transparent) ;; Changes over the control located at the given argument from the structure in env[1] -(define-struct: RestoreControl! ()) +(define-struct: RestoreControl! ([tag : (U DefaultContinuationPromptTag OpArg)])) ;; Changes over the environment located at the given argument from the structure in env[0] (define-struct: RestoreEnvironment! ()) diff --git a/simulator-primitives.rkt b/simulator-primitives.rkt index 0ee393c..ee6ad13 100644 --- a/simulator-primitives.rkt +++ b/simulator-primitives.rkt @@ -1,7 +1,5 @@ #lang racket/base (require "simulator-structs.rkt" - "compile.rkt" - "bootstrapped-primitives.rkt" racket/math (for-syntax racket/base)) diff --git a/simulator.rkt b/simulator.rkt index bede678..a5f4e23 100644 --- a/simulator.rkt +++ b/simulator.rkt @@ -260,8 +260,18 @@ 'ok)] [(RestoreControl!? op) - (set-machine-control! m (CapturedControl-frames (ensure-CapturedControl (env-ref m 0)))) - 'ok] + (let: ([tag-value : ContinuationPromptTagValue + (let ([tag (RestoreControl!-tag op)]) + (cond + [(DefaultContinuationPromptTag? tag) + default-continuation-prompt-tag-value] + [(OpArg? tag) + (ensure-continuation-prompt-tag-value (evaluate-oparg m tag))]))]) + (set-machine-control! m (append + (CapturedControl-frames (ensure-CapturedControl (env-ref m 0))) + (drop-continuation-to-tag (machine-control m) + tag-value))) + 'ok)] [(RestoreEnvironment!? op) (set-machine-env! m (CapturedEnvironment-vals (ensure-CapturedEnvironment (env-ref m 1)))) @@ -346,8 +356,8 @@ (target-updater! m (make-CapturedEnvironment (drop (machine-env m) (CaptureEnvironment-skip op))))] [(CaptureControl? op) - (target-updater! m (make-CapturedControl (drop (machine-control m) - (CaptureControl-skip op))))] + (target-updater! m (evaluate-continuation-capture m op))] + [(MakeBoxedEnvironmentValue? op) (target-updater! m (box (ensure-primitive-value (env-ref m (MakeBoxedEnvironmentValue-depth op)))))] @@ -356,6 +366,61 @@ (target-updater! m (evaluate-kernel-primitive-procedure-call m op))]))) +(: evaluate-continuation-capture (machine CaptureControl -> SlotValue)) +(define (evaluate-continuation-capture m op) + (let: ([frames : (Listof frame) (drop (machine-control m) + (CaptureControl-skip op))] + [tag : ContinuationPromptTagValue + (let ([tag (CaptureControl-tag op)]) + (cond + [(DefaultContinuationPromptTag? tag) + default-continuation-prompt-tag-value] + [(OpArg? tag) + (ensure-continuation-prompt-tag-value (evaluate-oparg m tag))]))]) + (make-CapturedControl (take-continuation-to-tag frames tag)))) + + +(: take-continuation-to-tag ((Listof frame) ContinuationPromptTagValue -> (Listof frame))) +(define (take-continuation-to-tag frames tag) + (cond + [(empty? frames) + (error 'trim-continuation-at-tag "Unable to find continuation tag value ~s" tag)] + [else + (let ([a-frame (first frames)]) + (cond + [(CallFrame? a-frame) + (cons a-frame (take-continuation-to-tag (rest frames) tag))] + [(PromptFrame? a-frame) + (cond + [(eq? (PromptFrame-tag a-frame) tag) + '()] + [else + (cons a-frame (take-continuation-to-tag (rest frames) tag))])]))])) + + +(: drop-continuation-to-tag ((Listof frame) ContinuationPromptTagValue -> (Listof frame))) +;; Drops continuation frames until we reach the appropriate one. +(define (drop-continuation-to-tag frames tag) + (cond + [(empty? frames) + (error 'trim-continuation-at-tag "Unable to find continuation tag value ~s" tag)] + [else + (let ([a-frame (first frames)]) + (cond + [(CallFrame? a-frame) + (drop-continuation-to-tag (rest frames) tag)] + [(PromptFrame? a-frame) + (cond + [(eq? (PromptFrame-tag a-frame) tag) + frames] + [else + (drop-continuation-to-tag (rest frames) tag)])]))])) + + + + + + (: evaluate-kernel-primitive-procedure-call (machine CallKernelPrimitiveProcedure -> PrimitiveValue)) (define (evaluate-kernel-primitive-procedure-call m op) (let: ([op : KernelPrimitiveName (CallKernelPrimitiveProcedure-operator op)] diff --git a/test-compiler.rkt b/test-compiler.rkt index b305e25..9530003 100644 --- a/test-compiler.rkt +++ b/test-compiler.rkt @@ -443,7 +443,7 @@ 33644764876431783266621612005107543310302148460680063906564769974680081442166662368155595513633734025582065332680836159373734790483865268263040892463056431887354544369559827491606602099884183933864652731300088830269235673613135117579297437854413752130520504347701602264758318906527890855154366159582987279682987510631200575428783453215515103870818298969791613127856265033195487140214287532698187962046936097879900350962302291026368131493195275630227837628441540360584402572114334961180023091208287046088923962328835461505776583271252546093591128203925285393434620904245248929403901706233888991085841065183173360437470737908552631764325733993712871937587746897479926305837065742830161637408969178426378624212835258112820516370298089332099905707920064367426202389783111470054074998459250360633560933883831923386783056136435351892133279732908133732642652633989763922723407882928177953580570993691049175470808931841056146322338217465637321248226383092103297701648054726243842374862411453093812206564914032751086643394517512161526545361333111314042436854805106765843493523836959653428071768775328348234345557366719731392746273629108210679280784718035329131176778924659089938635459327894523777674406192240337638674004021330343297496902028328145933418826817683893072003634795623117103101291953169794607632737589253530772552375943788434504067715555779056450443016640119462580972216729758615026968443146952034614932291105970676243268515992834709891284706740862008587135016260312071903172086094081298321581077282076353186624611278245537208532365305775956430072517744315051539600905168603220349163222640885248852433158051534849622434848299380905070483482449327453732624567755879089187190803662058009594743150052402532709746995318770724376825907419939632265984147498193609285223945039707165443156421328157688908058783183404917434556270520223564846495196112460268313970975069382648706613264507665074611512677522748621598642530711298441182622661057163515069260029861704945425047491378115154139941550671256271197133252763631939606902895650288268608362241082050562430701794976171121233066073310059947366875 #:stack-limit 10 - #:control-limit 2) + #:control-limit 3) @@ -577,7 +577,7 @@ (sum-iter 300 0)) 45150 #:stack-limit 8 - #:control-limit 2) + #:control-limit 3) (test '(let ([x 16]) @@ -782,7 +782,7 @@ (sum-iter 300 0)) 45150 #:stack-limit 10 - #:control-limit 2) + #:control-limit 3)