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

continuing to debug

Browse Source
This commit is contained in:
Danny Yoo 2011-04-01 21:31:57 -04:00
parent 570879d194
commit 931078130f
4 changed files with 62 additions and 37 deletions

59
compile.rkt
View File

@ -33,15 +33,8 @@
(make-instruction-sequence
`(,(make-PushControlFrame/Prompt default-continuation-prompt-tag
before-pop-prompt)))
(compile exp
'()
target
(make-LabelLinkage before-pop-prompt))
before-pop-prompt
(make-instruction-sequence
`(,(make-PopControlFrame))))))))
(compile exp '() target prompt-linkage)
before-pop-prompt)))))
(define-struct: lam+cenv ([lam : Lam]
[cenv : CompileTimeEnvironment]))
@ -205,6 +198,10 @@
,(make-PopEnvironment (length cenv) 0)
,(make-PopControlFrame)
,(make-GotoStatement (make-Reg 'proc))))]
[(PromptLinkage? linkage)
(make-instruction-sequence `(,(make-AssignPrimOpStatement 'proc (make-GetControlStackLabel))
,(make-PopControlFrame)
,(make-GotoStatement (make-Reg 'proc))))]
[(NextLinkage? linkage)
empty-instruction-sequence]
[(LabelLinkage? linkage)
@ -220,6 +217,11 @@
(make-instruction-sequence `(,(make-AssignPrimOpStatement 'proc (make-GetControlStackLabel))
,(make-PopControlFrame)
,(make-GotoStatement (make-Reg 'proc))))]
[(PromptLinkage? linkage)
(make-instruction-sequence `(,(make-AssignPrimOpStatement 'proc (make-GetControlStackLabel))
,(make-PopControlFrame)
,(make-PopEnvironment (length cenv) 0)
,(make-GotoStatement (make-Reg 'proc))))]
[(NextLinkage? linkage)
(make-instruction-sequence `(,(make-PopEnvironment (length cenv) 0)))]
[(LabelLinkage? linkage)
@ -322,20 +324,17 @@
(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))))))]
before-pop-prompt)))
(compile (first-exp seq) cenv target prompt-linkage)
before-pop-prompt)))]
[else
(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)
(compile (first-exp seq) cenv target prompt-linkage)
before-pop-prompt
(make-instruction-sequence `(,(make-PopControlFrame)))
(compile-splice (rest-exps seq) cenv target linkage)))]))
@ -887,6 +886,28 @@
(error 'compile "return linkage, target not val: ~s" target)])]
[(PromptLinkage? linkage)
(cond [(eq? target 'val)
;; This case happens for a function call that isn't in
;; tail position.
(let ([proc-return (make-label 'procReturn)])
(make-instruction-sequence
`(,(make-PushControlFrame proc-return)
,(make-AssignPrimOpStatement 'val (make-GetCompiledProcedureEntry))
,(make-GotoStatement entry-point)
,proc-return)))]
[else
;; This case happens for evaluating arguments, since the
;; arguments are being installed into the scratch space.
(let ([proc-return (make-label 'procReturn)])
(make-instruction-sequence
`(,(make-PushControlFrame proc-return)
,(make-AssignPrimOpStatement 'val (make-GetCompiledProcedureEntry))
,(make-GotoStatement entry-point)
,proc-return
,(make-AssignImmediateStatement target (make-Reg 'val)))))])]
[(NextLinkage? linkage)
(cond [(eq? target 'val)
;; This case happens for a function call that isn't in
@ -984,6 +1005,8 @@
linkage]
[(ReturnLinkage? linkage)
linkage]
[(PromptLinkage? linkage)
linkage]
[(LabelLinkage? linkage)
after-body-code])]
[body-target : Target (adjust-target-depth target 1)]
@ -1016,6 +1039,8 @@
linkage]
[(ReturnLinkage? linkage)
linkage]
[(PromptLinkage? linkage)
linkage]
[(LabelLinkage? linkage)
after-body-code])]
[body-target : Target (adjust-target-depth target n)]
@ -1056,6 +1081,8 @@
linkage]
[(ReturnLinkage? linkage)
linkage]
[(PromptLinkage? linkage)
linkage]
[(LabelLinkage? linkage)
after-body-code])])
(end-with-linkage

4
il-structs.rkt
View File

@ -296,10 +296,14 @@
(define-struct: ReturnLinkage ())
(define return-linkage (make-ReturnLinkage))
(define-struct: PromptLinkage ())
(define prompt-linkage (make-PromptLinkage))
(define-struct: LabelLinkage ([label : Symbol]))
(define-type Linkage (U NextLinkage
ReturnLinkage
PromptLinkage
LabelLinkage))

3
simulator-structs.rkt
View File

@ -64,7 +64,7 @@
)
#:transparent)
(define-struct: PromptFrame ([tag : ContinuationPromptTagValue]
[label : Symbol])
[return : Symbol])
#:transparent)
(define-struct: ContinuationPromptTagValue ([name : Symbol])
@ -109,3 +109,4 @@
(define-predicate PrimitiveValue? PrimitiveValue)
(define-predicate frame? frame)

33
simulator.rkt
View File

@ -284,26 +284,8 @@
(: 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)))
(append frames-1 frames-2))
(: 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)))
@ -379,7 +361,12 @@
(error 'apply-primitive-procedure)]))]
[(GetControlStackLabel? op)
(target-updater! m (CallFrame-return (ensure-CallFrame (first (machine-control m)))))]
(target-updater! m (let ([frame (ensure-frame (first (machine-control m)))])
(cond
[(PromptFrame? frame)
(PromptFrame-return frame)]
[(CallFrame? frame)
(CallFrame-return frame)])))]
[(CaptureEnvironment? op)
(target-updater! m (make-CapturedEnvironment (drop (machine-env m)
@ -647,6 +634,12 @@
x
(error 'ensure-prompt-frame "not a PromptFrame: ~s" x)))
(: ensure-frame (Any -> frame))
(define (ensure-frame x)
(if (frame? x)
x
(error 'ensure-frame "not a frame: ~s" x)))
(: ensure-CapturedControl (Any -> CapturedControl))
(define (ensure-CapturedControl x)