mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 03:40:34 +02:00
* module/language/cps.scm ($calli): New expression type which calls a function entry as originally captured via $code. Adapt all callers.
185 lines
7.7 KiB
Scheme
185 lines
7.7 KiB
Scheme
;;; Continuation-passing style (CPS) intermediate language (IL)
|
|
|
|
;; 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
|
|
;;;; 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)))
|
|
(($ $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)
|
|
(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)))))
|