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/split-rec.scm (7739B)

;;; 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:
;;;
;;; Split functions bound in $rec expressions into strongly-connected
;;; components.  The result will be that each $rec binds a
;;; strongly-connected component of mutually recursive functions.
;;;
;;; Code:

(define-module (language cps split-rec)
  #:use-module (ice-9 match)
  #:use-module ((srfi srfi-1) #:select (fold))
  #:use-module (language cps)
  #:use-module (language cps utils)
  #:use-module (language cps with-cps)
  #:use-module (language cps intmap)
  #:use-module (language cps intset)
  #:export (split-rec))

(define (compute-free-vars conts kfun)
  "Compute a FUN-LABEL->FREE-VAR... map describing all free variable
references."
  (define (add-def var defs) (intset-add! defs var))
  (define (add-defs vars defs)
    (match vars
      (() defs)
      ((var . vars) (add-defs vars (add-def var defs)))))
  (define (add-use var uses) (intset-add! uses var))
  (define (add-uses vars uses)
    (match vars
      (() uses)
      ((var . vars) (add-uses vars (add-use var uses)))))
  (define (visit-nested-funs body)
    (intset-fold
     (lambda (label out)
       (match (intmap-ref conts label)
         (($ $kargs _ _ ($ $continue _ _
                           ($ $fun kfun)))
          (intmap-union out (visit-fun kfun)))
         (($ $kargs _ _ ($ $continue _ _
                           ($ $rec _ _ (($ $fun kfun) ...))))
          (fold (lambda (kfun out)
                  (intmap-union out (visit-fun kfun)))
                out kfun))
         (_ out)))
     body
     empty-intmap))
  (define (visit-fun kfun)
    (let* ((body (compute-function-body conts kfun))
           (free (visit-nested-funs body)))
      (call-with-values
          (lambda ()
            (intset-fold
             (lambda (label defs uses)
               (match (intmap-ref conts label)
                 (($ $kargs names vars term)
                  (values
                   (add-defs vars defs)
                   (match term
                     (($ $continue k src exp)
                      (match exp
                        ((or ($ $const) ($ $prim)) uses)
                        (($ $fun kfun)
                         (intset-union (persistent-intset uses)
                                       (intmap-ref free kfun)))
                        (($ $rec names vars (($ $fun kfun) ...))
                         (fold (lambda (kfun uses)
                                 (intset-union (persistent-intset uses)
                                               (intmap-ref free kfun)))
                               uses kfun))
                        (($ $values args)
                         (add-uses args uses))
                        (($ $call proc args)
                         (add-use proc (add-uses args uses)))
                        (($ $callk k proc args)
                         (let ((uses (add-uses args uses)))
                           (if proc
                               (add-use proc uses)
                               uses)))
                        (($ $primcall name param args)
                         (add-uses args uses))))
                     (($ $branch kf kt src op param args)
                      (add-uses args uses))
                     (($ $switch kf kt* src arg)
                      (add-use arg uses))
                     (($ $prompt k kh src escape? tag)
                      (add-use tag uses))
                     (($ $throw src op param args)
                      (add-uses args uses)))))
                 (($ $kfun src meta (and self (not #f)))
                  (values (add-def self defs) uses))
                 (_ (values defs uses))))
             body empty-intset empty-intset))
        (lambda (defs uses)
          (intmap-add free kfun (intset-subtract
                                 (persistent-intset uses)
                                 (persistent-intset defs)))))))
  (visit-fun kfun))

(define (compute-split fns free-vars)
  (define (get-free kfun)
    ;; It's possible for a fun to have been skipped by
    ;; compute-free-vars, if the fun isn't reachable.  Fall back to
    ;; empty-intset for the fun's free vars, in that case.
    (intmap-ref free-vars kfun (lambda (_) empty-intset)))
  (let* ((vars (intmap-keys fns))
         (edges (intmap-map
                 (lambda (var kfun)
                   (intset-intersect (get-free kfun) vars))
                 fns)))
    (compute-sorted-strongly-connected-components edges)))

(define (intmap-acons k v map)
  (intmap-add map k v))

(define (split-rec conts)
  (let ((free (compute-free-vars conts 0)))
    (with-fresh-name-state conts
      (persistent-intmap
       (intmap-fold
        (lambda (label cont out)
          (match cont
            (($ $kargs cont-names cont-vars
                ($ $continue k src ($ $rec names vars (($ $fun kfuns) ...))))
             (let ((fns (fold intmap-acons empty-intmap vars kfuns))
                   (fn-names (fold intmap-acons empty-intmap vars names)))
               (match (compute-split fns free)
                 (()
                  ;; Remove trivial $rec.
                  (with-cps out
                    (setk label ($kargs cont-names cont-vars
                                  ($continue k src ($values ()))))))
                 ((_)
                  ;; Bound functions already form a strongly-connected
                  ;; component.
                  out)
                 (components
                  ;; Multiple components.  Split them into separate $rec
                  ;; expressions.
                  (define (build-body out components)
                    (match components
                      (()
                       (match (intmap-ref out k)
                         (($ $kargs names vars term)
                          (with-cps (intmap-remove out k)
                            term))))
                      ((vars . components)
                       (match (intset-fold
                               (lambda (var out)
                                 (let ((name (intmap-ref fn-names var))
                                       (fun (build-exp
                                              ($fun (intmap-ref fns var)))))
                                   (cons (list name var fun) out)))
                               vars '())
                         (((name var fun) ...)
                          (with-cps out
                            (let$ body (build-body components))
                            (letk kbody ($kargs name var ,body))
                            (build-term
                              ($continue kbody src ($rec name var fun)))))))))
                  (with-cps out
                    (let$ body (build-body components))
                    (setk label ($kargs cont-names cont-vars ,body)))))))
             (_ out)))
          conts
          conts)))))

cmd: