diff --git a/assemble.rkt b/assemble.rkt index 56453c1..7009864 100644 --- a/assemble.rkt +++ b/assemble.rkt @@ -139,6 +139,8 @@ EOF (next)] [(PushImmediateOntoEnvironment? stmt) (next)] + [(PushControlFrame/Generic? stmt) + (next)] [(PushControlFrame/Call? stmt) (next)] [(PushControlFrame/Prompt? stmt) @@ -259,6 +261,8 @@ EOF empty] [(PushImmediateOntoEnvironment? stmt) (collect-input (PushImmediateOntoEnvironment-value stmt))] + [(PushControlFrame/Generic? stmt) + empty] [(PushControlFrame/Call? stmt) (label->labels (PushControlFrame/Call-label stmt))] [(PushControlFrame/Prompt? stmt) @@ -330,6 +334,9 @@ EOF [(GotoStatement? stmt) (assemble-jump (GotoStatement-target stmt))] + [(PushControlFrame/Generic? stmt) + "MACHINE.control.push(new RUNTIME.Frame());"] + [(PushControlFrame/Call? stmt) (format "MACHINE.control.push(new RUNTIME.CallFrame(~a, MACHINE.proc));" (let ([label (PushControlFrame/Call-label stmt)]) diff --git a/compiler.rkt b/compiler.rkt index 57c5411..df5d83a 100644 --- a/compiler.rkt +++ b/compiler.rkt @@ -1284,50 +1284,23 @@ [(or (NextLinkage? linkage) (LabelLinkage? linkage)) - (let* (;[after-key-multiple (make-label 'afterKeyMultiple)] - ;[after-key (make-LinkedLabel (make-label 'afterKey) after-key-multiple)] - ;[after-value-multiple (make-label 'afterValueMultiple)] - ;[after-value (make-LinkedLabel (make-label 'afterValue) after-value-multiple)] - [after-body-multiple (make-label 'afterBody)] - [after-body (make-LinkedLabel (make-label 'afterBody) after-body-multiple)]) - (end-with-linkage - linkage cenv - (append-instruction-sequences - ;; Making a continuation frame; isn't really used for anything else but recording the key/value data. - ;; FIXME: create separate frame structure here, and don't try to reuse. - (make-instruction-sequence - `(,(make-AssignImmediateStatement 'proc (make-Const #f)) - ,(make-PushControlFrame/Call after-body))) - - ;(make-instruction-sequence - ; `(,(make-AssignImmediateStatement 'proc (make-Const #f)) - ; ,(make-PushControlFrame after-key))) - (compile (WithContMark-key exp) cenv 'val next-linkage) - ;after-key-multiple - ;; Fixme: we should error out here instead - ;(make-instruction-sequence - ; `(,(make-PopEnvironment (make-Reg 'argcount) (make-Const 0)))) - ;after-key - (make-instruction-sequence `(,(make-AssignImmediateStatement - (make-ControlFrameTemporary 'pendingContinuationMarkKey) - (make-Reg 'val)))) - ;(make-instruction-sequence - ; `(,(make-AssignImmediateStatement 'proc (make-Const #f)) - ; ,(make-PushControlFrame after-value))) - (compile (WithContMark-value exp) cenv 'val next-linkage) - ;after-value-multiple - ;; Fixme: we should error out here instead - ;(make-instruction-sequence - ; `(,(make-PopEnvironment (make-Reg 'argcount) (make-Const 0)))) - ;after-value - (make-instruction-sequence `(,(make-PerformStatement - (make-InstallContinuationMarkEntry!)))) - (compile (WithContMark-body exp) cenv target next-linkage) - after-body-multiple - after-body - (make-instruction-sequence - `(,(make-PopControlFrame))))))])) - + (end-with-linkage + linkage cenv + (append-instruction-sequences + ;; Making a continuation frame; isn't really used for anything + ;; but recording the key/value data. + (make-instruction-sequence + `(,(make-PushControlFrame/Generic))) + (compile (WithContMark-key exp) cenv 'val next-linkage) + (make-instruction-sequence `(,(make-AssignImmediateStatement + (make-ControlFrameTemporary 'pendingContinuationMarkKey) + (make-Reg 'val)))) + (compile (WithContMark-value exp) cenv 'val next-linkage) + (make-instruction-sequence `(,(make-PerformStatement + (make-InstallContinuationMarkEntry!)))) + (compile (WithContMark-body exp) cenv target next-linkage) + (make-instruction-sequence + `(,(make-PopControlFrame)))))])) diff --git a/il-structs.rkt b/il-structs.rkt index fbd126a..1d30d6d 100644 --- a/il-structs.rkt +++ b/il-structs.rkt @@ -80,6 +80,7 @@ PushImmediateOntoEnvironment + PushControlFrame/Generic PushControlFrame/Call PushControlFrame/Prompt @@ -124,6 +125,10 @@ #:transparent) +;; A generic control frame only holds marks and other temporary variables. +(define-struct: PushControlFrame/Generic () + #:transparent) + ;; Adding a frame for getting back after procedure application. ;; The 'proc register must hold either #f or a closure at the time of ;; this call, as the control frame will hold onto the called procedure record. diff --git a/simulator-structs.rkt b/simulator-structs.rkt index acb8f6f..e0cc474 100644 --- a/simulator-structs.rkt +++ b/simulator-structs.rkt @@ -57,7 +57,14 @@ #:mutable) -(define-type frame (U CallFrame PromptFrame)) + +(define-type frame (U GenericFrame CallFrame PromptFrame)) + + +(define-struct: GenericFrame ([temps : (HashTable Symbol PrimitiveValue)] + [marks : (HashTable PrimitiveValue PrimitiveValue)]) + #:transparent) + (define-struct: CallFrame ([return : (U Symbol LinkedLabel)] ;; The procedure being called. Used to optimize self-application @@ -66,7 +73,7 @@ [temps : (HashTable Symbol PrimitiveValue)] [marks : (HashTable PrimitiveValue PrimitiveValue)]) #:transparent - #:mutable) + #:mutable) ;; mutable because we want to allow mutation of proc. (define-struct: PromptFrame ([tag : ContinuationPromptTagValue] [return : (U Symbol LinkedLabel)] @@ -79,6 +86,8 @@ (: frame-temps (frame -> (HashTable Symbol PrimitiveValue))) (define (frame-temps a-frame) (cond + [(GenericFrame? a-frame) + (GenericFrame-temps a-frame)] [(CallFrame? a-frame) (CallFrame-temps a-frame)] [(PromptFrame? a-frame) @@ -88,14 +97,19 @@ (: frame-marks (frame -> (HashTable PrimitiveValue PrimitiveValue))) (define (frame-marks a-frame) (cond + [(GenericFrame? a-frame) + (GenericFrame-marks a-frame)] [(CallFrame? a-frame) (CallFrame-marks a-frame)] [(PromptFrame? a-frame) (PromptFrame-marks a-frame)])) + (: frame-tag (frame -> (U ContinuationPromptTagValue #f))) (define (frame-tag a-frame) (cond + [(GenericFrame? a-frame) + #f] [(CallFrame? a-frame) #f] [(PromptFrame? a-frame) diff --git a/simulator.rkt b/simulator.rkt index e8085ca..f9c95e5 100644 --- a/simulator.rkt +++ b/simulator.rkt @@ -109,6 +109,8 @@ (step-push-environment! m i)] [(PushImmediateOntoEnvironment? i) (step-push-immediate-onto-environment! m i)] + [(PushControlFrame/Generic? i) + (step-push-control-frame/generic! m i)] [(PushControlFrame/Call? i) (step-push-control-frame! m i)] [(PushControlFrame/Prompt? i) @@ -168,6 +170,14 @@ (step-push-environment! m (make-PushEnvironment 1 (PushImmediateOntoEnvironment-box? stmt))) ((get-target-updater t) m v))) + + +(: step-push-control-frame/generic! (machine PushControlFrame/Generic -> 'ok)) +(define (step-push-control-frame/generic! m stmt) + (control-push! m (make-GenericFrame (make-hasheq) + (make-hasheq)))) + + (: step-push-control-frame! (machine PushControlFrame/Call -> 'ok)) (define (step-push-control-frame! m stmt) (control-push! m (make-CallFrame (PushControlFrame/Call-label stmt) @@ -504,6 +514,8 @@ [(GetControlStackLabel? op) (target-updater! m (let ([frame (ensure-frame (first (machine-control m)))]) (cond + [(GenericFrame? frame) + (error 'GetControlStackLabel)] [(PromptFrame? frame) (let ([label (PromptFrame-return frame)]) (cond @@ -522,6 +534,8 @@ [(GetControlStackLabel/MultipleValueReturn? op) (target-updater! m (let ([frame (ensure-frame (first (machine-control m)))]) (cond + [(GenericFrame? frame) + (error 'GetControlStackLabel/MultipleValueReturn)] [(PromptFrame? frame) (let ([label (PromptFrame-return frame)]) (cond @@ -573,6 +587,8 @@ [else (let ([a-frame (first frames)]) (cond + [(GenericFrame? a-frame) + (cons a-frame (take-continuation-to-tag (rest frames) tag))] [(CallFrame? a-frame) (cons a-frame (take-continuation-to-tag (rest frames) tag))] [(PromptFrame? a-frame) @@ -592,6 +608,8 @@ [else (let ([a-frame (first frames)]) (cond + [(GenericFrame? a-frame) + (drop-continuation-to-tag (rest frames) tag)] [(CallFrame? a-frame) (drop-continuation-to-tag (rest frames) tag)] [(PromptFrame? a-frame)