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

abort still not doing the right thing...

Browse Source
This commit is contained in:
Danny Yoo 2013-04-16 18:48:22 -06:00
parent d482c78ac4
commit 6f03e04ee8
4 changed files with 30 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
whalesong/compiler/compiler.rkt
View File

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

5
whalesong/compiler/il-structs.rkt
View File

@ -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)
(define-predicate OpArg? OpArg)

7
whalesong/compiler/optimize-il.rkt
View File

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

10
whalesong/js-assembler/assemble.rkt
View File

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