suzanne.soy/whalesong
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

in the middle of continuation marks

Browse Source
This commit is contained in:
Danny Yoo 2011-04-13 16:20:47 -04:00
parent 66e57b4805
commit a1aa14885a
9 changed files with 137 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
assemble-helpers.rkt
View File

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

8
assemble.rkt
View File

@ -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);")]))

39
compiler.rkt
View File

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

9
expression-structs.rkt
View File

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

16
il-structs.rkt
View File

@ -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!

16
runtime.js
View File

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

7
simulator-structs.rkt
View File

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

51
simulator.rkt
View File

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

6
test-simulator.rkt
View File

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