in the middle of continuation marks

assemble-helpers.rkt

@@ -50,7 +50,10 @@
     [(EnvPrefixReference? target)
      (assemble-prefix-reference target)]
     [(PrimitivesReference? target)
-     (format "MACHINE.primitives[~s]" (symbol->string (PrimitivesReference-name target)))]))
+     (format "MACHINE.primitives[~s]" (symbol->string (PrimitivesReference-name target)))]
+    [(ControlFrameTemporary? target)
+     (format "MACHINE.control[MACHINE.control.length-1].~a"
+             (ControlFrameTemporary-name target))]))
 
 
 

assemble.rkt

@@ -228,6 +228,8 @@ EOF
       [(UnspliceRestFromStack!? op)
        empty]
       [(FixClosureShellMap!? op)
+       empty]
+      [(InstallContinuationMarkEntry!? op)
        empty]))
   
   (unique/eq?
@@ -588,7 +590,11 @@ EOF
     [(UnspliceRestFromStack!? op)
      (format "RUNTIME.unspliceRestFromStack(MACHINE, ~a, ~a);"
              (assemble-oparg (UnspliceRestFromStack!-depth op))
-             (assemble-oparg (UnspliceRestFromStack!-length op)))]))
+             (assemble-oparg (UnspliceRestFromStack!-length op)))]
+    [(InstallContinuationMarkEntry!? op)
+     (string-append "RUNTIME.installContinuationMarkEntry(MACHINE,"
+                    "MACHINE.control[MACHINE.control.length-1].pendingContinuationMarkKey,"
+                    "MACHINE.val);")]))
 
 
 

compiler.rkt

@@ -107,7 +107,11 @@
                             (map (lambda: ([lam : Lam])
                                           (loop lam new-cenv))
                                  (LetRec-procs exp)))
-                     (loop (LetRec-body exp) new-cenv)))])))
+                     (loop (LetRec-body exp) new-cenv)))]
+          [(WithContMark? exp)
+           (append (loop (WithContMark-key exp) cenv)
+                   (loop (WithContMark-value exp) cenv)
+                   (loop (WithContMark-body exp) cenv))])))
 
 
 
@@ -162,7 +166,9 @@
     [(BoxEnv? exp)
      (compile-box-environment-value exp cenv target linkage)]
     [(LetRec? exp)
-     (compile-let-rec exp cenv target linkage)]))
+     (compile-let-rec exp cenv target linkage)]
+    [(WithContMark? exp)
+     (compile-with-cont-mark exp cenv target linkage)]))
 
 
 
@@ -1260,6 +1266,26 @@
    (compile (BoxEnv-body exp) cenv target linkage)))
 
 
+
+(: compile-with-cont-mark (WithContMark CompileTimeEnvironment Target Linkage -> InstructionSequence))
+(define (compile-with-cont-mark exp cenv target linkage)
+  (append-instruction-sequences
+   (compile (WithContMark-key exp) cenv 'val next-linkage)
+   (make-instruction-sequence `(,(make-AssignImmediateStatement
+                                  (make-ControlFrameTemporary 'pendingContinuationMarkKey)
+                                  (make-Reg 'val))))
+   (compile (WithContMark-value exp) cenv 'val next-linkage)
+   (make-instruction-sequence `(,(make-PerformStatement
+                                    (make-InstallContinuationMarkEntry!))))
+   (compile (WithContMark-body exp) cenv target linkage)))
+
+
+
+
+
+
+
+
 (: append-instruction-sequences (InstructionSequence * -> InstructionSequence))
 (define (append-instruction-sequences . seqs)
   (append-seq-list seqs))
@@ -1313,6 +1339,8 @@
      (make-EnvPrefixReference (+ n (EnvPrefixReference-depth target))
                               (EnvPrefixReference-pos target))]
     [(PrimitivesReference? target)
+     target]
+    [(ControlFrameTemporary? target)
      target]))
 
 
@@ -1430,6 +1458,11 @@
          (make-BoxEnv (BoxEnv-depth exp)
                       (adjust-expression-depth (BoxEnv-body exp) n skip))
          (make-BoxEnv (ensure-natural (- (BoxEnv-depth exp) n))
-                      (adjust-expression-depth (BoxEnv-body exp) n skip)))]))
+                      (adjust-expression-depth (BoxEnv-body exp) n skip)))]
+
+    [(WithContMark? exp)
+     (make-WithContMark (adjust-expression-depth (WithContMark-key exp) n skip)
+                        (adjust-expression-depth (WithContMark-value exp) n skip)
+                        (adjust-expression-depth (WithContMark-body exp) n skip))]))
 
 

expression-structs.rkt

@@ -13,7 +13,8 @@
                                LetVoid 
                                LetRec
                                InstallValue
-                               BoxEnv))
+                               BoxEnv
+                               WithContMark))
 
 (define-struct: Top ([prefix : Prefix]
                      [code : Expression]) #:transparent)
@@ -73,6 +74,12 @@
 
 
 
+(define-struct: WithContMark ([key : Expression]
+                              [value : Expression]
+                              [body : Expression])
+  #:transparent)
+
+
 (: last-exp? ((Listof Expression) -> Boolean))
 (define (last-exp? seq) 
   (null? (cdr seq)))

il-structs.rkt

@@ -34,7 +34,13 @@
 (define-type Target (U AtomicRegisterSymbol 
                        EnvLexicalReference
                        EnvPrefixReference
-                       PrimitivesReference))
+                       PrimitivesReference                   
+                       ControlFrameTemporary))
+
+
+;; When we need to store a value temporarily in the top control frame, we can use this as a target.
+(define-struct: ControlFrameTemporary ([name : (U 'pendingContinuationMarkKey)])
+  #:transparent)
 
 
 
@@ -305,12 +311,14 @@
   #:transparent)
 
 ;; Changes over the control located at the given argument from the structure in env[1]
-(define-struct: RestoreControl! ([tag : (U DefaultContinuationPromptTag OpArg)]))
+(define-struct: RestoreControl! ([tag : (U DefaultContinuationPromptTag OpArg)]) #:transparent)
 
 ;; Changes over the environment located at the given argument from the structure in env[0]
-(define-struct: RestoreEnvironment! ())
+(define-struct: RestoreEnvironment! () #:transparent)
 
 
+;; Adds a continuation mark into the current top control frame.
+(define-struct: InstallContinuationMarkEntry! () #:transparent)
 
 (define-type PrimitiveCommand (U                                
                                CheckToplevelBound!
@@ -320,6 +328,8 @@
                                ExtendEnvironment/Prefix!
                                InstallClosureValues!
                                FixClosureShellMap!
+           
+                               InstallContinuationMarkEntry!
                                
                                SetFrameCallee!
                                SpliceListIntoStack!

runtime.js

@@ -92,6 +92,13 @@
     var CallFrame = function(label, proc) {
 	this.label = label;
 	this.proc = proc;
+
+	// When we're in the middle of computing with-cont-mark, we
+	// stash the key in here temporarily.
+	this.pendingContinuationMarkKey = undefined;
+
+	// The set of continuation marks.
+	this.marks = [];
     };
     CallFrame.prototype = heir(Frame.prototype);
 
@@ -99,6 +106,15 @@
     var PromptFrame = function(label, tag) {
 	this.label = label;
 	this.tag = tag; // ContinuationPromptTag
+
+	// The set of continuation marks.
+	this.marks = [];
+
+
+	// When we're in the middle of computing with-cont-mark, we
+	// stash the key in here temporarily.
+	this.pendingContinuationMarkKey = undefined;
+	
     };
     PromptFrame.prototype = heir(Frame.prototype);
 

simulator-structs.rkt

@@ -62,13 +62,16 @@
                            ;; The procedure being called.  Used to optimize self-application
                            [proc : (U closure #f)]
                            ;; TODO: add continuation marks
-                           )
+                           [temps : (HashTable Symbol PrimitiveValue)]
+                           [marks : (HashTable PrimitiveValue PrimitiveValue)])
   #:transparent
   #:mutable)
 
 (define-struct: PromptFrame ([tag : ContinuationPromptTagValue]
                              [return : (U Symbol LinkedLabel)]
-                             [env-depth : Natural])
+                             [env-depth : Natural]
+                             [temps : (HashTable Symbol PrimitiveValue)]
+                             [marks : (HashTable PrimitiveValue PrimitiveValue)])
   #:transparent)
 
 (define-struct: ContinuationPromptTagValue ([name : Symbol])

simulator.rkt

@@ -172,7 +172,9 @@
 (: step-push-control-frame! (machine PushControlFrame -> 'ok))
 (define (step-push-control-frame! m stmt)
   (control-push! m (make-CallFrame (PushControlFrame-label stmt)
-                                   (ensure-closure-or-false (machine-proc m)))))
+                                   (ensure-closure-or-false (machine-proc m))
+                                   (make-hasheq)
+                                   (make-hasheq))))
 
 (: step-push-control-frame/prompt! (machine PushControlFrame/Prompt -> 'ok))
 (define (step-push-control-frame/prompt! m stmt)
@@ -184,9 +186,11 @@
                         [(OpArg? tag)
                          (ensure-continuation-prompt-tag-value (evaluate-oparg m tag))]))
                     (PushControlFrame/Prompt-label stmt)
-                    (length (machine-env m)))))
+                    (length (machine-env m))
-                        
+                    (make-hasheq)
-  
+                    (make-hasheq))))
+
+
 
 (: step-pop-control-frame! (machine (U PopControlFrame PopControlFrame/Prompt) -> 'ok))
 (define (step-pop-control-frame! m stmt)
@@ -359,7 +363,18 @@
           [(RestoreEnvironment!? op)
            (set-machine-env! m (CapturedEnvironment-vals (ensure-CapturedEnvironment (env-ref m 1))))
            (set-machine-stack-size! m (length (machine-env m)))
-           'ok])))
+           'ok]
+          
+          [(InstallContinuationMarkEntry!? op)
+           (let* ([a-frame (control-top m)]
+                  [key (hash-ref (frame-temps a-frame) 'pendingContinuationMarkKey)]
+                  [val (machine-val m)]
+                  [marks (frame-marks a-frame)])
+             (hash-set! marks 
+                        (ensure-primitive-value key)
+                        (ensure-primitive-value val))
+             'ok)]
+          )))
 
 
 
@@ -433,7 +448,31 @@
      (lambda: ([m : machine] [v : SlotValue])
               (set-primitive! (PrimitivesReference-name t)
                               (ensure-primitive-value v))
-              'ok)]))
+              'ok)]
+    [(ControlFrameTemporary? t)
+     (lambda: ([m : machine] [v : SlotValue])
+              (let ([ht (frame-temps (control-top m))])
+                (hash-set! ht
+                           (ControlFrameTemporary-name t)
+                           (ensure-primitive-value v))
+                'ok))]))
+
+(: frame-temps (frame -> (HashTable Symbol PrimitiveValue)))
+(define (frame-temps a-frame)
+  (cond
+    [(CallFrame? a-frame)
+     (CallFrame-temps a-frame)]
+    [(PromptFrame? a-frame)
+     (PromptFrame-temps a-frame)]))
+
+
+(: frame-marks (frame -> (HashTable PrimitiveValue PrimitiveValue)))
+(define (frame-marks a-frame)
+  (cond
+    [(CallFrame? a-frame)
+     (CallFrame-marks a-frame)]
+    [(PromptFrame? a-frame)
+     (PromptFrame-marks a-frame)]))
 
 
 (: step-assign-primitive-operation! (machine AssignPrimOpStatement -> 'ok))

test-simulator.rkt

@@ -173,8 +173,8 @@
                         baz
                         ))])
   (test (machine-control (run! m))
-        (list (make-CallFrame 'bar #f)
+        (list (make-CallFrame 'bar #f (make-hasheq) (make-hasheq))
-              (make-CallFrame 'foo #f))))
+              (make-CallFrame 'foo #f (make-hasheq) (make-hasheq)))))
 
 
 
@@ -188,7 +188,7 @@
                         ,(make-PopControlFrame)
                         ))])
   (test (machine-control (run! m))
-        (list (make-CallFrame 'foo #f))))
+        (list (make-CallFrame 'foo #f (make-hasheq) (make-hasheq)))))
 
 (let ([m (new-machine `(,(make-AssignImmediateStatement 'proc (make-Const #f))
                         foo