in the middle of supporting the multiple value return with labels

NOTES

@@ -17,6 +17,9 @@ Some possible optimizations with application:
 
 
 
+----------------------------------------------------------------------
+
+
 Multiple values
 
 There's interplay between compile-proc-appl and the linkage compiling
@@ -28,6 +31,36 @@ in Scheme" that I'll need to read.
 http://citeseerx.ist.psu.edu/viewdoc/download?doi=10.1.1.39.1668&rep=rep1&type=pdf
 
 
+Basic idea: each return address is actually a pair, where the
+secondary address lies at a fixed offset of the first and handles
+multiple value return.  Multiple values are returned back by keeping
+them on the stack, and assigning argcount to the number of the
+returned values.
+
+
+In the context of my compiler: the compiler implicitly defines a
+singleton, statement context by using next-linkage.  But some uses of
+next-linkage ignore the number of values that come back, and others
+should raise an error.  Here are the contexts that care:
+
+    app
+    let1
+    install-value
+    toplevel-set (define-values, assign)
+
+
+For the contexts that don't care, we need to set up a return address
+that just pops those values off.
+
+
+
+
+
+
+
+
+----------------------------------------------------------------------
+
 
 
 

assemble.rkt

@@ -143,6 +143,8 @@ EOF
        empty]
       [(GetControlStackLabel? op)
        empty]
+      [(GetControlStackLabel/MultipleValueReturn? op)
+       empty]
       [(CaptureEnvironment? op)
        empty]
       [(CaptureControl? op)
@@ -378,6 +380,9 @@ EOF
     [(GetControlStackLabel? op)
      (format "MACHINE.control[MACHINE.control.length-1].label")]
 
+    [(GetControlStackLabel/MultipleValueReturn? op)
+     (format "MACHINE.control[MACHINE.control.length-1].label.multipleValueReturn")]
+  
     [(CaptureEnvironment? op)
      (format "MACHINE.env.slice(0, MACHINE.env.length - ~a)"
              (CaptureEnvironment-skip op))]

bootstrapped-primitives.rkt

@@ -143,6 +143,9 @@
 	      
 
    
+   
+   
+   
    ;; The call/cc code is special:
    (let ([after-call/cc-code (make-label 'afterCallCCImplementation)])
      (append 
@@ -157,6 +160,26 @@
    
   
    
+   ;; values
+   (let ([after-values (make-label 'afterValues)]
+         [values-entry (make-label 'valuesEntry)])
+     `(,(make-GotoStatement (make-Label after-values))
+       ,values-entry
+       ;; values simply keeps the values on the stack, preserves the argcount, and does a return
+       ;; to the multiple-value-return address.
+       ,(make-AssignPrimOpStatement 'proc (make-GetControlStackLabel/MultipleValueReturn))
+       ,(make-PopControlFrame)
+       ,(make-GotoStatement (make-Reg 'proc))
+       ,after-values
+       ,(make-AssignPrimOpStatement (make-PrimitivesReference 'values)
+                                    (make-MakeCompiledProcedure values-entry
+                                                                (make-ArityAtLeast 0) 
+                                                                '() 
+                                                                'values))))  
+   
+   
+   
+   
    ;; As is apply:
    (let ([after-apply-code (make-label 'afterApplyCode)]
          [apply-entry (make-label 'applyEntry)])

il-structs.rkt

@@ -82,8 +82,15 @@
 
 (define-type Statement (U UnlabeledStatement
                           Symbol      ;; label
+                          LinkedLabel ;; Label with a reference to a multiple-return-value label
                           ))
 
+
+(define-struct: LinkedLabel ([label : Symbol]
+                             [linked-to : Symbol])
+  #:transparent)
+
+
 (define-struct: AssignImmediateStatement ([target : Target]
                                           [value : OpArg])
   #:transparent)
@@ -115,11 +122,11 @@
 ;; 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.
-(define-struct: PushControlFrame ([label : Symbol]) 
+(define-struct: PushControlFrame ([label : (U Symbol LinkedLabel)]) 
   #:transparent)
 
 (define-struct: PushControlFrame/Prompt ([tag : (U OpArg DefaultContinuationPromptTag)]
-                                         [label : Symbol]
+                                         [label : (U Symbol LinkedLabel)]
                                          ;; TODO: add handler and arguments
                                          )
   #:transparent)
@@ -155,7 +162,11 @@
                                   MakeCompiledProcedureShell
                                   ApplyPrimitiveProcedure
 
+                                  ;; Gets at the single-value-return address.
                                   GetControlStackLabel
+                                  ;; Gets at the multiple-value-return address.
+                                  GetControlStackLabel/MultipleValueReturn
+                                  
                                   MakeBoxedEnvironmentValue
 
                                   CaptureEnvironment
@@ -209,6 +220,9 @@
 ;; Gets the return address embedded at the top of the control stack.
 (define-struct: GetControlStackLabel ()
   #:transparent)
+(define-struct: GetControlStackLabel/MultipleValueReturn ()
+  #:transparent)
+
 
 (define-struct: MakeBoxedEnvironmentValue ([depth : Natural])
   #:transparent)

simulator-structs.rkt

@@ -58,7 +58,7 @@
 
 (define-type frame (U CallFrame PromptFrame))
 
-(define-struct: CallFrame ([return : Symbol]
+(define-struct: CallFrame ([return : (U Symbol LinkedLabel)]
                            ;; The procedure being called.  Used to optimize self-application
                            [proc : (U closure #f)]
                            ;; TODO: add continuation marks
@@ -67,7 +67,7 @@
   #:mutable)
 
 (define-struct: PromptFrame ([tag : ContinuationPromptTagValue]
-                             [return : Symbol]
+                             [return : (U Symbol LinkedLabel)]
                              [env-depth : Natural])
   #:transparent)
 

simulator.rkt

@@ -89,6 +89,8 @@
                   (cond
                     [(symbol? i)
                      'ok]
+                    [(LinkedLabel? i)
+                     'ok]
                     [(AssignImmediateStatement? i)
                      (step-assign-immediate! m i)]
                     [(AssignPrimOpStatement? i)
@@ -479,6 +481,13 @@
                                    (PromptFrame-return frame)]
                                   [(CallFrame? frame)
                                    (CallFrame-return frame)])))]
+          [(GetControlStackLabel/MultipleValueReturn? op)
+           (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)

test-compiler.rkt

@@ -1075,6 +1075,10 @@
         #:control-limit 3
         #:with-bootstrapping? #t)
 
+
+
+
+
 #;(test (read (open-input-file "tests/conform/program0.sch"))
       (port->string (open-input-file "tests/conform/expected0.txt")))