1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-28 16:00:22 +02:00
guile/module/language/cps2/utils.scm
Andy Wingo cb7aa0b3b1 Add two-argument fixpoint arity
* module/language/cps2/utils.scm (fixpoint): Add two-argument arity.
2015-05-20 19:18:45 +02:00

239 lines
8.3 KiB
Scheme

;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014, 2015 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:
;;;
;;; Helper facilities for working with CPS.
;;;
;;; Code:
(define-module (language cps2 utils)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (language cps2)
#:use-module (language cps intset)
#:use-module (language cps intmap)
#:export (;; Fresh names.
label-counter var-counter
fresh-label fresh-var
with-fresh-name-state compute-max-label-and-var
let-fresh
;; Various utilities.
fold1 fold2
intset->intmap
worklist-fold worklist-fold2
fixpoint
;; Flow analysis.
compute-predecessors
compute-function-body
compute-idoms
compute-dom-edges
))
(define label-counter (make-parameter #f))
(define var-counter (make-parameter #f))
(define (fresh-label)
(let ((count (or (label-counter)
(error "fresh-label outside with-fresh-name-state"))))
(label-counter (1+ count))
count))
(define (fresh-var)
(let ((count (or (var-counter)
(error "fresh-var outside with-fresh-name-state"))))
(var-counter (1+ count))
count))
(define-syntax-rule (let-fresh (label ...) (var ...) body ...)
(let* ((label (fresh-label)) ...
(var (fresh-var)) ...)
body ...))
(define-syntax-rule (with-fresh-name-state fun body ...)
(call-with-values (lambda () (compute-max-label-and-var fun))
(lambda (max-label max-var)
(parameterize ((label-counter (1+ max-label))
(var-counter (1+ max-var)))
body ...))))
(define (compute-max-label-and-var conts)
(values (or (intmap-prev conts) -1)
(intmap-fold (lambda (k cont max-var)
(match cont
(($ $kargs names syms body)
(apply max max-var syms))
(($ $kfun src meta self)
(max max-var self))
(_ max-var)))
conts
-1)))
(define-inlinable (fold1 f l s0)
(let lp ((l l) (s0 s0))
(match l
(() s0)
((elt . l) (lp l (f elt s0))))))
(define-inlinable (fold2 f l s0 s1)
(let lp ((l l) (s0 s0) (s1 s1))
(match l
(() (values s0 s1))
((elt . l)
(call-with-values (lambda () (f elt s0 s1))
(lambda (s0 s1)
(lp l s0 s1)))))))
(define (intset->intmap f set)
(persistent-intmap
(intset-fold (lambda (label preds)
(intmap-add! preds label (f label)))
set empty-intmap)))
(define (worklist-fold f in out)
(if (eq? in empty-intset)
out
(call-with-values (lambda () (f in out))
(lambda (in out)
(worklist-fold f in out)))))
(define (worklist-fold2 f in out0 out1)
(if (eq? in empty-intset)
(values out0 out1)
(call-with-values (lambda () (f in out0 out1))
(lambda (in out0 out1)
(worklist-fold2 f in out0 out1)))))
(define fixpoint
(case-lambda
((f x)
(let lp ((x x))
(let ((x* (f x)))
(if (eq? x x*) x* (lp x*)))))
((f x0 x1)
(let lp ((x0 x0) (x1 x1))
(call-with-values (lambda () (f x0 x1))
(lambda (x0* x1*)
(if (and (eq? x0 x0*) (eq? x1 x1*))
(values x0* x1*)
(lp x0* x1*))))))))
(define (compute-function-body conts kfun)
(persistent-intset
(let visit-cont ((label kfun) (labels empty-intset))
(cond
((intset-ref labels label) labels)
(else
(let ((labels (intset-add! labels label)))
(match (intmap-ref conts label)
(($ $kreceive arity k) (visit-cont k labels))
(($ $kfun src meta self ktail kclause)
(let ((labels (visit-cont ktail labels)))
(if kclause
(visit-cont kclause labels)
labels)))
(($ $ktail) labels)
(($ $kclause arity kbody kalt)
(if kalt
(visit-cont kalt (visit-cont kbody labels))
(visit-cont kbody labels)))
(($ $kargs names syms ($ $continue k src exp))
(visit-cont k (match exp
(($ $branch k)
(visit-cont k labels))
(($ $callk k)
(visit-cont k labels))
(($ $prompt escape? tag k)
(visit-cont k labels))
(_ labels)))))))))))
(define* (compute-predecessors conts kfun #:key
(labels (compute-function-body conts kfun)))
(define (meet cdr car)
(cons car cdr))
(define (add-preds label preds)
(define (add-pred k preds)
(intmap-add! preds k label meet))
(match (intmap-ref conts label)
(($ $kreceive arity k)
(add-pred k preds))
(($ $kfun src meta self ktail kclause)
(add-pred ktail (if kclause (add-pred kclause preds) preds)))
(($ $ktail)
preds)
(($ $kclause arity kbody kalt)
(add-pred kbody (if kalt (add-pred kalt preds) preds)))
(($ $kargs names syms ($ $continue k src exp))
(add-pred k
(match exp
(($ $branch k) (add-pred k preds))
(($ $prompt _ _ k) (add-pred k preds))
(_ preds))))))
(persistent-intmap
(intset-fold add-preds labels
(intset->intmap (lambda (label) '()) labels))))
;; Precondition: For each function in CONTS, the continuation names are
;; topologically sorted.
(define (compute-idoms conts kfun)
;; This is the iterative O(n^2) fixpoint algorithm, originally from
;; Allen and Cocke ("Graph-theoretic constructs for program flow
;; analysis", 1972). See the discussion in Cooper, Harvey, and
;; Kennedy's "A Simple, Fast Dominance Algorithm", 2001.
(let ((preds-map (compute-predecessors conts kfun)))
(define (compute-idom idoms preds)
(match preds
(() -1)
((pred) pred) ; Shortcut.
((pred . preds)
(define (common-idom d0 d1)
;; We exploit the fact that a reverse post-order is a
;; topological sort, and so the idom of a node is always
;; numerically less than the node itself.
(let lp ((d0 d0) (d1 d1))
(cond
;; d0 or d1 can be false on the first iteration.
((not d0) d1)
((not d1) d0)
((= d0 d1) d0)
((< d0 d1) (lp d0 (intmap-ref idoms d1)))
(else (lp (intmap-ref idoms d0) d1)))))
(fold1 common-idom preds pred))))
(define (adjoin-idom label preds idoms)
(let ((idom (compute-idom idoms preds)))
;; Don't use intmap-add! here.
(intmap-add idoms label idom (lambda (old new) new))))
(fixpoint (lambda (idoms)
(intmap-fold adjoin-idom preds-map idoms))
empty-intmap)))
;; Compute a vector containing, for each node, a list of the nodes that
;; it immediately dominates. These are the "D" edges in the DJ tree.
(define (compute-dom-edges idoms)
(define (snoc cdr car) (cons car cdr))
(persistent-intmap
(intmap-fold (lambda (label idom doms)
(let ((doms (intmap-add! doms label '())))
(cond
((< idom 0) doms) ;; No edge to entry.
(else (intmap-add! doms idom label snoc)))))
idoms
empty-intmap)))