diff --git a/assemble-helpers.rkt b/assemble-helpers.rkt index 32ae6e4..651c4d5 100644 --- a/assemble-helpers.rkt +++ b/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))])) diff --git a/assemble.rkt b/assemble.rkt index 249464a..ee71a99 100644 --- a/assemble.rkt +++ b/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);")])) diff --git a/compiler.rkt b/compiler.rkt index 759282c..1e5f24d 100644 --- a/compiler.rkt +++ b/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))])) diff --git a/expression-structs.rkt b/expression-structs.rkt index bf33f21..f3ad0e7 100644 --- a/expression-structs.rkt +++ b/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))) diff --git a/il-structs.rkt b/il-structs.rkt index bdf0200..26e6599 100644 --- a/il-structs.rkt +++ b/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! diff --git a/runtime.js b/runtime.js index 2c2ec5e..22861cf 100644 --- a/runtime.js +++ b/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); diff --git a/simulator-structs.rkt b/simulator-structs.rkt index 2e64205..91a4e37 100644 --- a/simulator-structs.rkt +++ b/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]) diff --git a/simulator.rkt b/simulator.rkt index 0c3139c..9179dde 100644 --- a/simulator.rkt +++ b/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)) diff --git a/test-simulator.rkt b/test-simulator.rkt index 9c3d12e..f5b57f2 100644 --- a/test-simulator.rkt +++ b/test-simulator.rkt @@ -173,8 +173,8 @@ baz ))]) (test (machine-control (run! m)) - (list (make-CallFrame 'bar #f) - (make-CallFrame 'foo #f)))) + (list (make-CallFrame 'bar #f (make-hasheq) (make-hasheq)) + (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