hacking in a call-with-values form to see if i got apply-values right

assemble-helpers.rkt

@@ -43,7 +43,9 @@
     [(ControlStackLabel/MultipleValueReturn? v)
      (assemble-control-stack-label/multiple-value-return v)]
     [(CompiledProcedureEntry? v)
-     (assemble-compiled-procedure-entry v)]))
+     (assemble-compiled-procedure-entry v)]
+    [(ControlFrameTemporary? v)
+     (assemble-control-frame-temporary v)]))
 
 
 
@@ -64,10 +66,13 @@
     [(PrimitivesReference? target)
      (format "MACHINE.primitives[~s]" (symbol->string (PrimitivesReference-name target)))]
     [(ControlFrameTemporary? target)
-     (format "MACHINE.control[MACHINE.control.length-1].~a"
+     (assemble-control-frame-temporary target)]))
-             (ControlFrameTemporary-name target))]))
 
 
+(: assemble-control-frame-temporary (ControlFrameTemporary -> String))
+(define (assemble-control-frame-temporary t)
+  (format "MACHINE.control[MACHINE.control.length-1].~a"
+          (ControlFrameTemporary-name t)))
 
 ;; fixme: use js->string
 (: assemble-const (Const -> String))

bootstrapped-primitives.rkt

@@ -220,4 +220,9 @@
        
        ,after-apply-code
        ,(make-AssignPrimOpStatement (make-PrimitivesReference 'apply)
-                                    (make-MakeCompiledProcedure apply-entry (make-ArityAtLeast 2) '() 'apply))))))
+                                    (make-MakeCompiledProcedure apply-entry (make-ArityAtLeast 2) '() 'apply))))
+   
+   
+     
+   
+   ))

collect-jump-targets.rkt

@@ -84,7 +84,9 @@
    [(ControlStackLabel/MultipleValueReturn? an-input)
     empty]
    [(CompiledProcedureEntry? an-input)
-    (collect-input (CompiledProcedureEntry-proc an-input))]))
+    (collect-input (CompiledProcedureEntry-proc an-input))]
+   [(ControlFrameTemporary? an-input)
+    empty]))
 
 (: collect-location ((U Reg Label) -> (Listof Symbol)))
 (define (collect-location a-location)

compiler.rkt

@@ -121,7 +121,10 @@
           [(WithContMark? exp)
            (append (loop (WithContMark-key exp) cenv)
                    (loop (WithContMark-value exp) cenv)
-                   (loop (WithContMark-body exp) cenv))])))
+                   (loop (WithContMark-body exp) cenv))]
+          [(ApplyValues? exp)
+           (append (loop (ApplyValues-proc exp) cenv)
+                   (loop (ApplyValues-args-expr exp) cenv))])))
 
 
 
@@ -178,7 +181,9 @@
     [(LetRec? exp)
      (compile-let-rec exp cenv target linkage)]
     [(WithContMark? exp)
-     (compile-with-cont-mark exp cenv target linkage)]))
+     (compile-with-cont-mark exp cenv target linkage)]
+    [(ApplyValues? exp)
+     (compile-apply-values exp cenv target linkage)]))
 
 
 
@@ -1416,6 +1421,44 @@
      (in-other-context linkage)]))
 
 
+(: compile-apply-values (ApplyValues CompileTimeEnvironment Target Linkage -> InstructionSequence))
+(define (compile-apply-values exp cenv target linkage)
+  (append-instruction-sequences
+   
+   ;; Save the procedure value temporarily in a control stack frame
+   (make-instruction-sequence 
+    `(,(make-PushControlFrame/Generic)))
+   (compile (ApplyValues-proc exp) 
+            cenv 
+            (make-ControlFrameTemporary 'pendingApplyValuesProc)
+            next-linkage/expects-single)
+   
+   ;; Then evaluate the value producer in a context that expects
+   ;; the return values to be placed onto the stack.
+   (compile (ApplyValues-args-expr exp)
+            cenv 
+            'val
+            next-linkage/values-on-stack)
+
+   ;; Retrieve the procedure off the temporary control frame.
+   (make-instruction-sequence
+    `(,(make-AssignImmediateStatement 
+        'proc 
+        (make-ControlFrameTemporary 'pendingApplyValuesProc))))
+   
+   ;; Pop off the temporary control frame
+   (make-instruction-sequence 
+    `(,(make-PopControlFrame)))
+   
+   ;; Finally, do the generic call into the function.
+   (compile-general-procedure-call cenv (make-Reg 'argcount) target linkage)))
+
+   
+            
+  
+
+   
+
 
 (: append-instruction-sequences (InstructionSequence * -> InstructionSequence))
 (define (append-instruction-sequences . seqs)
@@ -1594,6 +1637,9 @@
     [(WithContMark? exp)
      (make-WithContMark (adjust-expression-depth (WithContMark-key exp) n skip)
                         (adjust-expression-depth (WithContMark-value exp) n skip)
-                        (adjust-expression-depth (WithContMark-body exp) n skip))]))
+                        (adjust-expression-depth (WithContMark-body exp) n skip))]
+    [(ApplyValues? exp)
+     (make-ApplyValues (adjust-expression-depth (ApplyValues-proc exp) n skip)
+                       (adjust-expression-depth (ApplyValues-args-expr exp) n skip))]))
 
 

expression-structs.rkt

@@ -14,7 +14,8 @@
                                LetRec
                                InstallValue
                                BoxEnv
-                               WithContMark))
+                               WithContMark
+                               ApplyValues))
 
 (define-struct: Top ([prefix : Prefix]
                      [code : Expression]) #:transparent)
@@ -80,6 +81,12 @@
   #:transparent)
 
 
+(define-struct: ApplyValues ([proc : Expression]
+                             [args-expr : Expression])
+  #:transparent)
+
+
+
 (: last-exp? ((Listof Expression) -> Boolean))
 (define (last-exp? seq) 
   (null? (cdr seq)))

il-structs.rkt

@@ -30,7 +30,7 @@
 		      ControlStackLabel
 		      ControlStackLabel/MultipleValueReturn
                       CompiledProcedureEntry
-                      ))
+                      ControlFrameTemporary))
 
 
 ;; Targets: these are the allowable lhs's for an assignment.
@@ -42,7 +42,9 @@
 
 
 ;; When we need to store a value temporarily in the top control frame, we can use this as a target.
-(define-struct: ControlFrameTemporary ([name : (U 'pendingContinuationMarkKey)])
+(define-struct: ControlFrameTemporary ([name : (U 'pendingContinuationMarkKey ;; for continuation marks
+                                                  'pendingApplyValuesProc ;; for apply-values
+                                                  )])
   #:transparent)
 
 
@@ -419,7 +421,7 @@
 (define-struct: NextLinkage ([context : ValuesContext]))
 (define next-linkage/drop-multiple (make-NextLinkage 'drop-multiple))
 (define next-linkage/expects-single (make-NextLinkage 1))
-
+(define next-linkage/values-on-stack (make-NextLinkage 'keep-multiple))
 
 
 

optimize-il.rkt

@@ -71,7 +71,9 @@
     [(ControlStackLabel/MultipleValueReturn? oparg)
      oparg]
     [(CompiledProcedureEntry? oparg)
-     (make-CompiledProcedureEntry (adjust-oparg-depth (CompiledProcedureEntry-proc oparg) n))]))
+     (make-CompiledProcedureEntry (adjust-oparg-depth (CompiledProcedureEntry-proc oparg) n))]
+    [(ControlFrameTemporary? oparg)
+     oparg]))
 
 
 (define-predicate natural? Natural)

parse.rkt

@@ -151,7 +151,9 @@
      (make-WithContMark (parse (with-continuation-mark-key exp) cenv #f)
                         (parse (with-continuation-mark-value exp) cenv #f)
                         (parse (with-continuation-mark-body exp) cenv #f))]
-                        
+
+    [(call-with-values? exp)
+     (parse-call-with-values exp cenv)]
 
     ;; Remember, this needs to be the last case.
     [(application? exp)
@@ -282,6 +284,10 @@
         (append (loop (with-continuation-mark-key exp))
                 (loop (with-continuation-mark-value exp))
                 (loop (with-continuation-mark-body exp)))]
+      
+       [(call-with-values? exp)
+        (append (loop (call-with-values-producer exp))
+                (loop (call-with-values-consumer exp)))]
 
        ;; Remember: this needs to be the last case.
        [(application? exp)
@@ -351,6 +357,10 @@
                 (loop (with-continuation-mark-value exp))
                 (loop (with-continuation-mark-body exp)))]
        
+       [(call-with-values? exp)
+        (append (loop (call-with-values-producer exp))
+                (loop (call-with-values-consumer exp)))]
+       
        ;; Remember, this needs to be the last case.
        [(application? exp)
         (append (loop (operator exp))
@@ -582,6 +592,26 @@
                        #t))])))
 
 
+
+(define (parse-call-with-values exp cenv)
+  (cond
+    [(and (lambda? (call-with-values-producer exp))
+          (empty? (lambda-parameters (call-with-values-producer exp))))
+     (let ([producer (parse `(begin ,@(lambda-body (call-with-values-producer exp)))
+                            cenv #f)]
+           [consumer-proc (parse (call-with-values-consumer exp) cenv #f)])
+              (make-ApplyValues consumer-proc producer))]
+    [else
+     (let ([producer (parse `(,(call-with-values-producer exp)) cenv #f)]
+           [consumer-proc (parse (call-with-values-consumer exp) cenv #f)])
+       (make-ApplyValues consumer-proc producer))]))
+
+
+
+
+
+
+
 (define (desugar-let* exp)
   (let ([body (let-body exp)])
     (let loop ([vars (let-variables exp)]
@@ -604,6 +634,7 @@
 
 
 
+
 (define (named-let? exp)
   (and (tagged-list? exp 'let)
        (symbol? (cadr exp))))
@@ -622,6 +653,13 @@
   (cdddr exp))
 
 
+(define (call-with-values? exp)
+  (tagged-list? exp 'call-with-values))
+(define (call-with-values-producer exp)
+  (cadr exp))
+(define (call-with-values-consumer exp)
+  (caddr exp))
+
 
 ;; any -> boolean
 (define (let? exp)

simulator.rkt

@@ -746,7 +746,13 @@
 
     [(CompiledProcedureEntry? an-oparg)
      (let ([proc (ensure-closure (evaluate-oparg m (CompiledProcedureEntry-proc an-oparg)))])
-       (closure-label proc))]))
+       (closure-label proc))]
+
+    [(ControlFrameTemporary? an-oparg)
+     (let ([ht (frame-temps (control-top m))])
+       (hash-ref ht
+                 (ControlFrameTemporary-name an-oparg)))]))
+
 
 
 (: ensure-closure-or-false (SlotValue -> (U closure #f)))

test-parse.rkt

@@ -486,4 +486,16 @@
       (make-Top (make-Prefix '(x y z))
                 (make-WithContMark (make-ToplevelRef 0 0)
                                    (make-ToplevelRef 0 1)
-                                   (make-ToplevelRef 0 2))))
+                                   (make-ToplevelRef 0 2))))
+
+
+
+(test (parse '(call-with-values x y))
+      (make-Top (make-Prefix '(x y))
+                (make-ApplyValues (make-ToplevelRef 0 1)
+                                  (make-App (make-ToplevelRef 0 0) (list)))))
+
+(test (parse '(call-with-values (lambda () x) y))
+      (make-Top (make-Prefix '(x y))
+                (make-ApplyValues (make-ToplevelRef 0 1)
+                                  (make-ToplevelRef 0 0))))