introducing prompts in the simulator

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)

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 
+     (end-with-linkage 
-                                    `(,(make-GotoStatement (make-Label after-lam-bodies))))
+      linkage '() 
-                                   (compile-lambda-bodies (collect-all-lams exp))
+      (append-instruction-sequences (make-instruction-sequence 
-                                   after-lam-bodies
+                                     `(,(make-GotoStatement (make-Label after-lam-bodies))))
-                                   (compile exp
+                                    (compile-lambda-bodies (collect-all-lams exp))
-                                            '()
+                                    after-lam-bodies
-                                            target 
+                                    (make-instruction-sequence
-                                            linkage)))))
+                                     `(,(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]))

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! ())

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))
 

simulator.rkt

@@ -260,8 +260,18 @@
                  'ok)]
           
           [(RestoreControl!? op)
-           (set-machine-control! m (CapturedControl-frames (ensure-CapturedControl (env-ref m 0))))
+           (let: ([tag-value : ContinuationPromptTagValue
-           'ok]
+                             (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)
+           (target-updater! m (evaluate-continuation-capture m op))]
-                                                          (CaptureControl-skip 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)]

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)