module/language/cps/contification.scm

   1 ;;; Continuation-passing style (CPS) intermediate language (IL)
   2
   3 ;; Copyright (C) 2013 Free Software Foundation, Inc.
   4
   5 ;;;; This library is free software; you can redistribute it and/or
   6 ;;;; modify it under the terms of the GNU Lesser General Public
   7 ;;;; License as published by the Free Software Foundation; either
   8 ;;;; version 3 of the License, or (at your option) any later version.
   9 ;;;;
  10 ;;;; This library is distributed in the hope that it will be useful,
  11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;;;; Lesser General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU Lesser General Public
  16 ;;;; License along with this library; if not, write to the Free Software
  17 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18
  19 ;;; Commentary:
  20 ;;;
  21 ;;; Contification is a pass that turns $fun instances into $cont
  22 ;;; instances if all calls to the $fun return to the same continuation.
  23 ;;; This is a more rigorous variant of our old "fixpoint labels
  24 ;;; allocation" optimization.
  25 ;;;
  26 ;;; See Kennedy's "Compiling with Continuations, Continued", and Fluet
  27 ;;; and Weeks's "Contification using Dominators".
  28 ;;;
  29 ;;; Code:
  30
  31 (define-module (language cps contification)
  32   #:use-module (ice-9 match)
  33   #:use-module ((srfi srfi-1) #:select (concatenate))
  34   #:use-module (srfi srfi-26)
  35   #:use-module (language cps)
  36   #:use-module (language cps dfg)
  37   #:use-module (language cps primitives)
  38   #:use-module (language rtl)
  39   #:export (contify))
  40
  41 (define (contify fun)
  42   (let* ((dfg (compute-dfg fun))
  43          (cont-table (dfg-cont-table dfg))
  44          (call-substs '())
  45          (cont-substs '()))
  46     (define (subst-call! sym arities body-ks)
  47       (set! call-substs (acons sym (map cons arities body-ks) call-substs)))
  48     (define (subst-return! old-tail new-tail)
  49       (set! cont-substs (acons old-tail new-tail cont-substs)))
  50     (define (lookup-return-cont k)
  51       (or (assq-ref cont-substs k) k))
  52
  53     (define (contify-call proc args)
  54       (and=> (assq-ref call-substs proc)
  55              (lambda (clauses)
  56                (let lp ((clauses clauses))
  57                  (match clauses
  58                    (() (error "invalid contification"))
  59                    (((($ $arity req () #f () #f) . k) . clauses)
  60                     (if (= (length req) (length args))
  61                         (build-cps-term
  62                           ($continue k ($values args)))
  63                         (lp clauses)))
  64                    ((_ . clauses) (lp clauses)))))))
  65
  66     ;; If K is a continuation that binds one variable, and it has only
  67     ;; one predecessor, return that variable.
  68     (define (bound-symbol k)
  69       (match (lookup-cont k cont-table)
  70         (($ $kargs (_) (sym))
  71          (match (lookup-uses k dfg)
  72            ((_)
  73             ;; K has one predecessor, the one that defined SYM.
  74             sym)
  75            (_ #f)))
  76         (_ #f)))
  77
  78     (define (contify-fun term-k sym self tail arities bodies)
  79       (contify-funs term-k
  80                     (list sym) (list self) (list tail)
  81                     (list arities) (list bodies)))
  82
  83     (define (contify-funs term-k syms selfs tails arities bodies)
  84       ;; Are the given args compatible with any of the arities?
  85       (define (applicable? proc args)
  86         (or-map (match-lambda
  87                  (($ $arity req () #f () #f)
  88                   (= (length args) (length req)))
  89                  (_ #f))
  90                 (assq-ref (map cons syms arities) proc)))
  91
  92       ;; If the use of PROC in continuation USE is a call to PROC that
  93       ;; is compatible with one of the procedure's arities, return the
  94       ;; target continuation.  Otherwise return #f.
  95       (define (call-target use proc)
  96         (match (find-call (lookup-cont use cont-table))
  97           (($ $continue k ($ $call proc* args))
  98            (and (eq? proc proc*) (not (memq proc args)) (applicable? proc args)
  99                 k))
 100           (_ #f)))
 101
 102       (and
 103        (and-map null? (map (cut lookup-uses <> dfg) selfs))
 104        (and=> (let visit-syms ((syms syms) (k #f))
 105                 (match syms
 106                   (() k)
 107                   ((sym . syms)
 108                    (let visit-uses ((uses (lookup-uses sym dfg)) (k k))
 109                      (match uses
 110                        (() (visit-syms syms k))
 111                        ((use . uses)
 112                         (and=> (call-target use sym)
 113                                (lambda (k*)
 114                                  (cond
 115                                   ((memq k* tails) (visit-uses uses k))
 116                                   ((not k) (visit-uses uses k*))
 117                                   ((eq? k k*) (visit-uses uses k))
 118                                   (else #f))))))))))
 119               (lambda (k)
 120                 ;; We have a common continuation, so we contify: mark
 121                 ;; all SYMs for replacement in calls, and mark the tail
 122                 ;; continuations for replacement by K.
 123                 (for-each (lambda (sym tail arities bodies)
 124                             (for-each (cut lift-definition! <> term-k dfg)
 125                                       bodies)
 126                             (subst-call! sym arities bodies)
 127                             (subst-return! tail k))
 128                           syms tails arities bodies)
 129                 k))))
 130
 131     ;; This is a first cut at a contification algorithm.  It contifies
 132     ;; non-recursive functions that only have positional arguments.
 133     (define (visit-fun term)
 134       (rewrite-cps-exp term
 135         (($ $fun meta free body)
 136          ($fun meta free ,(visit-cont body)))))
 137     (define (visit-cont cont)
 138       (rewrite-cps-cont cont
 139         (($ $cont sym src
 140             ($ $kargs (name) (and sym (? (cut assq <> call-substs)))
 141                body))
 142          (sym src ($kargs () () ,(visit-term body sym))))
 143         (($ $cont sym src ($ $kargs names syms body))
 144          (sym src ($kargs names syms ,(visit-term body sym))))
 145         (($ $cont sym src ($ $kentry self tail clauses))
 146          (sym src ($kentry self ,tail ,(map visit-cont clauses))))
 147         (($ $cont sym src ($ $kclause arity body))
 148          (sym src ($kclause ,arity ,(visit-cont body))))
 149         (($ $cont)
 150          ,cont)))
 151     (define (visit-term term term-k)
 152       (match term
 153         (($ $letk conts body)
 154          ;; Visit the body first, so we visit depth-first.
 155          (let ((body (visit-term body term-k)))
 156            (build-cps-term
 157              ($letk ,(map visit-cont conts) ,body))))
 158         (($ $letrec names syms funs body)
 159          (define (split-components nsf)
 160            ;; FIXME: Compute strongly-connected components.  Currently
 161            ;; we just put non-recursive functions in their own
 162            ;; components, and lump everything else in the remaining
 163            ;; component.
 164            (define (recursive? k)
 165              (or-map (cut variable-used-in? <> k dfg) syms))
 166            (let lp ((nsf nsf) (rec '()))
 167              (match nsf
 168                (()
 169                 (if (null? rec)
 170                     '()
 171                     (list rec)))
 172                (((and elt (n s ($ $fun meta free ($ $cont kentry))))
 173                  . nsf)
 174                 (if (recursive? kentry)
 175                     (lp nsf (cons elt rec))
 176                     (cons (list elt) (lp nsf rec)))))))
 177          (define (visit-components components)
 178            (match components
 179              (() (visit-term body term-k))
 180              ((((name sym fun) ...) . components)
 181               (match fun
 182                 ((($ $fun meta free
 183                      ($ $cont fun-k _
 184                         ($ $kentry self
 185                            ($ $cont tail-k _ ($ $ktail))
 186                            (($ $cont _ _ ($ $kclause arity
 187                                             (and body ($ $cont body-k))))
 188                             ...))))
 189                   ...)
 190                  (if (contify-funs term-k sym self tail-k arity body-k)
 191                      (let ((body* (visit-components components)))
 192                        (build-cps-term
 193                          ($letk ,(map visit-cont (concatenate body))
 194                            ,body*)))
 195                      (let-gensyms (k)
 196                        (build-cps-term
 197                          ($letrec name sym (map visit-fun fun)
 198                                   ,(visit-components components))))))))))
 199          (visit-components (split-components (map list names syms funs))))
 200         (($ $continue k exp)
 201          (let ((k* (lookup-return-cont k)))
 202            (define (default)
 203              (rewrite-cps-term exp
 204                (($ $fun) ($continue k* ,(visit-fun exp)))
 205                (($ $primcall 'return (val))
 206                 ,(if (eq? k k*)
 207                      (build-cps-term ($continue k* ,exp))
 208                      (build-cps-term ($continue k* ($values (val))))))
 209                (($ $primcall 'return-values vals)
 210                 ,(if (eq? k k*)
 211                      (build-cps-term ($continue k* ,exp))
 212                      (build-cps-term ($continue k* ($values vals)))))
 213                (_ ($continue k* ,exp))))
 214            (match exp
 215              (($ $fun meta free
 216                  ($ $cont fun-k _
 217                     ($ $kentry self
 218                        ($ $cont tail-k _ ($ $ktail))
 219                        (($ $cont _ _ ($ $kclause arity
 220                                         (and body ($ $cont body-k))))
 221                         ...))))
 222               (if (and=> (bound-symbol k*)
 223                          (lambda (sym)
 224                            (contify-fun term-k sym self tail-k arity body-k)))
 225                   (build-cps-term
 226                     ($letk ,(map visit-cont body)
 227                       ($continue k* ($values ()))))
 228                   (default)))
 229              (($ $call proc args)
 230               (or (contify-call proc args)
 231                   (default)))
 232              (_ (default)))))))
 233
 234     (let ((fun (visit-fun fun)))
 235       (if (null? call-substs)
 236           fun
 237           ;; Iterate to fixed point.
 238           (contify fun)))))