diff --git a/compile.rkt b/compile.rkt index 0b7321f..db665e4 100644 --- a/compile.rkt +++ b/compile.rkt @@ -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 diff --git a/il-structs.rkt b/il-structs.rkt index 8e7d376..8293b8c 100644 --- a/il-structs.rkt +++ b/il-structs.rkt @@ -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)) diff --git a/simulator-structs.rkt b/simulator-structs.rkt index 63ae58e..e0825da 100644 --- a/simulator-structs.rkt +++ b/simulator-structs.rkt @@ -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) \ No newline at end of file diff --git a/simulator.rkt b/simulator.rkt index 27470c7..e585f78 100644 --- a/simulator.rkt +++ b/simulator.rkt @@ -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)