module/language/cps/simplify.scm

   1 ;;; Continuation-passing style (CPS) intermediate language (IL)
   2
   3 ;; Copyright (C) 2013, 2014 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 ;;; The fundamental lambda calculus reductions, like beta and eta
  22 ;;; reduction and so on.  Pretty lame currently.
  23 ;;;
  24 ;;; Code:
  25
  26 (define-module (language cps simplify)
  27   #:use-module (ice-9 match)
  28   #:use-module (srfi srfi-1)
  29   #:use-module (srfi srfi-11)
  30   #:use-module (srfi srfi-26)
  31   #:use-module (language cps)
  32   #:use-module (language cps dfg)
  33   #:use-module (language cps renumber)
  34   #:export (simplify))
  35
  36 (define (compute-eta-reductions fun)
  37   (let ((table (make-hash-table)))
  38     (define (visit-cont cont)
  39       (match cont
  40         (($ $cont sym ($ $kargs names syms body))
  41          (visit-term body sym syms))
  42         (($ $cont sym ($ $kfun src meta self tail clause))
  43          (when clause (visit-cont clause)))
  44         (($ $cont sym ($ $kclause arity body alternate))
  45          (visit-cont body)
  46          (when alternate (visit-cont alternate)))
  47         (($ $cont sym _) #f)))
  48     (define (visit-term term term-k term-args)
  49       (match term
  50         (($ $letk conts body)
  51          (for-each visit-cont conts)
  52          (visit-term body term-k term-args))
  53         (($ $letrec names syms funs body)
  54          (for-each visit-fun funs)
  55          (visit-term body term-k term-args))
  56         (($ $continue k src ($ $values args))
  57          (when (and (equal? term-args args) (not (eq? k term-k)))
  58            (hashq-set! table term-k k)))
  59         (($ $continue k src (and fun ($ $fun)))
  60          (visit-fun fun))
  61         (($ $continue k src _)
  62          #f)))
  63     (define (visit-fun fun)
  64       (match fun
  65         (($ $fun free body)
  66          (visit-cont body))))
  67     (visit-cont fun)
  68     table))
  69
  70 (define (eta-reduce fun)
  71   (let ((table (compute-eta-reductions fun))
  72         (dfg (compute-dfg fun)))
  73     (define (reduce* k scope values?)
  74       (match (hashq-ref table k)
  75         (#f k)
  76         (k*
  77          (if (and (continuation-bound-in? k* scope dfg)
  78                   (or values?
  79                       (match (lookup-cont k* dfg)
  80                         (($ $kargs) #t)
  81                         (_ #f))))
  82              (reduce* k* scope values?)
  83              k))))
  84     (define (reduce k scope)
  85       (reduce* k scope #f))
  86     (define (reduce-values k scope)
  87       (reduce* k scope #t))
  88     (define (reduce-const k src scope const)
  89       (let lp ((k k) (seen '()) (const const))
  90         (match (lookup-cont k dfg)
  91           (($ $kargs (_) (arg) term)
  92            (match (find-call term)
  93              (($ $continue k* src* ($ $values (arg*)))
  94               (and (eqv? arg arg*)
  95                    (not (memq k* seen))
  96                    (lp k* (cons k seen) const)))
  97              (($ $continue k* src* ($ $primcall 'not (arg*)))
  98               (and (eqv? arg arg*)
  99                    (not (memq k* seen))
 100                    (lp k* (cons k seen) (not const))))
 101              (($ $continue k* src* ($ $branch kt ($ $values (arg*))))
 102               (and (eqv? arg arg*)
 103                    (let ((k* (if const kt k*)))
 104                      (and (continuation-bound-in? k* scope dfg)
 105                           (build-cps-term
 106                             ($continue k* src ($values ())))))))
 107              (_
 108               (and (continuation-bound-in? k scope dfg)
 109                    (build-cps-term
 110                      ($continue k src ($const const)))))))
 111           (_ #f))))
 112     (define (visit-cont cont scope)
 113       (rewrite-cps-cont cont
 114         (($ $cont sym ($ $kargs names syms body))
 115          (sym ($kargs names syms ,(visit-term body sym))))
 116         (($ $cont sym ($ $kfun src meta self tail clause))
 117          (sym ($kfun src meta self ,tail
 118                 ,(and clause (visit-cont clause sym)))))
 119         (($ $cont sym ($ $kclause arity body alternate))
 120          (sym ($kclause ,arity ,(visit-cont body sym)
 121                         ,(and alternate (visit-cont alternate sym)))))
 122         (($ $cont sym ($ $kreceive ($ $arity req () rest () #f) kargs))
 123          (sym ($kreceive req rest (reduce kargs scope))))))
 124     (define (visit-term term scope)
 125       (rewrite-cps-term term
 126         (($ $letk conts body)
 127          ($letk ,(map (cut visit-cont <> scope) conts)
 128            ,(visit-term body scope)))
 129         (($ $letrec names syms funs body)
 130          ($letrec names syms (map visit-fun funs)
 131            ,(visit-term body scope)))
 132         (($ $continue k src ($ $values args))
 133          ($continue (reduce-values k scope) src ($values args)))
 134         (($ $continue k src (and fun ($ $fun)))
 135          ($continue (reduce k scope) src ,(visit-fun fun)))
 136         (($ $continue k src ($ $const const))
 137          ,(let ((k (reduce k scope)))
 138             (or (reduce-const k src scope const)
 139                 (build-cps-term ($continue k src ($const const))))))
 140         (($ $continue k src exp)
 141          ($continue (reduce k scope) src ,exp))))
 142     (define (visit-fun fun)
 143       (rewrite-cps-exp fun
 144         (($ $fun free body)
 145          ($fun free ,(visit-cont body #f)))))
 146     (visit-cont fun #f)))
 147
 148 (define (compute-beta-reductions fun)
 149   ;; A continuation's body can be inlined in place of a $values
 150   ;; expression if the continuation is a $kargs.  It should only be
 151   ;; inlined if it is used only once, and not recursively.
 152   (let ((var-table (make-hash-table))
 153         (k-table (make-hash-table))
 154         (dfg (compute-dfg fun)))
 155     (define (visit-cont cont)
 156       (match cont
 157         (($ $cont sym ($ $kargs names syms body))
 158          (visit-term body))
 159         (($ $cont sym ($ $kfun src meta self tail clause))
 160          (when clause (visit-cont clause)))
 161         (($ $cont sym ($ $kclause arity body alternate))
 162          (visit-cont body)
 163          (when alternate (visit-cont alternate)))
 164         (($ $cont sym (or ($ $ktail) ($ $kreceive)))
 165          #f)))
 166     (define (visit-term term)
 167       (match term
 168         (($ $letk conts body)
 169          (for-each visit-cont conts)
 170          (visit-term body))
 171         (($ $letrec names syms funs body)
 172          (for-each visit-fun funs)
 173          (visit-term body))
 174         (($ $continue k src ($ $values args))
 175          (match (lookup-cont k dfg)
 176            (($ $kargs names syms body)
 177             (match (lookup-predecessors k dfg)
 178               ((_)
 179                ;; There is only one use, and it is this use.  We assume
 180                ;; it's not recursive, as there would to be some other
 181                ;; use for control flow to reach this loop.  Store the k
 182                ;; -> body mapping in the table.  Also store the
 183                ;; substitutions for the variables bound by the inlined
 184                ;; continuation.
 185                (for-each (cut hashq-set! var-table <> <>) syms args)
 186                (hashq-set! k-table k body))
 187               (_ #f)))
 188            (_ #f)))
 189         (($ $continue k src (and fun ($ $fun)))
 190          (visit-fun fun))
 191         (($ $continue k src _)
 192          #f)))
 193     (define (visit-fun fun)
 194       (match fun
 195         (($ $fun free body)
 196          (visit-cont body))))
 197     (visit-cont fun)
 198     (values var-table k-table)))
 199
 200 (define (beta-reduce fun)
 201   (let-values (((var-table k-table) (compute-beta-reductions fun)))
 202     (define (subst var)
 203       (cond ((hashq-ref var-table var) => subst)
 204             (else var)))
 205     (define (must-visit-cont cont)
 206       (or (visit-cont cont)
 207           (error "continuation must not be inlined" cont)))
 208     (define (visit-cont cont)
 209       (match cont
 210         (($ $cont sym cont)
 211          (and (not (hashq-ref k-table sym))
 212               (rewrite-cps-cont cont
 213                 (($ $kargs names syms body)
 214                  (sym ($kargs names syms ,(visit-term body))))
 215                 (($ $kfun src meta self tail clause)
 216                  (sym ($kfun src meta self ,tail
 217                         ,(and clause (must-visit-cont clause)))))
 218                 (($ $kclause arity body alternate)
 219                  (sym ($kclause ,arity ,(must-visit-cont body)
 220                                 ,(and alternate (must-visit-cont alternate)))))
 221                 (($ $kreceive)
 222                  (sym ,cont)))))))
 223     (define (visit-term term)
 224       (match term
 225         (($ $letk conts body)
 226          (match (filter-map visit-cont conts)
 227            (() (visit-term body))
 228            (conts (build-cps-term
 229                     ($letk ,conts ,(visit-term body))))))
 230         (($ $letrec names syms funs body)
 231          (build-cps-term
 232            ($letrec names syms (map visit-fun funs)
 233                     ,(visit-term body))))
 234         (($ $continue k src exp)
 235          (cond
 236           ((hashq-ref k-table k) => visit-term)
 237           (else
 238            (build-cps-term ($continue k src ,(visit-exp exp))))))))
 239     (define (visit-exp exp)
 240       (match exp
 241         ((or ($ $void) ($ $const) ($ $prim)) exp)
 242         (($ $fun) (visit-fun exp))
 243         (($ $call proc args)
 244          (let ((args (map subst args)))
 245            (build-cps-exp ($call (subst proc) args))))
 246         (($ $callk k proc args)
 247          (let ((args (map subst args)))
 248            (build-cps-exp ($callk k (subst proc) args))))
 249         (($ $primcall name args)
 250          (let ((args (map subst args)))
 251            (build-cps-exp ($primcall name args))))
 252         (($ $values args)
 253          (let ((args (map subst args)))
 254            (build-cps-exp ($values args))))
 255         (($ $branch kt exp)
 256          (build-cps-exp ($branch kt ,(visit-exp exp))))
 257         (($ $prompt escape? tag handler)
 258          (build-cps-exp ($prompt escape? (subst tag) handler)))))
 259     (define (visit-fun fun)
 260       (rewrite-cps-exp fun
 261         (($ $fun free body)
 262          ($fun (map subst free) ,(must-visit-cont body)))))
 263     (must-visit-cont fun)))
 264
 265 ;; Rewrite the scope tree to reflect the dominator tree.  Precondition:
 266 ;; the fun has been renumbered, its min-label is 0, and its labels are
 267 ;; packed.
 268 (define (redominate fun)
 269   (let* ((dfg (compute-dfg fun))
 270          (idoms (compute-idoms dfg 0 (dfg-label-count dfg)))
 271          (doms (compute-dom-edges idoms 0)))
 272     (define (visit-fun-cont cont)
 273       (rewrite-cps-cont cont
 274         (($ $cont label ($ $kfun src meta self tail clause))
 275          (label ($kfun src meta self ,tail
 276                   ,(and clause (visit-fun-cont clause)))))
 277         (($ $cont label ($ $kclause arity ($ $cont kbody body) alternate))
 278          (label ($kclause ,arity ,(visit-cont kbody body)
 279                           ,(and alternate (visit-fun-cont alternate)))))))
 280
 281     (define (visit-cont label cont)
 282       (rewrite-cps-cont cont
 283         (($ $kargs names vars body)
 284          (label ($kargs names vars ,(visit-term body label))))
 285         (_ (label ,cont))))
 286
 287     (define (visit-exp k src exp)
 288       (rewrite-cps-term exp
 289         (($ $fun free body)
 290          ($continue k src ($fun free ,(visit-fun-cont body))))
 291         (_
 292          ($continue k src ,exp))))
 293
 294     (define (visit-term term label)
 295       (define (visit-dom-conts label)
 296         (let ((cont (lookup-cont label dfg)))
 297           (match cont
 298             (($ $ktail) '())
 299             (($ $kargs) (list (visit-cont label cont)))
 300             (else
 301              (cons (visit-cont label cont)
 302                    (visit-dom-conts* (vector-ref doms label)))))))
 303
 304       (define (visit-dom-conts* labels)
 305         (match labels
 306           (() '())
 307           ((label . labels)
 308            (append (visit-dom-conts label)
 309                    (visit-dom-conts* labels)))))
 310
 311       (rewrite-cps-term term
 312         (($ $letk conts body)
 313          ,(visit-term body label))
 314         (($ $letrec names syms funs body)
 315          ($letrec names syms (let lp ((funs funs))
 316                                (match funs
 317                                  (() '())
 318                                  ((($ $fun free body) . funs)
 319                                   (cons (build-cps-exp
 320                                           ($fun free ,(visit-fun-cont body)))
 321                                         (lp funs)))))
 322            ,(visit-term body label)))
 323         (($ $continue k src exp)
 324          ,(let ((conts (visit-dom-conts* (vector-ref doms label))))
 325             (if (null? conts)
 326                 (visit-exp k src exp)
 327                 (build-cps-term
 328                   ($letk ,conts ,(visit-exp k src exp))))))))
 329
 330     (visit-fun-cont fun)))
 331
 332 (define (simplify fun)
 333   ;; Renumbering prunes continuations that are made unreachable by
 334   ;; eta/beta reductions.
 335   (redominate (renumber (eta-reduce (beta-reduce fun)))))