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

still debugging

Browse Source
This commit is contained in:
Danny Yoo 2011-04-01 19:44:24 -04:00
parent 8c3a9c5136
commit 570879d194
5 changed files with 69 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

46
compile.rkt
View File

@ -21,7 +21,8 @@
;; Note: the toplevel generates the lambda body streams at the head, and then the
;; rest of the instruction stream.
(define (-compile exp target linkage)
(let ([after-lam-bodies (make-label 'afterLamBodies)])
(let ([after-lam-bodies (make-label 'afterLamBodies)]
[before-pop-prompt (make-label 'beforePopPrompt)])
(statements
(end-with-linkage
linkage '()
@ -30,11 +31,15 @@
(compile-lambda-bodies (collect-all-lams exp))
after-lam-bodies
(make-instruction-sequence
`(,(make-PushControlFrame/Prompt default-continuation-prompt-tag)))
`(,(make-PushControlFrame/Prompt default-continuation-prompt-tag
before-pop-prompt)))
(compile exp
'()
target
next-linkage)
(make-LabelLinkage before-pop-prompt))
before-pop-prompt
(make-instruction-sequence
`(,(make-PopControlFrame))))))))
@ -310,21 +315,28 @@
;; Wrap a continuation prompt around each of the expressions.
(define (compile-splice seq cenv target linkage)
(cond [(last-exp? seq)
(end-with-linkage
linkage
cenv
(append-instruction-sequences
(make-instruction-sequence `(,(make-PushControlFrame/Prompt
default-continuation-prompt-tag)))
(compile (first-exp seq) cenv target next-linkage)
(make-instruction-sequence `(,(make-PopControlFrame)))))]
(let ([before-pop-prompt (make-label 'beforePromptPop)])
(end-with-linkage
linkage
cenv
(append-instruction-sequences
(make-instruction-sequence `(,(make-PushControlFrame/Prompt
default-continuation-prompt-tag
before-pop-prompt
)))
(compile (first-exp seq) cenv target next-linkage)
before-pop-prompt
(make-instruction-sequence `(,(make-PopControlFrame))))))]
[else
(append-instruction-sequences
(make-instruction-sequence `(,(make-PushControlFrame/Prompt
(make-DefaultContinuationPromptTag))))
(compile (first-exp seq) cenv target next-linkage)
(make-instruction-sequence `(,(make-PopControlFrame)))
(compile-splice (rest-exps seq) cenv target linkage))]))
(let ([before-pop-prompt (make-label 'beforePromptPop)])
(append-instruction-sequences
(make-instruction-sequence `(,(make-PushControlFrame/Prompt
(make-DefaultContinuationPromptTag)
before-pop-prompt)))
(compile (first-exp seq) cenv target next-linkage)
before-pop-prompt
(make-instruction-sequence `(,(make-PopControlFrame)))
(compile-splice (rest-exps seq) cenv target linkage)))]))

1
il-structs.rkt
View File

@ -100,6 +100,7 @@
#:transparent)
(define-struct: PushControlFrame/Prompt ([tag : (U OpArg DefaultContinuationPromptTag)]
[label : Symbol]
;; TODO: add handler and arguments
)
#:transparent)

3
simulator-structs.rkt
View File

@ -63,7 +63,8 @@
;; TODO: add continuation marks
)
#:transparent)
(define-struct: PromptFrame ([tag : ContinuationPromptTagValue])
(define-struct: PromptFrame ([tag : ContinuationPromptTagValue]
[label : Symbol])
#:transparent)
(define-struct: ContinuationPromptTagValue ([name : Symbol])

38
simulator.rkt
View File

@ -163,7 +163,8 @@
[(DefaultContinuationPromptTag? tag)
default-continuation-prompt-tag-value]
[(OpArg? tag)
(ensure-continuation-prompt-tag-value (evaluate-oparg m tag))])))))
(ensure-continuation-prompt-tag-value (evaluate-oparg m tag))]))
(PushControlFrame/Prompt-label stmt))))
@ -267,7 +268,7 @@
default-continuation-prompt-tag-value]
[(OpArg? tag)
(ensure-continuation-prompt-tag-value (evaluate-oparg m tag))]))])
(set-machine-control! m (append
(set-machine-control! m (compose-continuation-frames
(CapturedControl-frames (ensure-CapturedControl (env-ref m 0)))
(drop-continuation-to-tag (machine-control m)
tag-value)))
@ -279,6 +280,34 @@
'ok])))
(: compose-continuation-frames ((Listof frame) (Listof frame) -> (Listof frame)))
;; Stitch together the continuation. A PromptFrame must exist at the head of frames-2.
(define (compose-continuation-frames frames-1 frames-2)
(let ([prompt-frame (ensure-prompt-frame (first frames-2))]
[last-frame (last frames-1)])
(let ([result
(append #;frames-1
(drop-right frames-1 1)
(list (cond
[(CallFrame? last-frame)
last-frame #; (update-call-frame-return last-frame (PromptFrame-label prompt-frame))]
[(PromptFrame? last-frame)
last-frame]))
frames-2)])
;(displayln frames-1)
;(displayln frames-2)
;(displayln result)
result)))
(: update-call-frame-return (CallFrame Symbol -> CallFrame))
(define (update-call-frame-return a-call-frame a-return)
(make-CallFrame a-return
(CallFrame-proc a-call-frame)))
(: get-target-updater (Target -> (machine SlotValue -> 'ok)))
(define (get-target-updater t)
(cond
@ -612,6 +641,11 @@
x
(error 'ensure-mutable-pair "not a mutable pair: ~s" x)))
(: ensure-prompt-frame (Any -> PromptFrame))
(define (ensure-prompt-frame x)
(if (PromptFrame? x)
x
(error 'ensure-prompt-frame "not a PromptFrame: ~s" x)))
(: ensure-CapturedControl (Any -> CapturedControl))

2
test-compiler.rkt
View File

@ -826,7 +826,7 @@
;; This should produce 0 because there needs to be a continuation prompt around each evaluation.
#;(test '(begin
(test '(begin
(define cont #f)
(define n 0)
(call/cc (lambda (x) (set! cont x)))