Add new $calli expression type.

* module/language/cps.scm ($calli): New expression type which calls a
function entry as originally captured via $code.  Adapt all callers.

module/language/cps.scm

@@ -131,7 +131,7 @@
 
             ;; Expressions.
             $const $prim $fun $rec $const-fun $code
-            $call $callk $primcall $values
+            $call $callk $calli $primcall $values
 
             ;; Building macros.
             build-cont build-term build-exp
@@ -193,6 +193,7 @@
 (define-cps-type $code label) ; First-order.
 (define-cps-type $call proc args)
 (define-cps-type $callk k proc args) ; First-order.
+(define-cps-type $calli args callee) ; First-order.
 (define-cps-type $primcall name param args)
 (define-cps-type $values args)
 
@@ -247,7 +248,7 @@
 (define-syntax build-exp
   (syntax-rules (unquote
                  $const $prim $fun $rec $const-fun $code
-                 $call $callk $primcall $values)
+                 $call $callk $calli $primcall $values)
     ((_ (unquote exp)) exp)
     ((_ ($const val)) (make-$const val))
     ((_ ($prim name)) (make-$prim name))
@@ -261,6 +262,9 @@
     ((_ ($callk k proc (unquote args))) (make-$callk k proc args))
     ((_ ($callk k proc (arg ...))) (make-$callk k proc (list arg ...)))
     ((_ ($callk k proc args)) (make-$callk k proc args))
+    ((_ ($calli (unquote args) callee)) (make-$calli args callee))
+    ((_ ($calli (arg ...) callee)) (make-$calli (list arg ...) callee))
+    ((_ ($calli args callee)) (make-$calli args callee))
     ((_ ($primcall name param (unquote args))) (make-$primcall name param args))
     ((_ ($primcall name param (arg ...))) (make-$primcall name param (list arg ...)))
     ((_ ($primcall name param args)) (make-$primcall name param args))
@@ -328,6 +332,8 @@
      (build-exp ($call proc arg)))
     (('callk k proc arg ...)
      (build-exp ($callk k proc arg)))
+    (('calli arg ... callee)
+     (build-exp ($calli arg callee)))
     (('primcall name param arg ...)
      (build-exp ($primcall name param arg)))
     (('values arg ...)
@@ -383,6 +389,8 @@
      `(call ,proc ,@args))
     (($ $callk k proc args)
      `(callk ,k ,proc ,@args))
+    (($ $calli args callee)
+     `(callk ,@args ,callee))
     (($ $primcall name param args)
      `(primcall ,name ,param ,@args))
     (($ $values args)

module/language/cps/closure-conversion.scm

@@ -72,6 +72,8 @@
               (if proc
                   (add-use proc uses)
                   uses)))
+           (($ $calli args callee)
+            (add-uses args (add-use callee uses)))
            (($ $primcall name param args)
             (add-uses args uses))))
         (($ $kargs _ _ ($ $branch kf kt src op param args))
@@ -205,6 +207,8 @@ shared closures to use the appropriate 'self' variable, if possible."
               ((closure . label) ($callk label closure ,args)))))
         (($ $callk label proc args)
          ($callk label (and proc (subst proc)) ,(map subst args)))
+        (($ $calli args callee)
+         ($calli ,(map subst args) (subst callee)))
         (($ $primcall name param args)
          ($primcall name param ,(map subst args)))
         (($ $values args)
@@ -346,6 +350,8 @@ references."
                            (if proc
                                (add-use proc uses)
                                uses)))
+                        (($ $calli args callee)
+                         (add-uses args (add-use callee uses)))
                         (($ $primcall name param args)
                          (add-uses args uses))))
                      (($ $branch kf kt src op param args)
@@ -786,6 +792,15 @@ bound to @var{closure}, and continue to @var{k}."
         (($ $continue k src ($ $callk label proc args))
          (convert-known-proc-call cps k src label proc args))
 
+        (($ $continue k src ($ $calli args callee))
+         (convert-args cps args
+           (lambda (cps args)
+             (convert-arg cps callee
+               (lambda (cps callee)
+                 (with-cps cps
+                   (build-term
+                     ($continue k src ($calli args callee)))))))))
+
         (($ $continue k src ($ $primcall name param args))
          (convert-args cps args
            (lambda (cps args)

module/language/cps/compile-bytecode.scm

@@ -1,6 +1,6 @@
 ;;; Continuation-passing style (CPS) intermediate language (IL)
 
-;; Copyright (C) 2013-2021 Free Software Foundation, Inc.
+;; Copyright (C) 2013-2021, 2023 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
@@ -578,6 +578,8 @@
            (compile-call #f proc args))
           (($ $callk kfun proc args)
            (compile-call kfun proc args))
+          (($ $calli args callee)
+           (error "unreachable"))
           (_
            (match cont
              (($ $kargs names vars)

module/language/cps/contification.scm

@@ -206,8 +206,12 @@ $call, and are always called with a compatible arity."
       (match cont
         (($ $kargs _ _ ($ $continue _ _ exp))
          (match exp
-           ((or ($ $const) ($ $prim) ($ $const-fun) ($ $code) ($ $fun) ($ $rec))
+           ((or ($ $const) ($ $prim) ($ $fun) ($ $rec))
             functions)
+           (($ $const-fun kfun)
+            (intmap-remove functions kfun))
+           (($ $code kfun)
+            (intmap-remove functions kfun))
            (($ $values args)
             (exclude-vars functions args))
            (($ $call proc args)
@@ -226,6 +230,10 @@ $call, and are always called with a compatible arity."
               (restrict-arity functions proc (length args))))
            (($ $callk k proc args)
             (exclude-vars functions (if proc (cons proc args) args)))
+           (($ $calli args callee)
+            ;; While callee is a var and not a label, it is a var that
+            ;; holds a code label, not a function value.
+            (exclude-vars functions args))
            (($ $primcall name param args)
             (exclude-vars functions args))))
         (($ $kargs _ _ ($ $branch kf kt src op param args))
@@ -466,7 +474,7 @@ function set."
           (match (intmap-ref conts k*)
             (($ $kreceive ($ $arity req () rest () #f) kargs)
              (match exp
-               ((or ($ $call) ($ $callk))
+               ((or ($ $call) ($ $callk) ($ $calli))
                 (with-cps cps (build-term ($continue k* src ,exp))))
                ;; We need to punch through the $kreceive; otherwise we'd
                ;; have to rewrite as a call to the 'values primitive.

module/language/cps/cse.scm

@@ -473,6 +473,7 @@ for a label, it isn't known to be constant at that label."
       (($ $code label)                      (cons 'code label))
       (($ $call proc args)                  #f)
       (($ $callk k proc args)               #f)
+      (($ $calli args callee)               #f)
       (($ $primcall name param args)        (cons* name param args))
       (($ $values args)                     #f)))
   (define (compute-term-key term)
@@ -562,6 +563,8 @@ for a label, it isn't known to be constant at that label."
          ($call (subst-var proc) ,(map subst-var args)))
         (($ $callk k proc args)
          ($callk k (and proc (subst-var proc)) ,(map subst-var args)))
+        (($ $calli args callee)
+         ($calli ,(map subst-var args) (subst-var callee)))
         (($ $primcall name param args)
          ($primcall name param ,(map subst-var args)))
         (($ $values args)

module/language/cps/dce.scm

@@ -160,6 +160,8 @@ sites."
                  (adjoin-vars args (if proc
                                        (adjoin-var proc live-vars)
                                        live-vars))))
+        (($ $calli args callee)
+         (values live-labels (adjoin-var callee (adjoin-vars args live-vars))))
         (($ $primcall name param args)
          (values live-labels (adjoin-vars args live-vars)))
         (($ $values args)

module/language/cps/devirtualize-integers.scm

@@ -1,6 +1,6 @@
 ;;; Continuation-passing style (CPS) intermediate language (IL)
 
-;; Copyright (C) 2017-2020 Free Software Foundation, Inc.
+;; Copyright (C) 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
@@ -71,6 +71,8 @@
                (add-uses (add-use use-counts proc) args))
               (($ $callk kfun proc args)
                (add-uses (if proc (add-use use-counts proc) use-counts) args))
+              (($ $calli args callee)
+               (add-use (add-uses use-counts args) callee))
               (($ $primcall name param args)
                (add-uses use-counts args))))
            (($ $branch kf kt src op param args)

module/language/cps/dump.scm

@@ -163,6 +163,9 @@
                (arg-list
                 (cons (if proc (format-var proc) "_")
                       (map format-var args)))))
+      (($ $calli args callee)
+       (format #f "calli ~a(~a)"
+               (format-var callee) (arg-list (map format-var args))))
       (($ $primcall name param args)
        (format-primcall name param args))
       (($ $values args)

module/language/cps/effects-analysis.scm

@@ -738,7 +738,7 @@ the LABELS that are clobbered by the effects of LABEL."
      &no-effects)
     ((or ($ $fun) ($ $rec))
      (&allocate &unknown-memory-kinds))
-    ((or ($ $call) ($ $callk))
+    ((or ($ $call) ($ $callk) ($ $calli))
      &all-effects)
     (($ $primcall name param args)
      (primitive-effects param name args))))

module/language/cps/guile-vm/lower-primcalls.scm

@@ -603,6 +603,9 @@
      (intmap-fold
       (lambda (label cont cps)
         (match cont
+          (($ $kargs names vars
+              ($ $continue k src ($ $calli)))
+           (error "$calli unsupported by guile-vm backend"))
           (($ $kargs names vars
               ($ $continue k src ($ $primcall op param args)))
            (match (hashq-ref *primcall-lowerers* op)

module/language/cps/guile-vm/reify-primitives.scm

@@ -1,6 +1,6 @@
 ;;; Continuation-passing style (CPS) intermediate language (IL)
 
-;; Copyright (C) 2013-2021, 2023 Free Software Foundation, Inc.
+;; Copyright (C) 2013-2021,2023 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

module/language/cps/peel-loops.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
@@ -149,6 +149,8 @@
        ($call (rename-var proc) ,(map rename-var args)))
       (($ $callk k proc args)
        ($callk k (and proc (rename-var proc)) ,(map rename-var args)))
+      (($ $calli args callee)
+       ($calli ,(map rename-var args) (rename-var callee)))
       (($ $primcall name param args)
        ($primcall name param ,(map rename-var args)))))
   (define (rename-term term)

module/language/cps/renumber.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
@@ -152,8 +152,6 @@
       (($ $kargs names syms ($ $continue k src ($ $code kfun)))
        (maybe-visit-fun kfun labels vars))
       (($ $kargs names syms ($ $continue k src ($ $callk kfun)))
-       ;; Well-known functions never have a $const-fun created for them
-       ;; and are only referenced by their $callk call sites.
        (maybe-visit-fun kfun labels vars))
       (_ (values labels vars))))
   (define (visit-fun kfun labels vars)
@@ -188,6 +186,8 @@
         (($ $callk k proc args)
          ($callk (rename-label k) (and proc (rename-var proc))
                  ,(map rename-var args)))
+        (($ $calli args callee)
+         ($calli ,(map rename-var args) (rename-var callee)))
         (($ $primcall name param args)
          ($primcall name param ,(map rename-var args)))))
     (define (rename-arity arity)

module/language/cps/rotate-loops.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
@@ -117,6 +117,8 @@ corresponding var from REPLACEMENTS; otherwise return VAR."
                   ($call (rename proc) ,(rename* args)))
                  (($ $callk k proc args)
                   ($callk k (and proc (rename proc)) ,(rename* args)))
+                 (($ $calli args callee)
+                  ($calli ,(rename* args) (rename callee)))
                  (($ $primcall name param args)
                   ($primcall name param ,(rename* args))))))
            (($ $branch kf kt src op param args)

module/language/cps/self-references.scm

@@ -43,6 +43,8 @@
        ($call (subst proc) ,(map subst args)))
       (($ $callk k proc args)
        ($callk k (and proc (subst proc)) ,(map subst args)))
+      (($ $calli args callee)
+       ($calli ,(map subst args) (subst callee)))
       (($ $primcall name param args)
        ($primcall name param ,(map subst args)))
       (($ $values args)

module/language/cps/simplify.scm

@@ -74,6 +74,8 @@
           (ref* (cons proc args)))
          (($ $callk k proc args)
           (ref* (if proc (cons proc args) args)))
+         (($ $calli args callee)
+          (ref* (cons callee args)))
          (($ $primcall name param args)
           (ref* args))
          (($ $values args)
@@ -241,6 +243,8 @@
                    ($call (subst proc) ,(map subst args)))
                   (($ $callk k proc args)
                    ($callk k (and proc (subst proc)) ,(map subst args)))
+                  (($ $calli args callee)
+                   ($calli ,(map subst args) (subst callee)))
                   (($ $primcall name param args)
                    ($primcall name param ,(map subst args)))
                   (($ $values args)

module/language/cps/slot-allocation.scm

@@ -1,6 +1,6 @@
 ;; Continuation-passing style (CPS) intermediate language (IL)
 
-;; Copyright (C) 2013-2021 Free Software Foundation, Inc.
+;; Copyright (C) 2013-2021,2023 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
@@ -73,8 +73,8 @@
   (call-allocs allocation-call-allocs)
 
   ;; A map of LABEL to /parallel moves/.  Parallel moves shuffle locals
-  ;; into position for a $call, $callk, or $values, or shuffle returned
+  ;; into position for a $call, $callk, $calli, or $values, or shuffle
-  ;; values back into place at a return continuation.
+  ;; returned values back into place for a $kreceive.
   ;;
   ;; A set of moves is expressed as an ordered list of (SRC . DST)
   ;; moves, where SRC and DST are slots.  This may involve a temporary
@@ -237,6 +237,9 @@ is an active call."
                      (let ((args (list->intset args)))
                        (intset-subtract (if proc (intset-add args proc) args)
                                         (intmap-ref live-out label))))
+                    (($ $kargs _ _ ($ $continue _ _ ($ $calli args callee)))
+                     (intset-subtract (list->intset (cons callee args))
+                                      (intmap-ref live-out label)))
                     (($ $kargs _ _ ($ $continue k _($ $values args)))
                      (match (intmap-ref cps k)
                        (($ $ktail) (list->intset args))
@@ -492,6 +495,8 @@ are comparable with eqv?.  A tmp slot may be used."
           (add-call-shuffles label k (cons proc args) shuffles))
          (($ $callk _ proc args)
           (add-call-shuffles label k (if proc (cons proc args) args) shuffles))
+         (($ $calli args callee)
+          (add-call-shuffles label k (append args (list callee)) shuffles))
          (($ $values args)
           (add-values-shuffles label k args shuffles))
          (_ shuffles)))
@@ -538,6 +543,8 @@ are comparable with eqv?.  A tmp slot may be used."
            (($ $continue _ _ ($ $callk _ proc args))
             (let ((nclosure (if proc 1 0)))
               (call-size label (+ nclosure (length args)) size)))
+           (($ $continue _ _ ($ $calli args callee))
+            (call-size label (1+ (length args)) size))
            (($ $continue _ _ ($ $values args))
             (shuffle-size (get-shuffles label) size))
            (($ $prompt)
@@ -624,6 +631,8 @@ are comparable with eqv?.  A tmp slot may be used."
           (allocate-call label (cons proc args) slots))
          (($ $callk _ proc args)
           (allocate-call label (if proc (cons proc args) args) slots))
+         (($ $calli args callee)
+          (allocate-call label (append args (list callee)) slots))
          (($ $values args)
           (allocate-values label k args slots))
          (_ slots)))
@@ -825,6 +834,9 @@ are comparable with eqv?.  A tmp slot may be used."
              (($ $continue k src ($ $callk _ proc args))
               (allocate-call label k (if proc (cons proc args) args)
                              slots call-allocs live))
+             (($ $continue k src ($ $calli args callee))
+              (allocate-call label k (append args (list callee))
+                             slots call-allocs live))
              (($ $continue k src ($ $values args))
               (allocate-values label k args slots call-allocs))
              (($ $prompt k kh src escape? tag)

module/language/cps/specialize-numbers.scm

@@ -1,6 +1,6 @@
 ;;; Continuation-passing style (CPS) intermediate language (IL)
 
-;; Copyright (C) 2015-2020 Free Software Foundation, Inc.
+;; Copyright (C) 2015-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
@@ -361,6 +361,8 @@ BITS indicating the significant bits needed for a variable.  BITS may be
                          (if proc
                              (add-unknown-use out proc)
                              out)))
+                      (($ $calli args callee)
+                       (add-unknown-uses (add-unknown-use out callee) args))
                       (($ $primcall name param args)
                        (let ((h (significant-bits-handler name)))
                          (if h

module/language/cps/split-rec.scm

@@ -94,6 +94,8 @@ references."
                            (if proc
                                (add-use proc uses)
                                uses)))
+                        (($ $calli args callee)
+                         (add-uses args (add-use callee uses)))
                         (($ $primcall name param args)
                          (add-uses args uses))))
                      (($ $branch kf kt src op param args)

module/language/cps/types.scm

@@ -2102,7 +2102,7 @@ maximum, where type is a bitset as a fixnum."
                      (adjoin-var out def (var-type-entry in arg))))))))
          (_
           (propagate1 k types))))
-      ((or ($ $call) ($ $callk))
+      ((or ($ $call) ($ $callk) ($ $calli))
        (propagate1 k types))
       (($ $rec names vars funs)
        (let ((proc-type (make-type-entry &procedure -inf.0 +inf.0)))

module/language/cps/utils.scm

@@ -351,6 +351,8 @@ by a label, respectively."
            (($ $callk _ proc args)
             (let ((args (vars->intset args)))
               (return (get-defs k) (if proc (intset-add args proc) args))))
+           (($ $calli args callee)
+            (return (get-defs k) (intset-add (vars->intset args) callee)))
            (($ $primcall name param args)
             (return (get-defs k) (vars->intset args)))
            (($ $values args)

module/language/cps/verify.scm

@@ -1,5 +1,5 @@
 ;;; Diagnostic checker for CPS
-;;; Copyright (C) 2014-2021 Free Software Foundation, Inc.
+;;; Copyright (C) 2014-2021,2023 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
@@ -174,6 +174,10 @@ definitions that are available at LABEL."
          (when proc (check-use proc))
          (for-each check-use args)
          (visit-first-order kfun))
+        (($ $calli args callee)
+         (for-each check-use args)
+         (check-use callee)
+         first-order)
         (($ $primcall name param args)
          (for-each check-use args)
          first-order)))
@@ -211,6 +215,10 @@ definitions that are available at LABEL."
             (when proc (check-use proc))
             (for-each check-use args)
             (visit-first-order kfun))
+           (($ $calli args callee)
+            (for-each check-use args)
+            (check-use callee)
+            first-order)
            (($ $primcall name param args)
             (for-each check-use args)
             first-order)))
@@ -290,7 +298,7 @@ definitions that are available at LABEL."
        (match cont
          ((or ($ $kreceive) ($ $ktail)) #t)
          (_ (error "expected $kreceive or $ktail continuation" cont))))
-      (($ $callk k proc args)
+      ((or ($ $calli) ($ $callk))
        (match cont
          ((or ($ $kargs) ($ $kreceive) ($ $ktail)) #t)
          (_ (error "expected $kargs, $kreceive or $ktail continuation" cont))))