Allow $kargs as entry of $kfun

* module/language/cps.scm:
* module/language/cps/contification.scm:
* module/language/cps/cse.scm:
* module/language/cps/dce.scm:
* module/language/cps/simplify.scm:
* module/language/cps/slot-allocation.scm:
* module/language/cps/types.scm: Allow $kargs to follow $kfun.  In that
case, the function must be well-known and callers are responsible for
calling with the appropriate arity.
* module/language/cps/compile-bytecode.scm: Emit "unchecked-arity" for
$kargs following $kfun.
* module/system/vm/assembler.scm: Adapt.

8 files changed, 86 insertions, 54 deletions

diff --git a/module/language/cps.scm b/module/language/cps.scm
index 9682061c9..f83b62533 100644
--- a/module/language/cps.scm
+++ b/module/language/cps.scm
@@ -1,6 +1,6 @@
 ;;; Continuation-passing style (CPS) intermediate language (IL)
 
-;; Copyright (C) 2013-2015,2017-2018,2020 Free Software Foundation, Inc.
+;; Copyright (C) 2013-2015,2017-2018,2020,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
@@ -173,7 +173,7 @@
 ;; Continuations
 (define-cps-type $kreceive arity kbody)
 (define-cps-type $kargs names syms term)
-(define-cps-type $kfun src meta self ktail kclause)
+(define-cps-type $kfun src meta self ktail kentry)
 (define-cps-type $ktail)
 (define-cps-type $kclause arity kbody kalternate)
 
@@ -214,8 +214,8 @@
      (make-$kargs (list name ...) (list sym ...) (build-term body)))
     ((_ ($kargs names syms body))
      (make-$kargs names syms (build-term body)))
-    ((_ ($kfun src meta self ktail kclause))
-     (make-$kfun src meta self ktail kclause))
+    ((_ ($kfun src meta self ktail kentry))
+     (make-$kfun src meta self ktail kentry))
     ((_ ($ktail))
      (make-$ktail))
     ((_ ($kclause arity kbody kalternate))
@@ -288,8 +288,8 @@
      (build-cont ($kreceive req rest k)))
     (('kargs names syms body)
      (build-cont ($kargs names syms ,(parse-cps body))))
-    (('kfun meta self ktail kclause)
-     (build-cont ($kfun (src exp) meta self ktail kclause)))
+    (('kfun meta self ktail kentry)
+     (build-cont ($kfun (src exp) meta self ktail kentry)))
     (('ktail)
      (build-cont ($ktail)))
     (('kclause (req opt rest kw allow-other-keys?) kbody)
@@ -342,8 +342,8 @@
      `(kreceive ,req ,rest ,k))
     (($ $kargs names syms body)
      `(kargs ,names ,syms ,(unparse-cps body)))
-    (($ $kfun src meta self ktail kclause)
-     `(kfun ,meta ,self ,ktail ,kclause))
+    (($ $kfun src meta self ktail kentry)
+     `(kfun ,meta ,self ,ktail ,kentry))
     (($ $ktail)
      `(ktail))
     (($ $kclause ($ $arity req opt rest kw allow-other-keys?) kbody kalternate)
diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm
index e7d8abc61..40cd90486 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -1,6 +1,6 @@
 ;;; Continuation-passing style (CPS) intermediate language (IL)
 
-;; Copyright (C) 2013-2020 Free Software Foundation, Inc.
+;; Copyright (C) 2013-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
@@ -638,10 +638,17 @@
 
     (define (compile-cont label cont)
       (match cont
-        (($ $kfun src meta self tail clause)
+        (($ $kfun src meta self tail entry)
          (when src
            (emit-source asm src))
-         (emit-begin-program asm label meta))
+         (emit-begin-program asm label meta)
+         ;; If the function has a $kargs as entry, handle 
+         (match (intmap-ref cps entry)
+           (($ $kclause) #t) ;; Leave arity handling to the 
+           (($ $kargs names vars _)
+            (emit-begin-unchecked-arity asm (->bool self) names frame-size)
+            (when self
+              (emit-definition asm 'closure 0 'scm)))))
         (($ $kclause ($ $arity req opt rest kw allow-other-keys?) body alt)
          (let ((first? (match (intmap-ref cps (1- label))
                          (($ $kfun) #t)
diff --git a/module/language/cps/contification.scm b/module/language/cps/contification.scm
index 664c4b305..7cea6b243 100644
--- a/module/language/cps/contification.scm
+++ b/module/language/cps/contification.scm
@@ -1,6 +1,6 @@
 ;;; Continuation-passing style (CPS) intermediate language (IL)
 
-;; Copyright (C) 2013-2020 Free Software Foundation, Inc.
+;; Copyright (C) 2013-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
@@ -79,7 +79,9 @@ from label to arities."
     (if clause
         (match (intmap-ref conts clause)
           (($ $kclause arity body alt)
-           (cons arity (clause-arities alt))))
+           (cons arity (clause-arities alt)))
+          (($ $kargs names vars _)
+           (list (make-$arity names '() #f '() #f))))
         '()))
   (intmap-map (lambda (label vars)
                  (match (intmap-ref conts label)
@@ -346,7 +348,10 @@ function set."
            (($ $kclause arity body alt)
             (if (arity-matches? arity nargs)
                 body
-                (lp alt))))))))
+                (lp alt)))
+           (($ $kargs names)
+            (unless (= nargs (length names)) (error "what"))
+            clause))))))
   (define (inline-return cps k* kargs src nreq rest vals)
     (define (build-list cps k src vals)
       (match vals
diff --git a/module/language/cps/cse.scm b/module/language/cps/cse.scm
index efa95cda9..55cf5490e 100644
--- a/module/language/cps/cse.scm
+++ b/module/language/cps/cse.scm
@@ -1,6 +1,6 @@
 ;;; Continuation-passing style (CPS) intermediate language (IL)
 
-;; Copyright (C) 2013-2020 Free Software Foundation, Inc.
+;; Copyright (C) 2013-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
@@ -287,7 +287,10 @@ for a label, it isn't known to be constant at that label."
      ($kreceive req rest (rename kbody)))
     (($ $kclause arity kbody kalternate)
      ;; Can only be a body continuation.
-     ($kclause ,arity (rename kbody) kalternate))))
+     ($kclause ,arity (rename kbody) kalternate))
+    (($ $kfun src meta self tail kentry)
+     ;; Can only be a $kargs clause continuation.
+     ($kfun src meta self tail (rename kentry)))))
 
 (define (elide-predecessor label pred out analysis)
   (match analysis
@@ -722,7 +725,7 @@ for a label, it isn't known to be constant at that label."
                          ;; those as well.
                          (add-auxiliary-definitions! pred vars substs term-key)))
                       (visit-term-normally))
-                     ((or ($ $kclause) ($ $kreceive))
+                     ((or ($ $kclause) ($ $kfun) ($ $kreceive))
                       (visit-term-normally)))))
              (else
               (visit-term-normally)))))))
diff --git a/module/language/cps/dce.scm b/module/language/cps/dce.scm
index aa52611af..bc8345d9b 100644
--- a/module/language/cps/dce.scm
+++ b/module/language/cps/dce.scm
@@ -1,6 +1,6 @@
 ;;; Continuation-passing style (CPS) intermediate language (IL)
 
-;; Copyright (C) 2013-2020 Free Software Foundation, Inc.
+;; Copyright (C) 2013-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
@@ -88,8 +88,8 @@ sites."
                           (values known unknown))
                          (($ $kreceive arity kargs)
                           (values known (intset-add! unknown kargs)))
-                         (($ $kfun src meta self tail clause)
-                          (values known unknown))
+                         (($ $kfun src meta self tail entry)
+                          (values known (intset-add! unknown entry)))
                          (($ $kclause arity body alt)
                           (values known (intset-add! unknown body)))
                          (($ $ktail)
@@ -267,9 +267,11 @@ sites."
             (values live-labels live-vars))
            (($ $kclause arity kargs kalt)
             (values live-labels (adjoin-vars (cont-defs kargs) live-vars)))
-           (($ $kfun src meta self)
+           (($ $kfun src meta self tail entry)
             (values live-labels
-                    (if self (adjoin-var self live-vars) live-vars)))
+                    (adjoin-vars
+                     (or (cont-defs entry) '())
+                     (if self (adjoin-var self live-vars) live-vars))))
            (($ $ktail)
             (values live-labels live-vars))))
        conts label live-labels live-vars))
diff --git a/module/language/cps/simplify.scm b/module/language/cps/simplify.scm
index b44c1e78c..20c1279b9 100644
--- a/module/language/cps/simplify.scm
+++ b/module/language/cps/simplify.scm
@@ -1,6 +1,6 @@
 ;;; Continuation-passing style (CPS) intermediate language (IL)
 
-;; Copyright (C) 2013-2015, 2017-2020 Free Software Foundation, Inc.
+;; Copyright (C) 2013-2015, 2017-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
@@ -177,6 +177,8 @@
                ($kreceive req rest (subst k)))
               (($ $kclause arity body alt)
                ($kclause ,arity (subst body) alt))
+              (($ $kfun src meta self tail entry)
+               ($kfun src meta self tail (subst entry)))
               (_ ,cont))))
      conts)))
 
diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm
index 6a90db05d..ff32e1ae1 100644
--- a/module/language/cps/slot-allocation.scm
+++ b/module/language/cps/slot-allocation.scm
@@ -1,6 +1,6 @@
 ;; Continuation-passing style (CPS) intermediate language (IL)
 
-;; Copyright (C) 2013-2020 Free Software Foundation, Inc.
+;; Copyright (C) 2013-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
@@ -142,8 +142,11 @@ by a label, respectively."
         (values (intmap-add! defs label d)
                 (intmap-add! uses label u)))
       (match cont
-        (($ $kfun src meta self)
-         (return (if self (intset self) empty-intset) empty-intset))
+        (($ $kfun src meta self tail clause)
+         (return (intset-union
+                  (if clause (get-defs clause) empty-intset)
+                  (if self (intset self) empty-intset))
+                 empty-intset))
         (($ $kargs _ _ ($ $continue k src exp))
          (match exp
            ((or ($ $const) ($ $const-fun) ($ $code))
@@ -331,7 +334,7 @@ the definitions that are live before and after LABEL, as intsets."
         (($ $kclause arity body alternate)
          (get-defs label))
         (($ $kfun src meta self)
-         (if self (intset self) empty-intset))
+         (get-defs label))
         (($ $ktail)
          empty-intset))))
    cps
@@ -657,27 +660,29 @@ are comparable with eqv?.  A tmp slot may be used."
   (intmap-fold measure-cont cps minimum-frame-size))
 
 (define (allocate-args cps)
+  (define (add-clause entry first-slot slots)
+    (match (intmap-ref cps entry)
+      (($ $kclause arity body alt)
+       (let ((slots (add-clause body first-slot slots)))
+         (if alt
+             (add-clause alt first-slot slots)
+             slots)))
+      (($ $kargs names vars)
+       (let lp ((vars vars) (n first-slot) (slots slots))
+         (match vars
+           (() slots)
+           ((var . vars)
+            (lp vars
+                (1+ n)
+                (intmap-add slots var n))))))))
   (match (intmap-ref cps (intmap-next cps))
-    (($ $kfun _ _ has-self?)
-     (intmap-fold (lambda (label cont slots)
-                    (match cont
-                      (($ $kfun src meta self)
-                       (if has-self?
-                           (intmap-add! slots self 0)
-                           slots))
-                      (($ $kclause arity body alt)
-                       (match (intmap-ref cps body)
-                         (($ $kargs names vars)
-                          (let lp ((vars vars) (slots slots)
-                                   (n (if has-self? 1 0)))
-                            (match vars
-                              (() slots)
-                              ((var . vars)
-                               (lp vars
-                                   (intmap-add! slots var n)
-                                   (1+ n))))))))
-                      (_ slots)))
-                  cps empty-intmap))))
+    (($ $kfun src meta self tail entry)
+     (add-clause
+      entry
+      (if self 1 0)
+      (if self
+          (intmap-add empty-intmap self 0)
+          empty-intmap)))))
 
 (define (allocate-lazy-vars cps slots call-allocs live-in lazy)
   (define (compute-live-slots slots label)
@@ -796,10 +801,13 @@ are comparable with eqv?.  A tmp slot may be used."
                     representations args vars))))))
        (($ $kargs _ _ (or ($ $branch) ($ $switch) ($ $prompt) ($ $throw)))
         representations)
-       (($ $kfun src meta self)
-        (if self
-            (intmap-add representations self 'scm)
-            representations))
+       (($ $kfun src meta self tail entry)
+        (let ((representations (if self
+                                   (intmap-add representations self 'scm)
+                                   representations)))
+          (fold1 (lambda (var representations)
+                   (intmap-add representations var 'scm))
+                 (get-defs entry) representations)))
        (($ $kclause arity body alt)
         (fold1 (lambda (var representations)
                  (intmap-add representations var 'scm))
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index 574c39bd2..7657bf409 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -2098,9 +2098,14 @@ maximum, where type is a bitset as a fixnum."
             (propagate1 k (adjoin-vars types vars all-types-entry)))))
         (($ $kfun src meta self tail clause)
          (if clause
-             (propagate1 clause (if self
-                                    (adjoin-var types self all-types-entry)
-                                    types))
+             (let ((types (if self
+                              (adjoin-var types self all-types-entry)
+                              types)))
+               (propagate1 clause
+                           (match (intmap-ref conts clause)
+                             (($ $kargs _ defs)
+                              (adjoin-vars types defs all-types-entry))
+                             (_ types))))
              (propagate0)))
         (($ $kclause arity kbody kalt)
          (match (intmap-ref conts kbody)