Add compiler support for eliding closure bindings

* module/language/cps/closure-conversion.scm (compute-elidable-closures):
  New function.
  (convert-one, convert-closures): Add ability to set "self" variable of
  $kfun to $f, hopefully avoiding passing that argument in some cases.
* module/language/cps/compile-bytecode.scm (compile-function): Pass the
  has-closure? bit on through to the assembler.
* module/system/vm/assembler.scm (begin-standard-arity)
  (begin-opt-arity, begin-kw-arity): Only reserve space for the closure
  as appropriate.
* module/language/cps/slot-allocation.scm (allocate-args)
  (compute-defs-and-uses, compute-needs-slot)
  (compute-var-representations): Allow for closure slot allocation
  differences.
* module/language/cps/cse.scm (compute-defs):
* module/language/cps/dce.scm (compute-live-code):
* module/language/cps/renumber.scm (renumber, compute-renaming):
(allocate-args):
* module/language/cps/specialize-numbers.scm (compute-significant-bits):
(compute-defs):
* module/language/cps/split-rec.scm (compute-free-vars):
* module/language/cps/types.scm (infer-types):
* module/language/cps/utils.scm (compute-max-label-and-var):
* module/language/cps/verify.scm (check-distinct-vars):
(compute-available-definitions): Allow closure to be #f.

module/language/cps/closure-conversion.scm

@@ -1,6 +1,6 @@
 ;;; Continuation-passing style (CPS) intermediate language (IL)
 
-;; Copyright (C) 2013, 2014, 2015, 2017, 2018 Free Software Foundation, Inc.
+;; Copyright (C) 2013-2019 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
@@ -26,6 +26,10 @@
 ;;; contification did not handle.  See (language cps) for a further
 ;;; discussion of $rec.
 ;;;
+;;; Before closure conversion, function self variables are always bound.
+;;; After closure conversion, well-known functions with no free
+;;; variables may have no self reference.
+;;;
 ;;; Code:
 
 (define-module (language cps closure-conversion)
@@ -451,7 +455,50 @@ variable, until we reach a fixed point on the free-vars map."
 (define (intset-count set)
   (intset-fold (lambda (_ count) (1+ count)) set 0))
 
-(define (convert-one cps label body free-vars bound->label well-known shared)
+(define (compute-elidable-closures cps well-known shared free-vars)
+  "Compute the set of well-known callees with no free variables.  Calls
+to these functions can avoid passing a closure parameter.  Note however
+that we have to exclude well-known callees that are part of a shared
+closure that contains any not-well-known member."
+  (define (intset-map f set)
+    (persistent-intset
+     (intset-fold (lambda (i out) (if (f i) (intset-add! out i) out))
+                  set
+                  empty-intset)))
+
+  (let ((no-free-vars (persistent-intset
+                       (intmap-fold (lambda (label free out)
+                                      (if (eq? empty-intset free)
+                                          (intset-add! out label)
+                                          out))
+                                    free-vars empty-intset)))
+        (shared
+         (intmap-fold
+          (lambda (label cont out)
+            (match cont
+              (($ $kargs _ _
+                  ($ $continue _ _ ($ $rec _ _ (($ $fun kfuns) ...))))
+               ;; Either all of these functions share a closure, in
+               ;; which all or all except one of them are well-known, or
+               ;; none of the functions share a closure.
+               (if (intmap-ref shared (car kfuns) (lambda (_) #f))
+                   (let* ((scc (fold intset-cons empty-intset kfuns)))
+                     (intset-fold (lambda (label out)
+                                    (intmap-add out label scc))
+                                  scc out))
+                   out))
+              (_ out)))
+          cps
+          empty-intmap)))
+    (intmap-fold (lambda (label labels elidable)
+                   (if (eq? labels (intset-intersect labels well-known))
+                       elidable
+                       (intset-subtract elidable labels)))
+                 shared
+                 (intset-intersect well-known no-free-vars))))
+
+(define (convert-one cps label body free-vars bound->label well-known shared
+                     elidable)
   (define (well-known? label)
     (intset-ref well-known label))
 
@@ -650,11 +697,14 @@ bound to @var{var}, and continue to @var{k}."
                 ($continue k src ($callk label closure args)))))))
       (cond
        ((eq? (intmap-ref free-vars label) empty-intset)
-        ;; Known call, no free variables; no closure needed.
+        ;; Known call, no free variables; no closure needed.  If the
-        ;; Pass #f as closure argument.
+        ;; callee is well-known, elide the closure argument entirely.
-        (with-cps cps
+        ;; Otherwise pass #f.
-          ($ (with-cps-constants ((false #f))
+        (if (and (intset-ref elidable label) #f) ; Disabled temporarily.
-               ($ (have-closure false))))))
+            (have-closure cps #f)
+            (with-cps cps
+              ($ (with-cps-constants ((false #f))
+                   ($ (have-closure false)))))))
        ((and (well-known? (closure-label label shared bound->label))
              (trivial-intset (intmap-ref free-vars label)))
         ;; Well-known closures with one free variable are
@@ -796,6 +846,11 @@ bound to @var{var}, and continue to @var{k}."
                       (with-cps cps
                         (let$ term (visit-term term))
                         (setk label ($kargs names vars ,term))))
+                     (($ $kfun src meta self ktail kclause)
+                      (if (and (intset-ref elidable label) #f)
+                          (with-cps cps
+                            (setk label ($kfun src meta #f ktail kclause)))
+                          cps))
                      (_ cps)))
                  body
                  cps)))
@@ -819,7 +874,9 @@ and allocate and initialize flat closures."
                                             kfun))
          ;; label -> free-var...
          (free-vars (compute-free-vars cps kfun shared))
-         (free-vars (prune-free-vars free-vars bound->label well-known shared)))
+         (free-vars (prune-free-vars free-vars bound->label well-known shared))
+         ;; label...
+         (elidable (compute-elidable-closures cps well-known shared free-vars)))
     (let ((free-in-program (intmap-ref free-vars kfun)))
       (unless (eq? empty-intset free-in-program)
         (error "Expected no free vars in program" free-in-program)))
@@ -827,7 +884,8 @@ and allocate and initialize flat closures."
       (persistent-intmap
        (intmap-fold
         (lambda (label body cps)
-          (convert-one cps label body free-vars bound->label well-known shared))
+          (convert-one cps label body free-vars bound->label well-known shared
+                       elidable))
         functions
         cps)))))
 

module/language/cps/compile-bytecode.scm

@@ -1,6 +1,6 @@
 ;;; Continuation-passing style (CPS) intermediate language (IL)
 
-;; Copyright (C) 2013, 2014, 2015, 2017, 2018 Free Software Foundation, Inc.
+;; Copyright (C) 2013-2019 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
@@ -624,6 +624,8 @@
          (let ((first? (match (intmap-ref cps (1- label))
                          (($ $kfun) #t)
                          (_ #f)))
+               (has-closure? (match (intmap-ref cps (intmap-next cps))
+                               (($ $kfun src meta self tail) (->bool self))))
                (kw-indices (map (match-lambda
                                  ((key name sym)
                                   (cons key (lookup-slot sym allocation))))
@@ -631,10 +633,11 @@
            (unless first?
              (emit-end-arity asm))
            (emit-label asm label)
-           (emit-begin-kw-arity asm req opt rest kw-indices allow-other-keys?
+           (emit-begin-kw-arity asm has-closure? req opt rest kw-indices
-                                frame-size alt)
+                                allow-other-keys? frame-size alt)
-           ;; All arities define a closure binding in slot 0.
+           (when has-closure?
-           (emit-definition asm 'closure 0 'scm)
+             ;; Most arities define a closure binding in slot 0.
+             (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)))

module/language/cps/cse.scm

@@ -152,7 +152,7 @@ false.  It could be that both true and false proofs are available."
   (intset-map (lambda (label)
                 (match (intmap-ref conts label)
                   (($ $kfun src meta self tail clause)
-                   (list self))
+                   (if self (list self) '()))
                   (($ $kclause arity body alt)
                    (match (intmap-ref conts body)
                      (($ $kargs names vars) vars)))

module/language/cps/dce.scm

@@ -1,6 +1,6 @@
 ;;; Continuation-passing style (CPS) intermediate language (IL)
 
-;; Copyright (C) 2013, 2014, 2015, 2017, 2018 Free Software Foundation, Inc.
+;; Copyright (C) 2013-2019 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
@@ -251,7 +251,8 @@ sites."
            (($ $kclause arity kargs kalt)
             (values live-labels (adjoin-vars (cont-defs kargs) live-vars)))
            (($ $kfun src meta self)
-            (values live-labels (adjoin-var self live-vars)))
+            (values live-labels
+                    (if self (adjoin-var self live-vars) live-vars)))
            (($ $ktail)
             (values live-labels live-vars))))
        conts label live-labels live-vars))

module/language/cps/renumber.scm

@@ -1,6 +1,6 @@
 ;;; Continuation-passing style (CPS) intermediate language (IL)
 
-;; Copyright (C) 2013, 2014, 2015, 2017, 2018 Free Software Foundation, Inc.
+;; Copyright (C) 2013-2019 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
@@ -127,7 +127,7 @@
             (match (intmap-ref conts label)
               (($ $kargs names syms exp)
                (fold1 rename-var syms vars))
-              (($ $kfun src meta self tail clause)
+              (($ $kfun src meta (and self (not #f)) tail clause)
                (rename-var self vars))
               (_ vars))))
   (define (maybe-visit-fun kfun labels vars)
@@ -220,7 +220,7 @@
            (($ $ktail)
             ($ktail))
            (($ $kfun src meta self tail clause)
-            ($kfun src meta (rename-var self) (rename-label tail)
+            ($kfun src meta (and self (rename-var self)) (rename-label tail)
               (and clause (rename-label clause))))
            (($ $kclause arity body alternate)
             ($kclause ,(rename-arity arity) (rename-label body)

module/language/cps/slot-allocation.scm

@@ -1,6 +1,6 @@
 ;; Continuation-passing style (CPS) intermediate language (IL)
 
-;; Copyright (C) 2013, 2014, 2015, 2017, 2018 Free Software Foundation, Inc.
+;; Copyright (C) 2013-2019 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
@@ -143,7 +143,7 @@ by a label, respectively."
                 (intmap-add! uses label u)))
       (match cont
         (($ $kfun src meta self)
-         (return (intset self) empty-intset))
+         (return (if self (intset self) empty-intset) empty-intset))
         (($ $kargs _ _ ($ $continue k src exp))
          (match exp
            ((or ($ $const) ($ $const-fun) ($ $code))
@@ -324,7 +324,7 @@ the definitions that are live before and after LABEL, as intsets."
         (($ $kclause arity body alternate)
          (get-defs label))
         (($ $kfun src meta self)
-         (intset self))
+         (if self (intset self) empty-intset))
         (($ $ktail)
          empty-intset))))
    cps
@@ -640,22 +640,27 @@ are comparable with eqv?.  A tmp slot may be used."
   (intmap-fold measure-cont cps minimum-frame-size))
 
 (define (allocate-args cps)
-  (intmap-fold (lambda (label cont slots)
+  (match (intmap-ref cps (intmap-next cps))
-                 (match cont
+    (($ $kfun _ _ has-self?)
-                   (($ $kfun src meta self)
+     (intmap-fold (lambda (label cont slots)
-                    (intmap-add! slots self 0))
+                    (match cont
-                   (($ $kclause arity body alt)
+                      (($ $kfun src meta self)
-                    (match (intmap-ref cps body)
+                       (if has-self?
-                      (($ $kargs names vars)
+                           (intmap-add! slots self 0)
-                       (let lp ((vars vars) (slots slots) (n 1))
+                           slots))
-                         (match vars
+                      (($ $kclause arity body alt)
-                           (() slots)
+                       (match (intmap-ref cps body)
-                           ((var . vars)
+                         (($ $kargs names vars)
-                            (lp vars
+                          (let lp ((vars vars) (slots slots)
-                                (intmap-add! slots var n)
+                                   (n (if has-self? 1 0)))
-                                (1+ n))))))))
+                            (match vars
-                   (_ slots)))
+                              (() slots)
-               cps empty-intmap))
+                              ((var . vars)
+                               (lp vars
+                                   (intmap-add! slots var n)
+                                   (1+ n))))))))
+                      (_ slots)))
+                  cps empty-intmap))))
 
 (define-inlinable (add-live-slot slot live-slots)
   (logior live-slots (ash 1 slot)))
@@ -784,7 +789,9 @@ are comparable with eqv?.  A tmp slot may be used."
        (($ $kargs _ _ (or ($ $branch) ($ $prompt) ($ $throw)))
         representations)
        (($ $kfun src meta self)
-        (intmap-add representations self 'scm))
+        (if self
+            (intmap-add representations self 'scm)
+            representations))
        (($ $kclause arity body alt)
         (fold1 (lambda (var representations)
                  (intmap-add representations var 'scm))

module/language/cps/specialize-numbers.scm

@@ -1,6 +1,6 @@
 ;;; Continuation-passing style (CPS) intermediate language (IL)
 
-;; Copyright (C) 2015, 2016, 2017, 2018 Free Software Foundation, Inc.
+;; Copyright (C) 2015, 2016, 2017, 2018, 2019 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
@@ -305,7 +305,7 @@ BITS indicating the significant bits needed for a variable.  BITS may be
            (continue
             (match (intmap-ref cps label)
               (($ $kfun src meta self)
-               (add-def out self))
+               (if self (add-def out self) out))
               (($ $kargs names vars term)
                (let ((out (add-defs out vars)))
                  (match term
@@ -670,7 +670,7 @@ BITS indicating the significant bits needed for a variable.  BITS may be
    (lambda (label defs)
      (match (intmap-ref conts label)
        (($ $kfun src meta self tail clause)
-        (intmap-add defs self label))
+        (if self (intmap-add defs self label) defs))
        (($ $kargs names vars)
         (fold1 (lambda (var defs)
                  (intmap-add defs var label))

module/language/cps/split-rec.scm

@@ -1,6 +1,6 @@
 ;;; Continuation-passing style (CPS) intermediate language (IL)
 
-;; Copyright (C) 2013, 2014, 2015, 2017, 2018 Free Software Foundation, Inc.
+;; Copyright (C) 2013-2019 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
@@ -97,7 +97,7 @@ references."
                       (add-use tag uses))
                      (($ $throw src op param args)
                       (add-uses args uses)))))
-                 (($ $kfun src meta self)
+                 (($ $kfun src meta (and self (not #f)))
                   (values (add-def self defs) uses))
                  (_ (values defs uses))))
              body empty-intset empty-intset))

module/language/cps/types.scm

@@ -1,5 +1,5 @@
 ;;; Type analysis on CPS
-;;; Copyright (C) 2014-2015,2017-2018 Free Software Foundation, Inc.
+;;; Copyright (C) 2014-2019 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
@@ -1935,7 +1935,9 @@ 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 (adjoin-var types self all-types-entry))
+             (propagate1 clause (if self
+                                    (adjoin-var types self all-types-entry)
+                                    types))
              (propagate0)))
         (($ $kclause arity kbody kalt)
          (match (intmap-ref conts kbody)

module/language/cps/utils.scm

@@ -92,7 +92,7 @@
                          (match cont
                            (($ $kargs names syms body)
                             (apply max max-var syms))
-                           (($ $kfun src meta self)
+                           (($ $kfun src meta (and self (not #f)))
                             (max max-var self))
                            (_ max-var)))
                        conts

module/language/cps/verify.scm

@@ -1,5 +1,5 @@
 ;;; Diagnostic checker for CPS
-;;; Copyright (C) 2014, 2015, 2017, 2018 Free Software Foundation, Inc.
+;;; Copyright (C) 2014-2019 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
@@ -64,7 +64,7 @@
      (match (intmap-ref conts label)
        (($ $kargs names vars term)
         (fold1 adjoin-def vars seen))
-       (($ $kfun src meta self tail clause)
+       (($ $kfun src meta (and self (not #f)) tail clause)
         (adjoin-def self seen))
        (_ seen))
      )
@@ -113,7 +113,7 @@ definitions that are available at LABEL."
         (($ $kreceive arity k)
          (propagate1 k in))
         (($ $kfun src meta self tail clause)
-         (let ((out (adjoin-def self in)))
+         (let ((out (if self (adjoin-def self in) in)))
            (if clause
                (propagate1 clause out)
                (propagate0 out))))

module/system/vm/assembler.scm

@@ -1412,13 +1412,15 @@ returned instead."
                  (meta-jit-data-label meta)
                  (asm-constants asm)))))
 
-(define-macro-assembler (begin-standard-arity asm req nlocals alternate)
+(define-macro-assembler (begin-standard-arity asm has-closure? req nlocals
-  (emit-begin-opt-arity asm req '() #f nlocals alternate))
+                                              alternate)
+  (emit-begin-opt-arity asm has-closure? req '() #f nlocals alternate))
 
-(define-macro-assembler (begin-opt-arity asm req opt rest nlocals alternate)
+(define-macro-assembler (begin-opt-arity asm has-closure? req opt rest nlocals
-  (emit-begin-kw-arity asm req opt rest '() #f nlocals alternate))
+                                         alternate)
+  (emit-begin-kw-arity asm has-closure? req opt rest '() #f nlocals alternate))
 
-(define-macro-assembler (begin-kw-arity asm req opt rest kw-indices
+(define-macro-assembler (begin-kw-arity asm has-closure? req opt rest kw-indices
                                         allow-other-keys? nlocals alternate)
   (assert-match req ((? symbol?) ...) "list of symbols")
   (assert-match opt ((? symbol?) ...) "list of symbols")
@@ -1439,7 +1441,8 @@ returned instead."
          ;; The procedure itself is in slot 0, in the standard calling
          ;; convention.  For procedure prologues, nreq includes the
          ;; procedure, so here we add 1.
-         (nreq (1+ (length req)))
+         (nclosure (if has-closure? 1 0))
+         (nreq (+ nclosure (length req)))
          (nopt (length opt))
          (rest? (->bool rest)))
     (set-meta-arities! meta (cons arity (meta-arities meta)))