[Guile-commits] 03/05: Allow callk to continue to kargs

[Andy Wingo]

wingo pushed a commit to branch main
in repository guile.

commit 5c76381625e3b5e7b25be0b97b42b487627e6478
Author: Andy Wingo <wingo@pobox.com>
AuthorDate: Mon Nov 15 10:39:04 2021 +0100

    Allow callk to continue to kargs
    
    * module/language/cps/verify.scm (check-arities): If a callk continues
    to kargs, the caller knows the number of return values that the callee
    provides and no number-of-values check is needed.
    * module/language/cps/contification.scm (apply-contification): Allow
    contification of known-return-values calls.
    * module/language/cps/reify-primitives.scm (uniquify-receive)
    (reify-primitives): No need for uniquify-receive any more as receive
    shuffles are attached to the call, not the continuation.
    * module/language/cps/compile-bytecode.scm (compile-function): Add kargs
    case.
---
 module/language/cps/compile-bytecode.scm |  2 ++
 module/language/cps/contification.scm    |  9 +++++++--
 module/language/cps/reify-primitives.scm | 20 --------------------
 module/language/cps/utils.scm            |  8 +++++++-
 module/language/cps/verify.scm           | 14 +++++++-------
 5 files changed, 23 insertions(+), 30 deletions(-)

diff --git a/module/language/cps/compile-bytecode.scm 
b/module/language/cps/compile-bytecode.scm
index 58d908b..53a2524 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -135,6 +135,8 @@
                (emit-fmov asm dst src)
                (lp moves reset-frame?)))))))
       (match cont
+        (($ $kargs)
+         (shuffle-results))
         (($ $kreceive ($ $arity req () rest () #f) kargs)
          (let ((nreq (length req))
                (rest-var (and rest
diff --git a/module/language/cps/contification.scm 
b/module/language/cps/contification.scm
index 8f07f79..7a05fa2 100644
--- a/module/language/cps/contification.scm
+++ b/module/language/cps/contification.scm
@@ -469,8 +469,9 @@ function set."
       (if (eq? k k*)
           (with-cps cps (build-term ($continue k src ,exp)))
           ;; We are contifying this return.  It must be a call or a
-          ;; $values expression.  k* will be either a $ktail or a
-          ;; $kreceive continuation.
+          ;; $values expression.  k* will be a $ktail or a $kreceive
+          ;; continuation, or a $kargs continuation for a
+          ;; known-number-of-values return.
           (match (intmap-ref conts k*)
             (($ $kreceive ($ $arity req () rest () #f) kargs)
              (match exp
@@ -480,6 +481,10 @@ function set."
                ;; have to rewrite as a call to the 'values primitive.
                (($ $values vals)
                 (inline-return cps k* kargs src (length req) rest vals))))
+            (($ $kargs)
+             (match exp
+               ((or ($ $callk) ($ $values))
+                (with-cps cps (build-term ($continue k* src ,exp))))))
             (($ $ktail)
              (with-cps cps (build-term ($continue k* src ,exp))))))))
   (define (contify-unchecked-function cps kfun)
diff --git a/module/language/cps/reify-primitives.scm 
b/module/language/cps/reify-primitives.scm
index d0441ff..5f42415 100644
--- a/module/language/cps/reify-primitives.scm
+++ b/module/language/cps/reify-primitives.scm
@@ -102,16 +102,6 @@
     (letk kclause ($kclause ('() '() #f '() #f) kbody #f))
     kclause))
 
-;; A $kreceive continuation should have only one predecessor.
-(define (uniquify-receive cps k)
-  (match (intmap-ref cps k)
-    (($ $kreceive ($ $arity req () rest () #f) kargs)
-     (with-cps cps
-       (letk k ($kreceive req rest kargs))
-       k))
-    (_
-     (with-cps cps k))))
-
 (define (wrap-unary cps k src wrap unwrap op param a)
   (with-cps cps
     (letv a* res*)
@@ -619,16 +609,6 @@
           ((imm-s64-< (s12? a) b) load-s64 (s64-< a b))
           ((eq-constant? (imm16? b) a) load-const (eq? a b))
           (_ cps))))
-      (($ $kargs names vars ($ $continue k src ($ $call proc args)))
-       (with-cps cps
-         (let$ k (uniquify-receive k))
-         (setk label ($kargs names vars
-                       ($continue k src ($call proc args))))))
-      (($ $kargs names vars ($ $continue k src ($ $callk k* proc args)))
-       (with-cps cps
-         (let$ k (uniquify-receive k))
-         (setk label ($kargs names vars
-                       ($continue k src ($callk k* proc args))))))
       (_ cps)))
 
   (with-fresh-name-state cps
diff --git a/module/language/cps/utils.scm b/module/language/cps/utils.scm
index 2b0c91c..584fb3b 100644
--- a/module/language/cps/utils.scm
+++ b/module/language/cps/utils.scm
@@ -389,6 +389,8 @@ by a label, respectively."
              (($ $values (arg))
               (intmap-add representations var
                           (intmap-ref representations arg)))
+             (($ $callk)
+              (intmap-add representations var 'scm))
              (($ $primcall (or 'scm->f64 'load-f64 's64->f64
                                'f32-ref 'f64-ref
                                'fadd 'fsub 'fmul 'fdiv 'fsqrt 'fabs
@@ -425,7 +427,11 @@ by a label, respectively."
               (fold (lambda (arg var representations)
                       (intmap-add representations var
                                   (intmap-ref representations arg)))
-                    representations args vars))))))
+                    representations args vars))
+             (($ $callk)
+              (fold1 (lambda (var representations)
+                      (intmap-add representations var 'scm))
+                     vars representations))))))
        (($ $kargs _ _ (or ($ $branch) ($ $switch) ($ $prompt) ($ $throw)))
         representations)
        (($ $kfun src meta self tail entry)
diff --git a/module/language/cps/verify.scm b/module/language/cps/verify.scm
index 88dcbc0..58317ae 100644
--- a/module/language/cps/verify.scm
+++ b/module/language/cps/verify.scm
@@ -1,5 +1,5 @@
 ;;; Diagnostic checker for CPS
-;;; Copyright (C) 2014-2020 Free Software Foundation, Inc.
+;;; Copyright (C) 2014-2021 Free Software Foundation, Inc.
 ;;;
 ;;; This library is free software: you can redistribute it and/or modify
 ;;; it under the terms of the GNU Lesser General Public License as
@@ -271,10 +271,6 @@ definitions that are available at LABEL."
          (unless (= (length vars) n)
            (error "expected n-ary continuation" n cont)))
         (_ (error "expected $kargs continuation" cont))))
-    (define (assert-kreceive-or-ktail)
-      (match cont
-        ((or ($ $kreceive) ($ $ktail)) #t)
-        (_ (error "expected $kreceive or $ktail continuation" cont))))
     (match exp
       ((or ($ $const) ($ $prim) ($ $const-fun) ($ $code) ($ $fun))
        (assert-unary))
@@ -291,9 +287,13 @@ definitions that are available at LABEL."
          (($ $ktail) #t)
          (_ (assert-n-ary (length args)))))
       (($ $call proc args)
-       (assert-kreceive-or-ktail))
+       (match cont
+         ((or ($ $kreceive) ($ $ktail)) #t)
+         (_ (error "expected $kreceive or $ktail continuation" cont))))
       (($ $callk k proc args)
-       (assert-kreceive-or-ktail))
+       (match cont
+         ((or ($ $kargs) ($ $kreceive) ($ $ktail)) #t)
+         (_ (error "expected $kargs, $kreceive or $ktail continuation" cont))))
       (($ $primcall name param args)
        (match cont
          (($ $kargs) #t)