RTL Compiler: Fix compilation of basic sequences.

* module/language/cps/slot-allocation.scm: Move the parallel moves into
  a separate hash table.
  (lookup-parallel-moves): Rename table argument to 'moves-table'.
  Use 'hashq-ref' directly instead of 'lookup-allocation'.
  (allocate-slots): Allocate new hash table 'moves-table', use it in
  'parallel-move!', and add it to the list of return values.

* module/language/cps/compile-rtl.scm (emit-rtl-sequence): Accept new
  argument 'moves'.  Pass it to all calls to 'lookup-parallel-moves'.
  (compile-fun): Receive 'moves' from 'allocate-slots', and pass it
  to 'emit-rtl-sequence'.

* test-suite/tests/rtl-compilation.test: Add test.

3 files changed, 25 insertions, 12 deletions

diff --git a/module/language/cps/compile-rtl.scm b/module/language/cps/compile-rtl.scm
index 6d5320eeb..bdc1e37e2 100644
--- a/module/language/cps/compile-rtl.scm
+++ b/module/language/cps/compile-rtl.scm
@@ -103,7 +103,7 @@
 
     (_ seed)))
 
-(define (emit-rtl-sequence exp slots nlocals)
+(define (emit-rtl-sequence exp moves slots nlocals)
   (define (intern-cont! k src cont table)
     (hashq-set! table k cont)
     table)
@@ -144,7 +144,7 @@
           (($ $call proc args)
            (for-each (match-lambda
                       ((src . dst) (emit `(mov ,dst ,src))))
-                     (lookup-parallel-moves label slots))
+                     (lookup-parallel-moves label moves))
            (let ((tail-slots (cdr (iota (1+ (length args))))))
              (for-each maybe-load-constant tail-slots args))
            (emit `(tail-call ,(1+ (length args)))))
@@ -152,7 +152,7 @@
            (let ((tail-slots (cdr (iota (1+ (length args))))))
              (for-each (match-lambda
                         ((src . dst) (emit `(mov ,dst ,src))))
-                       (lookup-parallel-moves label slots))
+                       (lookup-parallel-moves label moves))
              (for-each maybe-load-constant tail-slots args))
            (emit `(return-values ,(length args))))
           (($ $primcall 'return (arg))
@@ -215,7 +215,7 @@
           (($ $values args)
            (for-each (match-lambda
                       ((src . dst) (emit `(mov ,dst ,src))))
-                     (lookup-parallel-moves label slots))
+                     (lookup-parallel-moves label moves))
            (for-each maybe-load-constant (map slot syms) args)))
         (maybe-jump k))
 
@@ -289,7 +289,7 @@
                     (emit `(bind-rest ,(+ proc-slot 1 nreq))))
                   (for-each (match-lambda
                              ((src . dst) (emit `(mov ,dst ,src))))
-                            (lookup-parallel-moves label slots))
+                            (lookup-parallel-moves label moves))
                   (emit `(reset-frame ,nlocals)))
                  ((arg . args)
                   (or (maybe-load-constant n arg)
@@ -337,7 +337,7 @@
 
     (define (emit-fun-entry self body alternate)
       (call-with-values (lambda () (allocate-slots self body))
-        (lambda (slots nlocals)
+        (lambda (moves slots nlocals)
           (match body
             (($ $cont src k
                 ($ $kentry ($ $arity req opt rest kw allow-other-keys?) body))
@@ -350,7 +350,7 @@
                                       ,kw-indices ,allow-other-keys?
                                       ,nlocals
                                       ,alternate))
-               (for-each emit (emit-rtl-sequence body slots nlocals))
+               (for-each emit (emit-rtl-sequence body moves slots nlocals))
                (emit `(end-arity))))))))
 
     (define (emit-fun-entries self entries)
diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm
index 7aa112295..c66df532b 100644
--- a/module/language/cps/slot-allocation.scm
+++ b/module/language/cps/slot-allocation.scm
@@ -119,8 +119,8 @@
     (else
      (error "Continuation not a call" sym))))
 
-(define (lookup-parallel-moves sym allocation)
-  (match (lookup-allocation sym allocation)
+(define (lookup-parallel-moves sym moves-table)
+  (match (hashq-ref moves-table sym)
     (($ $parallel-move moves) moves)
     (else
      (error "Continuation has no parallel moves" sym))))
@@ -215,7 +215,8 @@ are comparable with eqv?.  A tmp slot may be used."
                      ($ $kentry _ ($ $cont _ _ ($ $kargs names syms))))
                   (length syms))))
         (visited (make-hash-table))
-        (allocation (make-hash-table)))
+        (allocation (make-hash-table))
+        (moves-table (make-hash-table)))
     (define (allocate! sym k hint live-set)
       (match (hashq-ref allocation sym)
         (($ $allocation def slot dead has-const)
@@ -257,7 +258,7 @@ are comparable with eqv?.  A tmp slot may be used."
              (moves (solve-parallel-move src-slots dst-slots tmp-slot)))
         (when (and (>= tmp-slot nlocals) (assv tmp-slot moves))
           (set! nlocals (+ tmp-slot 1)))
-        (hashq-set! allocation src-k (make-parallel-move moves))
+        (hashq-set! moves-table src-k (make-parallel-move moves))
         post-live-set))
 
     (let visit ((exp exp)
@@ -368,4 +369,4 @@ are comparable with eqv?.  A tmp slot may be used."
 
         (_ live-set)))
 
-    (values allocation nlocals)))
+    (values moves-table allocation nlocals)))
diff --git a/test-suite/tests/rtl-compilation.test b/test-suite/tests/rtl-compilation.test
index ebc66732e..778edbd58 100644
--- a/test-suite/tests/rtl-compilation.test
+++ b/test-suite/tests/rtl-compilation.test
@@ -79,3 +79,15 @@
 (with-test-prefix "values context"
   1
   )
+
+(with-test-prefix "mixed contexts"
+  (pass-if-equal "sequences" '(3 4 5)
+    (let* ((pair (cons 1 2))
+           (result ((run-rtl '(lambda (pair)
+                                (set-car! pair 3)
+                                (set-cdr! pair 4)
+                                5))
+                    pair)))
+      (list (car pair)
+            (cdr pair)
+            result))))