From 570879d19444cbbff35a1f511955dbb7f3a82b65 Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Fri, 1 Apr 2011 19:44:24 -0400 Subject: [PATCH] still debugging --- compile.rkt | 46 +++++++++++++++++++++++++++---------------- il-structs.rkt | 1 + simulator-structs.rkt | 3 ++- simulator.rkt | 38 +++++++++++++++++++++++++++++++++-- test-compiler.rkt | 2 +- 5 files changed, 69 insertions(+), 21 deletions(-) diff --git a/compile.rkt b/compile.rkt index 8188d21..0b7321f 100644 --- a/compile.rkt +++ b/compile.rkt @@ -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)))])) diff --git a/il-structs.rkt b/il-structs.rkt index c266275..8e7d376 100644 --- a/il-structs.rkt +++ b/il-structs.rkt @@ -100,6 +100,7 @@ #:transparent) (define-struct: PushControlFrame/Prompt ([tag : (U OpArg DefaultContinuationPromptTag)] + [label : Symbol] ;; TODO: add handler and arguments ) #:transparent) diff --git a/simulator-structs.rkt b/simulator-structs.rkt index e82fe88..63ae58e 100644 --- a/simulator-structs.rkt +++ b/simulator-structs.rkt @@ -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]) diff --git a/simulator.rkt b/simulator.rkt index a5f4e23..27470c7 100644 --- a/simulator.rkt +++ b/simulator.rkt @@ -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)) diff --git a/test-compiler.rkt b/test-compiler.rkt index 9530003..f5b8bef 100644 --- a/test-compiler.rkt +++ b/test-compiler.rkt @@ -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)))