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          (pending-contifications (make-hash-table)))
  47     (define (subst-call! sym arities body-ks)
  48       (set! call-substs (acons sym (map cons arities body-ks) call-substs)))
  49     (define (subst-return! old-tail new-tail)
  50       (set! cont-substs (acons old-tail new-tail cont-substs)))
  51     (define (lookup-return-cont k)
  52       (match (assq-ref cont-substs k)
  53         (#f k)
  54         (k (lookup-return-cont k))))
  55
  56     (define (add-pending-contifications! scope conts)
  57       (for-each (match-lambda
  58                  (($ $cont k)
  59                   (lift-definition! k scope dfg)))
  60                 conts)
  61       (hashq-set! pending-contifications scope
  62                   (append conts
  63                           (hashq-ref pending-contifications scope '()))))
  64     (define (finish-pending-contifications call term-k)
  65       (match (hashq-ref pending-contifications term-k)
  66         (#f call)
  67         ((cont ...)
  68          ;; Catch any possible double-contification bug.
  69          (hashq-set! pending-contifications term-k 'poison)
  70          (build-cps-term
  71            ($letk ,(map visit-cont cont)
  72              ,call)))))
  73
  74     (define (contify-call proc args)
  75       (and=> (assq-ref call-substs proc)
  76              (lambda (clauses)
  77                (let lp ((clauses clauses))
  78                  (match clauses
  79                    (() (error "invalid contification"))
  80                    (((($ $arity req () #f () #f) . k) . clauses)
  81                     (if (= (length req) (length args))
  82                         (build-cps-term
  83                           ($continue (lookup-return-cont k)
  84                             ($values args)))
  85                         (lp clauses)))
  86                    ((_ . clauses) (lp clauses)))))))
  87
  88     ;; If K is a continuation that binds one variable, and it has only
  89     ;; one predecessor, return that variable.
  90     (define (bound-symbol k)
  91       (match (lookup-cont k cont-table)
  92         (($ $kargs (_) (sym))
  93          (match (lookup-uses k dfg)
  94            ((_)
  95             ;; K has one predecessor, the one that defined SYM.
  96             sym)
  97            (_ #f)))
  98         (_ #f)))
  99
 100     (define (contify-fun term-k sym self tail arities bodies)
 101       (contify-funs term-k
 102                     (list sym) (list self) (list tail)
 103                     (list arities) (list bodies)))
 104
 105     ;; Given a set of mutually recursive functions bound to local
 106     ;; variables SYMS, with self symbols SELFS, tail continuations
 107     ;; TAILS, arities ARITIES, and bodies BODIES, all bound in TERM-K,
 108     ;; contify them if we can prove that they all return to the same
 109     ;; continuation.  Returns a true value on success, and false
 110     ;; otherwise.
 111     (define (contify-funs term-k syms selfs tails arities bodies)
 112       ;; Are the given args compatible with any of the arities?
 113       (define (applicable? proc args)
 114         (or-map (match-lambda
 115                  (($ $arity req () #f () #f)
 116                   (= (length args) (length req)))
 117                  (_ #f))
 118                 (assq-ref (map cons syms arities) proc)))
 119
 120       ;; If the use of PROC in continuation USE is a call to PROC that
 121       ;; is compatible with one of the procedure's arities, return the
 122       ;; target continuation.  Otherwise return #f.
 123       (define (call-target use proc)
 124         (match (find-call (lookup-cont use cont-table))
 125           (($ $continue k ($ $call proc* args))
 126            (and (eq? proc proc*) (not (memq proc args)) (applicable? proc args)
 127                 (lookup-return-cont k)))
 128           (_ #f)))
 129
 130       (and
 131        (and-map null? (map (cut lookup-uses <> dfg) selfs))
 132        (and=> (let visit-syms ((syms syms) (k #f))
 133                 (match syms
 134                   (() k)
 135                   ((sym . syms)
 136                    (let visit-uses ((uses (lookup-uses sym dfg)) (k k))
 137                      (match uses
 138                        (() (visit-syms syms k))
 139                        ((use . uses)
 140                         (and=> (call-target use sym)
 141                                (lambda (k*)
 142                                  (cond
 143                                   ((memq k* tails) (visit-uses uses k))
 144                                   ((not k) (visit-uses uses k*))
 145                                   ((eq? k k*) (visit-uses uses k))
 146                                   (else #f))))))))))
 147               (lambda (k)
 148                 ;; We have a common continuation.  High fives!
 149                 ;;
 150                 ;; (1) Find the scope at which to contify.
 151                 (let ((scope (if (variable-bound-in? k term-k dfg)
 152                                  term-k
 153                                  (lookup-def k dfg))))
 154                   ;; (2) Mark all SYMs for replacement in calls, and
 155                   ;; mark the tail continuations for replacement by K.
 156                   (for-each (lambda (sym tail arities bodies)
 157                               (match bodies
 158                                 ((($ $cont body-k) ...)
 159                                  (subst-call! sym arities body-k)))
 160                               (subst-return! tail k))
 161                             syms tails arities bodies)
 162                   ;; (3) Mutate the DFG to reflect the new scope of the
 163                   ;; continuations, and arrange for the continuations to
 164                   ;; be spliced into their new scope.
 165                   (add-pending-contifications! scope (concatenate bodies))
 166                   k)))))
 167
 168     (define (visit-fun term)
 169       (rewrite-cps-exp term
 170         (($ $fun meta free body)
 171          ($fun meta free ,(visit-cont body)))))
 172     (define (visit-cont cont)
 173       (rewrite-cps-cont cont
 174         (($ $cont sym src
 175             ($ $kargs (name) (and sym (? (cut assq <> call-substs)))
 176                body))
 177          (sym src ($kargs () () ,(visit-term body sym))))
 178         (($ $cont sym src ($ $kargs names syms body))
 179          (sym src ($kargs names syms ,(visit-term body sym))))
 180         (($ $cont sym src ($ $kentry self tail clauses))
 181          (sym src ($kentry self ,tail ,(map visit-cont clauses))))
 182         (($ $cont sym src ($ $kclause arity body))
 183          (sym src ($kclause ,arity ,(visit-cont body))))
 184         (($ $cont)
 185          ,cont)))
 186     (define (visit-term term term-k)
 187       (match term
 188         (($ $letk conts body)
 189          ;; Visit the body first, so we visit depth-first.
 190          (let lp ((body (visit-term body term-k)))
 191            ;; Because we attach contified functions on a particular
 192            ;; term-k, and one term-k can correspond to an arbitrarily
 193            ;; nested sequence of $letrec and $letk instances, normalize
 194            ;; so that all continuations are bound by one $letk --
 195            ;; guaranteeing that they are in the same scope.
 196            (rewrite-cps-term body
 197              (($ $letrec names syms funs body)
 198               ($letrec names syms funs ,(lp body)))
 199              (($ $letk conts* body)
 200               ($letk ,(append conts* (map visit-cont conts))
 201                 ,body))
 202              (body
 203               ($letk ,(map visit-cont conts)
 204                 ,body)))))
 205         (($ $letrec names syms funs body)
 206          (define (split-components nsf)
 207            ;; FIXME: Compute strongly-connected components.  Currently
 208            ;; we just put non-recursive functions in their own
 209            ;; components, and lump everything else in the remaining
 210            ;; component.
 211            (define (recursive? k)
 212              (or-map (cut variable-free-in? <> k dfg) syms))
 213            (let lp ((nsf nsf) (rec '()))
 214              (match nsf
 215                (()
 216                 (if (null? rec)
 217                     '()
 218                     (list rec)))
 219                (((and elt (n s ($ $fun meta free ($ $cont kentry))))
 220                  . nsf)
 221                 (if (recursive? kentry)
 222                     (lp nsf (cons elt rec))
 223                     (cons (list elt) (lp nsf rec)))))))
 224          (define (visit-components components)
 225            (match components
 226              (() (visit-term body term-k))
 227              ((((name sym fun) ...) . components)
 228               (match fun
 229                 ((($ $fun meta free
 230                      ($ $cont fun-k _
 231                         ($ $kentry self
 232                            ($ $cont tail-k _ ($ $ktail))
 233                            (($ $cont _ _ ($ $kclause arity body))
 234                             ...))))
 235                   ...)
 236                  (if (contify-funs term-k sym self tail-k arity body)
 237                      (visit-components components)
 238                      (build-cps-term
 239                        ($letrec name sym (map visit-fun fun)
 240                                 ,(visit-components components)))))))))
 241          (visit-components (split-components (map list names syms funs))))
 242         (($ $continue k exp)
 243          (let ((k* (lookup-return-cont k)))
 244            (define (default)
 245              (rewrite-cps-term exp
 246                (($ $fun) ($continue k* ,(visit-fun exp)))
 247                (($ $primcall 'return (val))
 248                 ,(if (eq? k k*)
 249                      (build-cps-term ($continue k* ,exp))
 250                      (build-cps-term ($continue k* ($values (val))))))
 251                (($ $primcall 'return-values vals)
 252                 ,(if (eq? k k*)
 253                      (build-cps-term ($continue k* ,exp))
 254                      (build-cps-term ($continue k* ($values vals)))))
 255                (_ ($continue k* ,exp))))
 256            (finish-pending-contifications
 257             (match exp
 258               (($ $fun meta free
 259                   ($ $cont fun-k _
 260                      ($ $kentry self
 261                         ($ $cont tail-k _ ($ $ktail))
 262                         (($ $cont _ _ ($ $kclause arity body)) ...))))
 263                (if (and=> (bound-symbol k*)
 264                           (lambda (sym)
 265                             (contify-fun term-k sym self tail-k arity body)))
 266                    (build-cps-term
 267                      ($continue k* ($values ())))
 268                    (default)))
 269               (($ $call proc args)
 270                (or (contify-call proc args)
 271                    (default)))
 272               (_ (default)))
 273             term-k)))))
 274
 275     (let ((fun (visit-fun fun)))
 276       (if (null? call-substs)
 277           fun
 278           ;; Iterate to fixed point.
 279           (contify fun)))))