introducing prompts

compile.rkt

@@ -308,14 +308,16 @@
           linkage
           cenv
           (append-instruction-sequences 
-           #;(make-instruction-sequence `(,(make-PushPrompt)))
+           (make-instruction-sequence `(,(make-PushControlFrame/Prompt
+                                          default-continuation-prompt-tag)))
            (compile (first-exp seq) cenv target next-linkage)
-           #;(make-instruction-sequence `(,(make-PushPrompt)))))]
+           (make-instruction-sequence `(,(make-PopControlFrame)))))]
         [else
          (append-instruction-sequences 
-          #;(make-instruction-sequence `(,(make-PushPrompt)))
+          (make-instruction-sequence `(,(make-PushControlFrame/Prompt
+                                         (make-DefaultContinuationPromptTag))))
           (compile (first-exp seq) cenv target next-linkage)
-          #;(make-instruction-sequence `(,(make-PushPrompt)))
+          (make-instruction-sequence `(,(make-PopControlFrame)))
           (compile-splice (rest-exps seq) cenv target linkage))]))
 
 

il-structs.rkt

@@ -66,6 +66,7 @@
                                  PopEnvironment
                                  PushEnvironment
                                  PushControlFrame
+                                 PushControlFrame/Prompt
                                  PopControlFrame))
 
 (define-type Statement (U UnlabeledStatement
@@ -98,6 +99,19 @@
 (define-struct: PushControlFrame ([label : Symbol]) 
   #:transparent)
 
+(define-struct: PushControlFrame/Prompt ([tag : (U OpArg DefaultContinuationPromptTag)]
+                                         ;; TODO: add handler and arguments
+                                         )
+  #:transparent)
+
+(define-struct: DefaultContinuationPromptTag ()
+  #:transparent)
+(define default-continuation-prompt-tag 
+  (make-DefaultContinuationPromptTag))
+
+
+
+
 (define-struct: GotoStatement ([target : (U Label Reg)]) 
   #:transparent)
 
@@ -326,3 +340,6 @@
                             [stmts : (Listof UnlabeledStatement)]) 
   #:transparent)
 
+
+
+(define-predicate OpArg? OpArg)

simulator-helpers.rkt

@@ -28,7 +28,7 @@
        v]
       [(null? v)
        v]
-      [(void? v)
+      [(VoidValue? v)
        v]
       [(MutablePair? v)
        v]
@@ -68,8 +68,8 @@
      v]
     [(null? v)
      v]
-    [(void? v)
+    [(VoidValue? v)
-     v]
+     (void)]
     [(undefined? v)
      (letrec ([x x]) x)]
     [(primitive-proc? v)
@@ -96,7 +96,7 @@
     [(null? v)
      v]
     [(void? v)
-     v]
+     the-void-value]
     [(eq? v (letrec ([x x]) x))
      (make-undefined)]
     [(procedure? v)

simulator-primitives.rkt

@@ -81,7 +81,8 @@
                    (vector-ref x 0)))
 
 (define my-set-box! (lambda (x v)
-                   (vector-set! x 0 v)))
+                      (vector-set! x 0 v)
+                      the-void-value))
 
 (define my-vector->list (lambda (v)
                           (apply my-list (vector->list v))))
@@ -98,15 +99,31 @@
                                 
 
 (define my-set-car! (lambda (p v)
-                      (set-MutablePair-h! p v)))
+                      (set-MutablePair-h! p v)
+                      the-void-value))
 
 (define my-set-cdr! (lambda (p v)
-                      (set-MutablePair-t! p v)))
+                      (set-MutablePair-t! p v)
+                      the-void-value))
+
+(define my-void (lambda args
+                  the-void-value))
+
+(define my-display (lambda args
+                     (apply display args)
+                     the-void-value))
+
+(define my-displayln (lambda args
+                       (apply displayln args)
+                       the-void-value))
+
+(define my-newline (lambda args
+                     (apply newline args)
+                     the-void-value))
 
 
 (define lookup-primitive (make-lookup #:functions (+ - * / = < <= > >= 
                                                      sub1
-                                                     display newline displayln
                                                      not
                                                      null?
                                                      eq?
@@ -114,12 +131,13 @@
                                                      sub1
                                                      zero?
                                                      abs
-                                                     void
+                                                     (my-void void)
                                                      quotient
                                                      remainder
-                                                     display
+ 
-                                                     displayln
+                                                     (my-display display)
-                                                     newline
+                                                     (my-displayln displayln)
+                                                     (my-newline newline)
                                                     
                                                      symbol->string
                                                      string-append

simulator-structs.rkt

@@ -7,7 +7,7 @@
 
 
 (define-type PrimitiveValue (Rec PrimitiveValue (U String Number Symbol Boolean
-                                                   Null Void
+                                                   Null VoidValue
                                                    undefined
                                                    
                                                    primitive-proc 
@@ -24,6 +24,10 @@
                           CapturedEnvironment))
 
 
+(define-struct: VoidValue () #:transparent)
+(define the-void-value (make-VoidValue))
+
+
 (define-struct: MutablePair ([h : PrimitiveValue]
                              [t : PrimitiveValue])
   #:mutable #:transparent)
@@ -51,12 +55,24 @@
   #:mutable)
 
 
-(define-struct: frame ([return : Symbol]
+(define-type frame (U CallFrame PromptFrame))
-                       ;; The procedure being called.  Used to optimize self-application
+
-                       [proc : (U closure #f)]
+(define-struct: CallFrame ([return : Symbol]
-                       ;; TODO: add continuation marks
+                           ;; The procedure being called.  Used to optimize self-application
-                       )
+                           [proc : (U closure #f)]
+                           ;; TODO: add continuation marks
+                           )
   #:transparent)
+(define-struct: PromptFrame ([tag : ContinuationPromptTagValue])
+  #:transparent)
+
+(define-struct: ContinuationPromptTagValue ([name : Symbol])
+  #:transparent)
+
+(define default-continuation-prompt-tag-value 
+  (make-ContinuationPromptTagValue 'default-continuation-prompt))
+
+
 
 (define-struct: toplevel ([names : (Listof (U #f Symbol ModuleVariable))]
                           [vals : (Listof PrimitiveValue)])

simulator.rkt

@@ -83,29 +83,32 @@
 (: step! (machine -> 'ok))
 ;; Take one simulation step.
 (define (step! m)
-  (let: ([i : Statement (current-instruction m)])
+  (let*: ([i : Statement (current-instruction m)]
-        (cond
+          [result : 'ok
-          [(symbol? i)
+                  (cond
-           'ok]
+                    [(symbol? i)
-          [(AssignImmediateStatement? i)
+                     'ok]
-           (step-assign-immediate! m i)]
+                    [(AssignImmediateStatement? i)
-          [(AssignPrimOpStatement? i)
+                     (step-assign-immediate! m i)]
-           (step-assign-primitive-operation! m i)]
+                    [(AssignPrimOpStatement? i)
-          [(PerformStatement? i)
+                     (step-assign-primitive-operation! m i)]
-           (step-perform! m i)]
+                    [(PerformStatement? i)
-          [(GotoStatement? i)
+                     (step-perform! m i)]
-           (step-goto! m i)]
+                    [(GotoStatement? i)
-          [(TestAndBranchStatement? i)
+                     (step-goto! m i)]
-           (step-test-and-branch! m i)]
+                    [(TestAndBranchStatement? i)
-          [(PopEnvironment? i)
+                     (step-test-and-branch! m i)]
-           (step-pop-environment! m i)]
+                    [(PopEnvironment? i)
-          [(PushEnvironment? i)
+                     (step-pop-environment! m i)]
-           (step-push-environment! m i)]
+                    [(PushEnvironment? i)
-          [(PushControlFrame? i)
+                     (step-push-environment! m i)]
-           (step-push-control-frame! m i)]
+                    [(PushControlFrame? i)
-          [(PopControlFrame? i)
+                     (step-push-control-frame! m i)]
-           (step-pop-control-frame! m i)]))
+                    [(PushControlFrame/Prompt? i)
-  (increment-pc! m))
+                     (step-push-control-frame/prompt! m i)]
+                    [(PopControlFrame? i)
+                     (step-pop-control-frame! m i)])])
+         (increment-pc! m)))
 
 
 
@@ -149,8 +152,20 @@
 
 (: step-push-control-frame! (machine PushControlFrame -> 'ok))
 (define (step-push-control-frame! m stmt)
-  (control-push! m (make-frame (PushControlFrame-label stmt)
+  (control-push! m (make-CallFrame (PushControlFrame-label stmt)
-                               (ensure-closure-or-false (machine-proc m)))))
+                                   (ensure-closure-or-false (machine-proc m)))))
+
+(: step-push-control-frame/prompt! (machine PushControlFrame/Prompt -> 'ok))
+(define (step-push-control-frame/prompt! m stmt)
+  (control-push! m (make-PromptFrame
+                    (let ([tag (PushControlFrame/Prompt-tag stmt)])
+                      (cond 
+                        [(DefaultContinuationPromptTag? tag)
+                         default-continuation-prompt-tag-value]
+                        [(OpArg? tag)
+                         (ensure-continuation-prompt-tag-value (evaluate-oparg m tag))])))))
+                        
+  
 
 (: step-pop-control-frame! (machine PopControlFrame -> 'ok))
 (define (step-pop-control-frame! m stmt)
@@ -325,7 +340,7 @@
                     (error 'apply-primitive-procedure)]))]
           
           [(GetControlStackLabel? op)
-           (target-updater! m (frame-return (first (machine-control m))))]
+           (target-updater! m (CallFrame-return (ensure-CallFrame (first (machine-control m)))))]
 
           [(CaptureEnvironment? op)
            (target-updater! m (make-CapturedEnvironment (drop (machine-env m)
@@ -381,7 +396,8 @@
            (let: loop : PrimitiveValue ([rand-vals : (Listof PrimitiveValue) rand-vals])
              (cond [(empty? rand-vals)
                     null]
-                   [(make-MutablePair (first rand-vals)
+                   [else
+                    (make-MutablePair (first rand-vals)
                                       (loop (rest rand-vals)))]))]
           [(null?)
            (null? (first rand-vals))]
@@ -453,11 +469,12 @@
      (let: ([v : SlotValue
                (list-ref (machine-env m) (EnvWholePrefixReference-depth an-oparg))])
            (cond
-             [(PrimitiveValue? v)
-              (error 'evaluate-oparg "Internal error: primitive value at depth ~s"
-                     (EnvWholePrefixReference-depth an-oparg))]
              [(toplevel? v)
-              v]))]))
+              v]
+             [else
+              (error 'evaluate-oparg "Internal error: not a toplevel at depth ~s: ~s"
+                     (EnvWholePrefixReference-depth an-oparg)
+                     v)]))]))
 
 
 (: ensure-closure-or-false (SlotValue -> (U closure #f)))
@@ -472,6 +489,18 @@
       v
       (error 'ensure-closure)))
 
+(: ensure-CallFrame (Any -> CallFrame))
+(define (ensure-CallFrame v)
+  (if (CallFrame? v)
+      v
+      (error 'ensure-CallFrame "not a CallFrame: ~s" v)))
+
+(: ensure-continuation-prompt-tag-value (Any -> ContinuationPromptTagValue))
+(define (ensure-continuation-prompt-tag-value v)
+  (if (ContinuationPromptTagValue? v)
+      v
+      (error 'ensure-ContinuationPromptTagValue "not a ContinuationPromptTagValue: ~s" v)))
+
 
 (: ensure-symbol (Any -> Symbol))
 ;; Make sure the value is a symbol.

test-compiler.rkt

@@ -443,7 +443,7 @@
       33644764876431783266621612005107543310302148460680063906564769974680081442166662368155595513633734025582065332680836159373734790483865268263040892463056431887354544369559827491606602099884183933864652731300088830269235673613135117579297437854413752130520504347701602264758318906527890855154366159582987279682987510631200575428783453215515103870818298969791613127856265033195487140214287532698187962046936097879900350962302291026368131493195275630227837628441540360584402572114334961180023091208287046088923962328835461505776583271252546093591128203925285393434620904245248929403901706233888991085841065183173360437470737908552631764325733993712871937587746897479926305837065742830161637408969178426378624212835258112820516370298089332099905707920064367426202389783111470054074998459250360633560933883831923386783056136435351892133279732908133732642652633989763922723407882928177953580570993691049175470808931841056146322338217465637321248226383092103297701648054726243842374862411453093812206564914032751086643394517512161526545361333111314042436854805106765843493523836959653428071768775328348234345557366719731392746273629108210679280784718035329131176778924659089938635459327894523777674406192240337638674004021330343297496902028328145933418826817683893072003634795623117103101291953169794607632737589253530772552375943788434504067715555779056450443016640119462580972216729758615026968443146952034614932291105970676243268515992834709891284706740862008587135016260312071903172086094081298321581077282076353186624611278245537208532365305775956430072517744315051539600905168603220349163222640885248852433158051534849622434848299380905070483482449327453732624567755879089187190803662058009594743150052402532709746995318770724376825907419939632265984147498193609285223945039707165443156421328157688908058783183404917434556270520223564846495196112460268313970975069382648706613264507665074611512677522748621598642530711298441182622661057163515069260029861704945425047491378115154139941550671256271197133252763631939606902895650288268608362241082050562430701794976171121233066073310059947366875
       
       #:stack-limit 10
-      #:control-limit 1)
+      #:control-limit 2)
                   
 
 
@@ -577,7 +577,7 @@
           (sum-iter 300 0))
       45150
       #:stack-limit 8
-      #:control-limit 1)
+      #:control-limit 2)
 
 
 (test '(let ([x 16])
@@ -782,7 +782,7 @@
             (sum-iter 300 0))
         45150
         #:stack-limit 10
-        #:control-limit 1)
+        #:control-limit 2)