Remove contification restriction in case-lambda

* module/language/cps/compile-bytecode.scm (compile-function): Check for
  fallthrough after $kclause too; possible to need to jump if clause
  tails are contified.
* module/language/cps/contification.scm (compute-contification-candidates):
  Enable inter-clause contification.

2 files changed, 12 insertions, 31 deletions

diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm
index 0524c1e97..98d635466 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -553,7 +553,12 @@
            (emit-begin-kw-arity asm req opt rest kw-indices allow-other-keys?
                                 frame-size alt)
            ;; All arities define a closure binding in slot 0.
-           (emit-definition asm 'closure 0 'scm)))
+           (emit-definition asm 'closure 0 'scm)
+           ;; Usually we just fall through, but it could be the body is
+           ;; contified into another clause.
+           (let ((body (forward-label body)))
+             (unless (= body (skip-elided-conts (1+ label)))
+               (emit-br asm body)))))
         (($ $kargs names vars ($ $continue k src exp))
          (emit-label asm label)
          (for-each (lambda (name var)
diff --git a/module/language/cps/contification.scm b/module/language/cps/contification.scm
index c08cfbc2e..f5727f842 100644
--- a/module/language/cps/contification.scm
+++ b/module/language/cps/contification.scm
@@ -98,24 +98,6 @@ the set."
                  conts
                  empty-intmap)))
 
-(define (compute-multi-clause conts)
-  "Compute an set containing all labels that are part of a multi-clause
-case-lambda.  See the note in compute-contification-candidates."
-  (define (multi-clause? clause)
-    (and clause
-         (match (intmap-ref conts clause)
-           (($ $kclause arity body alt)
-            alt))))
-  (intmap-fold (lambda (label cont multi)
-                 (match cont
-                   (($ $kfun src meta self tail clause)
-                    (if (multi-clause? clause)
-                        (intset-union multi (compute-function-body conts label))
-                        multi))
-                   (_ multi)))
-               conts
-               empty-intset))
-
 (define (compute-arities conts functions)
   "Given the map FUNCTIONS whose keys are $kfun labels, return a map
 from label to arities."
@@ -152,7 +134,6 @@ from label to arities."
 functions with known uses that are only ever used as the operator of a
 $call, and are always called with a compatible arity."
   (let* ((functions (compute-functions conts))
-         (multi-clause (compute-multi-clause conts))
          (vars (intmap-fold (lambda (label vars out)
                               (intset-fold (lambda (var out)
                                              (intmap-add out var label))
@@ -191,23 +172,18 @@ $call, and are always called with a compatible arity."
             (exclude-vars functions args))
            (($ $call proc args)
             (let ((functions (exclude-vars functions args)))
-              ;; This contification algorithm is happy to contify the
-              ;; `lp' in this example into a shared tail between clauses:
+              ;; Note that this contification algorithm is happy to
+              ;; contify the `lp' in this example into a shared tail
+              ;; between clauses:
               ;;
               ;; (letrec ((lp (lambda () (lp))))
               ;;   (case-lambda
               ;;     ((a) (lp))
               ;;     ((a b) (lp))))
               ;;
-              ;; However because the current compilation pipeline has to
-              ;; re-nest continuations into old CPS, there would be no
-              ;; scope in which the tail would be valid.  So, until the
-              ;; old compilation pipeline is completely replaced,
-              ;; conservatively exclude contifiable fucntions called
-              ;; from multi-clause procedures.
-              (if (intset-ref multi-clause label)
-                  (exclude-var functions proc)
-                  (restrict-arity functions proc (length args)))))
+              ;; This can cause cross-clause jumps.  The rest of the
+              ;; compiler handles this fine though, so we allow it.
+              (restrict-arity functions proc (length args))))
            (($ $callk k proc args)
             (exclude-vars functions (cons proc args)))
            (($ $branch kt ($ $primcall name args))