added generic frames

2011-04-14 13:17:44 -04:00 · 2011-04-14 13:17:44 -04:00 · 6e2c4e8d8a
commit 6e2c4e8d8a
parent 0c8cd9234c
5 changed files with 63 additions and 46 deletions
--- 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)])
--- 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)))))]))



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