From 6f03e04ee80c1200d96dd3b67b9a0b221bf3dca5 Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Tue, 16 Apr 2013 18:48:22 -0600 Subject: [PATCH] abort still not doing the right thing... --- whalesong/compiler/compiler.rkt | 17 +++++++++++++---- whalesong/compiler/il-structs.rkt | 5 +++-- whalesong/compiler/optimize-il.rkt | 7 ++++++- whalesong/js-assembler/assemble.rkt | 10 ++++++++-- 4 files changed, 30 insertions(+), 9 deletions(-) diff --git a/whalesong/compiler/compiler.rkt b/whalesong/compiler/compiler.rkt index 01b7229..68faee3 100644 --- a/whalesong/compiler/compiler.rkt +++ b/whalesong/compiler/compiler.rkt @@ -59,7 +59,8 @@ ;; Begin a prompted evaluation: (make-PushControlFrame/Prompt default-continuation-prompt-tag - before-pop-prompt) + before-pop-prompt + #f) (compile exp '() 'val return-linkage/nontail) before-pop-prompt-multiple (make-PopEnvironment (make-SubtractArg (make-Reg 'argcount) (make-Const 1)) @@ -93,6 +94,7 @@ ;; Begin a prompted evaluation: (make-PushControlFrame/Prompt default-continuation-prompt-tag + after-pop-prompt: ;; <--- FIXME: this argument isn't used right now! after-pop-prompt:) (compile exp '() 'val next-linkage/keep-multiple-on-stack) @@ -108,7 +110,11 @@ (make-Goto (make-Label last:)) - ;; If we abort, the abort handler code also needs to return values back: + ;; If we abort, the abort handler code should call the expected thunk + ;; with a return going to this code: + ;; FIXME + + after-pop-prompt-multiple: (make-DebugPrint (make-Const "abort multiple")) (make-TestAndJump (make-TestZero (make-Reg 'argcount)) abort-with-multiple-values:) @@ -127,6 +133,7 @@ (make-Perform (make-UnspliceRestFromStack! (make-Const 0) (make-Const 1))) (make-AssignImmediate 'val (make-EnvLexicalReference 0 #f)) (make-PopEnvironment (make-Const 1) (make-Const 0)) + (make-Goto (make-Label last:)) last: ;; Finally, return to the success continuation on the stack. @@ -593,7 +600,8 @@ cenv (append-instruction-sequences (make-PushControlFrame/Prompt default-continuation-prompt-tag - on-return) + on-return + #f) (compile (first seq) cenv 'val return-linkage/nontail) (emit-values-context-check-on-procedure-return (linkage-context linkage) on-return/multiple @@ -604,7 +612,8 @@ (new-linked-labels 'beforePromptPop)) (append-instruction-sequences (make-PushControlFrame/Prompt (make-DefaultContinuationPromptTag) - on-return) + on-return + #f) (compile (first seq) cenv 'val return-linkage/nontail) on-return/multiple diff --git a/whalesong/compiler/il-structs.rkt b/whalesong/compiler/il-structs.rkt index 148fbb6..1b11691 100644 --- a/whalesong/compiler/il-structs.rkt +++ b/whalesong/compiler/il-structs.rkt @@ -267,7 +267,8 @@ (define-struct: PushControlFrame/Prompt ([tag : (U OpArg DefaultContinuationPromptTag)] [label : LinkedLabel] - ;; TODO: add handler and arguments + [handler : (U LinkedLabel #f)] + ;; TODO: add arguments to the handler? ) #:transparent) @@ -620,4 +621,4 @@ -(define-predicate OpArg? OpArg) \ No newline at end of file +(define-predicate OpArg? OpArg) diff --git a/whalesong/compiler/optimize-il.rkt b/whalesong/compiler/optimize-il.rkt index 2276350..cdb168c 100644 --- a/whalesong/compiler/optimize-il.rkt +++ b/whalesong/compiler/optimize-il.rkt @@ -246,7 +246,12 @@ tag (rewrite-oparg tag))) (make-LinkedLabel (LinkedLabel-label a-label) - (ref (LinkedLabel-linked-to a-label)))) + (ref (LinkedLabel-linked-to a-label))) + (let ([handler (PushControlFrame/Prompt-handler a-stmt)]) + (if (eq? handler #f) + #f + (make-LinkedLabel (LinkedLabel-label handler) + (ref (LinkedLabel-linked-to handler)))))) (loop (rest stmts)))] [(PopControlFrame? a-stmt) diff --git a/whalesong/js-assembler/assemble.rkt b/whalesong/js-assembler/assemble.rkt index f740529..7755912 100644 --- a/whalesong/js-assembler/assemble.rkt +++ b/whalesong/js-assembler/assemble.rkt @@ -583,7 +583,7 @@ EOF (assemble-label (make-Label (LinkedLabel-label label)))])))] [(PushControlFrame/Prompt? stmt) - (format "M.c.push(new RT.PromptFrame(~a,~a,M.e.length,false));" + (format "M.c.push(new RT.PromptFrame(~a,~a,M.e.length,~a));" (let: ([label : (U Symbol LinkedLabel) (PushControlFrame/Prompt-label stmt)]) (cond [(symbol? label) @@ -597,7 +597,13 @@ EOF [(DefaultContinuationPromptTag? tag) (assemble-default-continuation-prompt-tag)] [(OpArg? tag) - (assemble-oparg tag blockht)])))] + (assemble-oparg tag blockht)])) + (let: ([handler : (U LinkedLabel #f) (PushControlFrame/Prompt-handler stmt)]) + (cond + [(eq? handler #f) + "false"] + [else + (assemble-label (make-Label (LinkedLabel-label handler)))])))] [(PopControlFrame? stmt) "M.c.pop();"]