FM / cps

/usr/share/guile/3.0/language/cps

Name	Size	Mode	Actions
closure-conversion.scm	38159	0644	edit dl rm
compile-bytecode.scm	32866	0644	edit dl rm
contification.scm	23824	0644	edit dl rm
cse.scm	33392	0644	edit dl rm
dce.scm	18456	0644	edit dl rm
devirtualize-integers.scm	11605	0644	edit dl rm
effects-analysis.scm	25138	0644	edit dl rm
elide-arity-checks.scm	4520	0644	edit dl rm
graphs.scm	10401	0644	edit dl rm
intmap.scm	29027	0644	edit dl rm
intset.scm	30298	0644	edit dl rm
licm.scm	15049	0644	edit dl rm
loop-instrumentation.scm	2613	0644	edit dl rm
optimize.scm	5730	0644	edit dl rm
peel-loops.scm	14868	0644	edit dl rm
prune-top-level-scopes.scm	2121	0644	edit dl rm
reify-primitives.scm	25205	0644	edit dl rm
renumber.scm	10457	0644	edit dl rm
rotate-loops.scm	10686	0644	edit dl rm
self-references.scm	3130	0644	edit dl rm
simplify.scm	10773	0644	edit dl rm
slot-allocation.scm	41846	0644	edit dl rm
spec.scm	1875	0644	edit dl rm
specialize-numbers.scm	44495	0644	edit dl rm
specialize-primcalls.scm	6871	0644	edit dl rm
split-rec.scm	7739	0644	edit dl rm
switch.scm	18438	0644	edit dl rm
type-checks.scm	3146	0644	edit dl rm
type-fold.scm	29158	0644	edit dl rm
types.scm	82504	0644	edit dl rm
utils.scm	14004	0644	edit dl rm
verify.scm	12703	0644	edit dl rm
with-cps.scm	5856	0644	edit dl rm

Edit: /usr/share/guile/3.0/language/cps/devirtualize-integers.scm (11605B)

;;; Continuation-passing style (CPS) intermediate language (IL)

;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

;;; Commentary:
;;;
;;; Some parts of programs operate on exact integers.  An exact integer
;;; is either a fixnum or a bignum.  It's often the case that if we know
;;; that a number is a fixnum, all operations on it can be unboxed in
;;; terms of s64 operations.  But if there's a series of operations and
;;; each one works on either bignums or fixnums, then the mixing of
;;; fixnums and bignums through that one control and data flow path
;;; makes it impossible for the compiler to specialize operations to
;;; either type.
;;;
;;; This "integer devirtualization" pass tries to duplicate the control
;;; and data flow of exact integers into two flows: one for bignums and
;;; one for fixnums.  This causes code growth, so it's something we need
;;; to be careful about.
;;;
;;; Code:

(define-module (language cps devirtualize-integers)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (language cps)
  #:use-module (language cps effects-analysis)
  #:use-module (language cps intmap)
  #:use-module (language cps intset)
  #:use-module (language cps utils)
  #:use-module (language cps with-cps)
  #:export (devirtualize-integers))

;; Compute a map from VAR -> COUNT, where COUNT indicates the number of
;; times in the source program that VAR is used.
(define (compute-use-counts cps)
  (define (add-use use-counts var)
    (let ((count (1+ (intmap-ref use-counts var (lambda (_) 0)))))
      (intmap-add! use-counts var count (lambda (old new) new))))
  (define (add-uses use-counts vars)
    (match vars
      (() use-counts)
      ((var . vars) (add-uses (add-use use-counts var) vars))))
  (persistent-intmap
   (intmap-fold
    (lambda (label cont use-counts)
      (match cont
        (($ $kargs names vars term)
         (match term
           (($ $continue k src exp)
            (match exp
              ((or ($ $const) ($ $prim) ($ $fun) ($ $const-fun) ($ $code) ($ $rec))
               use-counts)
              (($ $values args)
               (add-uses use-counts args))
              (($ $call proc args)
               (add-uses (add-use use-counts proc) args))
              (($ $callk kfun proc args)
               (add-uses (if proc (add-use use-counts proc) use-counts) args))
              (($ $primcall name param args)
               (add-uses use-counts args))))
           (($ $branch kf kt src op param args)
            (add-uses use-counts args))
           (($ $switch kf kt* src arg)
            (add-use use-counts arg))
           (($ $prompt k kh src escape? tag)
            (add-use use-counts tag))
           (($ $throw src op param args)
            (add-uses use-counts args))))
        (_ use-counts)))
    cps
    (transient-intmap))))

(define (bailout? cps label)
  (match (intmap-ref cps label)
    (($ $kargs _ _ ($ $throw)) #t)
    (_ #f)))

(define (peel-trace cps label fx kexit use-counts)
  "For the graph starting at LABEL, try to peel out a trace that uses
the variable FX.  A peelable trace consists of effect-free terms, or
terms that only have &type-check effect but which use FX or some
variable that was defined using FX as an input.  No variable defined in
the trace should be referenced outside of it."
  (let peel-cont ((cps cps) (label label)
                  (live-vars empty-intmap) ;; var -> pending refcount
                  (fresh-vars empty-intmap) ;; old-name -> new name
                  (vars-of-interest (intset-add empty-intset fx))
                  (defs-of-interest? #f))
    (define (fail) (with-cps cps #f))
    (define (add-live-vars live-vars vars)
      (match vars
        (() live-vars)
        ((var . vars)
         (add-live-vars
          (let ((count (intmap-ref use-counts var (lambda (_) 0))))
            (if (zero? count)
                live-vars
                (intmap-add live-vars var count)))
          vars))))
    (define (subtract-uses live-vars vars)
      (match vars
        (() live-vars)
        ((var . vars)
         (subtract-uses
          (let ((count (intmap-ref live-vars var (lambda (_) #f))))
            (cond
             ((not count) live-vars)
             ((= count 1) (intmap-remove live-vars var))
             (else (intmap-replace live-vars var (1- count)))))
          vars))))
    (match (intmap-ref cps label)
      ;; We know the initial label is a $kargs, and we won't follow the
      ;; graph to get to $kreceive etc, so we can stop with these two
      ;; continuation kinds.  (For our purposes, only $values can
      ;; continue to $ktail.)
      (($ $ktail) (fail))
      (($ $kargs names vars term)
       (let* ((vars-of-interest
               (if defs-of-interest?
                   (fold1 (lambda (var set) (intset-add set var))
                          vars vars-of-interest)
                   vars-of-interest))
              (live-vars (add-live-vars live-vars vars))
              (fresh-vars (fold (lambda (var fresh-vars)
                                  (intmap-add fresh-vars var (fresh-var)))
                                fresh-vars vars))
              (peeled-vars (map (lambda (var) (intmap-ref fresh-vars var))
                                vars)))
         (define (rename-uses args)
           (map (lambda (arg) (intmap-ref fresh-vars arg (lambda (arg) arg)))
                args))
         (define (any-use-of-interest? args)
           (or-map (lambda (arg) (intset-ref vars-of-interest arg))
                   args))
         (define (continue k live-vars defs-of-interest? can-terminate-trace?
                           make-term)
           (define (stitch cps k)
             (with-cps cps
               (letk label* ($kargs names peeled-vars ,(make-term k)))
               label*))
           (define (terminate)
             (stitch cps k))
           (with-cps cps
             (let$ k* (peel-cont k live-vars fresh-vars vars-of-interest
                                 defs-of-interest?))
             ($ ((lambda (cps)
                   (cond
                    (k* (stitch cps k*))
                    ((and can-terminate-trace? (eq? live-vars empty-intmap))
                     (terminate))
                    (else (fail))))))))
         (match term
           (($ $branch kf kt src op param args)
            ;; kt or k is kf; var of interest is in args
            (let* ((live-vars (subtract-uses live-vars args))
                   (uses-of-interest? (any-use-of-interest? args))
                   (defs-of-interest? #f) ;; Branches don't define values.
                   (can-terminate-trace? uses-of-interest?)
                   (peeled-args (rename-uses args)))
              (cond
               ((not uses-of-interest?)
                (fail))
               ((bailout? cps kt)
                (continue kf live-vars defs-of-interest? can-terminate-trace?
                          (lambda (kf)
                            (build-term
                              ($branch kf kt src op param peeled-args)))))
               ((bailout? cps kf)
                (continue kt live-vars defs-of-interest? can-terminate-trace?
                          (lambda (kt)
                            (build-term
                              ($branch kf kt src op param peeled-args)))))
               ((eq? live-vars empty-intmap)
                (with-cps cps
                  (letk label*
                        ($kargs names peeled-vars
                          ($branch kf kt src op param peeled-args)))
                  label*))
               (else
                (fail)))))
           (($ $switch)
            ;; Don't know how to peel past a switch.  The arg of a
            ;; switch is unboxed anyway.
            (fail))
           (($ $continue k src exp)
            (match exp
              (($ $const)
               ;; fine.
               (continue k live-vars #f #f
                         (lambda (k)
                           (build-term ($continue k src ,exp)))))
              (($ $values args)
               (let ((uses-of-interest? (any-use-of-interest? args))
                     (live-vars (subtract-uses live-vars args))
                     (peeled-args (rename-uses args)))
                 (continue k live-vars
                           uses-of-interest? #f
                           (lambda (k)
                             (build-term
                               ($continue k src ($values peeled-args)))))))
              (($ $primcall name param args)
               ;; exp is effect-free or var of interest in args
               (let* ((fx (expression-effects exp))
                      (uses-of-interest? (any-use-of-interest? args))
                      (live-vars (subtract-uses live-vars args))
                      (peeled-args (rename-uses args)))
                 ;; If the primcall uses a value of interest,
                 ;; consider it for peeling even if it would cause a
                 ;; type check; perhaps the peeling causes the type
                 ;; check to go away.
                 (if (or (eqv? fx &no-effects)
                         (and uses-of-interest? (eqv? fx &type-check)))
                     (continue k live-vars
                               ;; Primcalls that use values of interest
                               ;; define values of interest.
                               uses-of-interest? #t
                               (lambda (k)
                                 (build-term
                                   ($continue k src
                                     ($primcall name param ,peeled-args)))))
                     (fail))))
              (_ (fail))))))))))

(define (peel-traces-in-function cps body use-counts)
  (intset-fold
   (lambda (label cps)
     (match (intmap-ref cps label)
       ;; Traces start with a fixnum? predicate.  We could expand this
       ;; in the future if we wanted to.
       (($ $kargs names vars ($ $branch kf kt src 'fixnum? #f (x)))
        (if (and (bailout? cps kf) #f)
            ;; Don't peel traces whose alternate is just a bailout.
            cps
            (with-cps cps
              (let$ kt (peel-trace kt x kf use-counts))
              ($ ((lambda (cps)
                    (if kt
                        (with-cps cps
                          (setk label
                                ($kargs names vars
                                  ($branch kf kt src 'fixnum? #f (x)))))
                        cps)))))))
       (_ cps)))
   body
   cps))

(define (devirtualize-integers cps)
  (let ((use-counts (compute-use-counts cps)))
    (with-fresh-name-state cps
      (intmap-fold
       (lambda (kfun body cps)
         (peel-traces-in-function cps body use-counts))
       (compute-reachable-functions cps)
       cps))))

cmd: