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   #:export (simplify))
  34
  35 ;; Currently we just try to bypass all $values nodes that we can.  This
  36 ;; is eta-reduction on continuations.  Then we prune unused
  37 ;; continuations.  Note that this pruning is just a quick clean-up; for
  38 ;; a real fixed-point pass that can eliminate unused loops, the
  39 ;; dead-code elimination pass is there for you.  But DCE introduces new
  40 ;; nullary $values nodes (as replacements for expressions whose values
  41 ;; aren't used), making it useful for this pass to include its own
  42 ;; little pruner.
  43
  44 (define* (prune-continuations fun #:optional (dfg (compute-dfg fun)))
  45   (let ((cfa (analyze-control-flow fun dfg)))
  46     (define (must-visit-cont cont)
  47       (or (visit-cont cont)
  48           (error "cont must be reachable" cont)))
  49     (define (visit-cont cont)
  50       (match cont
  51         (($ $cont sym cont)
  52          (and (cfa-k-idx cfa sym #:default (lambda (k) #f))
  53               (rewrite-cps-cont cont
  54                 (($ $kargs names syms body)
  55                  (sym ($kargs names syms ,(visit-term body))))
  56                 (($ $kentry self tail clauses)
  57                  (sym ($kentry self ,tail ,(visit-conts clauses))))
  58                 (($ $kclause arity body)
  59                  (sym ($kclause ,arity ,(must-visit-cont body))))
  60                 ((or ($ $kreceive) ($ $kif))
  61                  (sym ,cont)))))))
  62     (define (visit-conts conts)
  63       (filter-map visit-cont conts))
  64     (define (visit-term term)
  65       (match term
  66         (($ $letk conts body)
  67          (let ((body (visit-term body)))
  68            (match (visit-conts conts)
  69              (() body)
  70              (conts (build-cps-term ($letk ,conts ,body))))))
  71         (($ $letrec names syms funs body)
  72          (build-cps-term
  73            ($letrec names syms (map (cut prune-continuations <> dfg) funs)
  74                     ,(visit-term body))))
  75         (($ $continue k src (and fun ($ $fun)))
  76          (build-cps-term
  77            ($continue k src ,(prune-continuations fun dfg))))
  78         (($ $continue k src exp)
  79          term)))
  80     (rewrite-cps-exp fun
  81       (($ $fun src meta free body)
  82        ($fun src meta free ,(must-visit-cont body))))))
  83
  84 (define (compute-eta-reductions fun)
  85   (let ((table (make-hash-table)))
  86     (define (visit-cont cont)
  87       (match cont
  88         (($ $cont sym ($ $kargs names syms body))
  89          (visit-term body sym syms))
  90         (($ $cont sym ($ $kentry self tail clauses))
  91          (for-each visit-cont clauses))
  92         (($ $cont sym ($ $kclause arity body))
  93          (visit-cont body))
  94         (($ $cont sym _) #f)))
  95     (define (visit-term term term-k term-args)
  96       (match term
  97         (($ $letk conts body)
  98          (for-each visit-cont conts)
  99          (visit-term body term-k term-args))
 100         (($ $letrec names syms funs body)
 101          (for-each visit-fun funs)
 102          (visit-term body term-k term-args))
 103         (($ $continue k src ($ $values args))
 104          (when (and (equal? term-args args) (not (eq? k term-k)))
 105            (hashq-set! table term-k k)))
 106         (($ $continue k src (and fun ($ $fun)))
 107          (visit-fun fun))
 108         (($ $continue k src _)
 109          #f)))
 110     (define (visit-fun fun)
 111       (match fun
 112         (($ $fun src meta free body)
 113          (visit-cont body))))
 114     (visit-fun fun)
 115     table))
 116
 117 (define (eta-reduce fun)
 118   (let ((table (compute-eta-reductions fun))
 119         (dfg (compute-dfg fun)))
 120     (define (reduce* k scope values?)
 121       (match (hashq-ref table k)
 122         (#f k)
 123         (k*
 124          (if (and (continuation-bound-in? k* scope dfg)
 125                   (or values?
 126                       (match (lookup-cont k* dfg)
 127                         (($ $kargs) #t)
 128                         (_ #f))))
 129              (reduce* k* scope values?)
 130              k))))
 131     (define (reduce k scope)
 132       (reduce* k scope #f))
 133     (define (reduce-values k scope)
 134       (reduce* k scope #t))
 135     (define (visit-cont cont scope)
 136       (rewrite-cps-cont cont
 137         (($ $cont sym ($ $kargs names syms body))
 138          (sym ($kargs names syms ,(visit-term body sym))))
 139         (($ $cont sym ($ $kentry self tail clauses))
 140          (sym ($kentry self ,tail ,(map (cut visit-cont <> sym) clauses))))
 141         (($ $cont sym ($ $kclause arity body))
 142          (sym ($kclause ,arity ,(visit-cont body sym))))
 143         (($ $cont sym ($ $kreceive ($ $arity req () rest () #f) kargs))
 144          (sym ($kreceive req rest (reduce kargs scope))))
 145         (($ $cont sym ($ $kif kt kf))
 146          (sym ($kif (reduce kt scope) (reduce kf scope))))))
 147     (define (visit-term term scope)
 148       (rewrite-cps-term term
 149         (($ $letk conts body)
 150          ($letk ,(map (cut visit-cont <> scope) conts)
 151            ,(visit-term body scope)))
 152         (($ $letrec names syms funs body)
 153          ($letrec names syms (map visit-fun funs)
 154                   ,(visit-term body scope)))
 155         (($ $continue k src ($ $values args))
 156          ($continue (reduce-values k scope) src ($values args)))
 157         (($ $continue k src (and fun ($ $fun)))
 158          ($continue (reduce k scope) src ,(visit-fun fun)))
 159         (($ $continue k src exp)
 160          ($continue (reduce k scope) src ,exp))))
 161     (define (visit-fun fun)
 162       (rewrite-cps-exp fun
 163         (($ $fun src meta free body)
 164          ($fun src meta free ,(visit-cont body #f)))))
 165     (visit-fun fun)))
 166
 167 (define (compute-beta-reductions fun)
 168   ;; A continuation's body can be inlined in place of a $values
 169   ;; expression if the continuation is a $kargs.  It should only be
 170   ;; inlined if it is used only once, and not recursively.
 171   (let ((var-table (make-hash-table))
 172         (k-table (make-hash-table))
 173         (dfg (compute-dfg fun)))
 174     (define (visit-cont cont)
 175       (match cont
 176         (($ $cont sym ($ $kargs names syms body))
 177          (visit-term body))
 178         (($ $cont sym ($ $kentry self tail clauses))
 179          (for-each visit-cont clauses))
 180         (($ $cont sym ($ $kclause arity body))
 181          (visit-cont body))
 182         (($ $cont sym (or ($ $ktail) ($ $kreceive) ($ $kif)))
 183          #f)))
 184     (define (visit-term term)
 185       (match term
 186         (($ $letk conts body)
 187          (for-each visit-cont conts)
 188          (visit-term body))
 189         (($ $letrec names syms funs body)
 190          (for-each visit-fun funs)
 191          (visit-term body))
 192         (($ $continue k src ($ $values args))
 193          (match (lookup-cont k dfg)
 194            (($ $kargs names syms body)
 195             (match (lookup-predecessors k dfg)
 196               ((_)
 197                ;; There is only one use, and it is this use.  We assume
 198                ;; it's not recursive, as there would to be some other
 199                ;; use for control flow to reach this loop.  Store the k
 200                ;; -> body mapping in the table.  Also store the
 201                ;; substitutions for the variables bound by the inlined
 202                ;; continuation.
 203                (for-each (cut hashq-set! var-table <> <>) syms args)
 204                (hashq-set! k-table k body))
 205               (_ #f)))
 206            (_ #f)))
 207         (($ $continue k src (and fun ($ $fun)))
 208          (visit-fun fun))
 209         (($ $continue k src _)
 210          #f)))
 211     (define (visit-fun fun)
 212       (match fun
 213         (($ $fun src meta free body)
 214          (visit-cont body))))
 215     (visit-fun fun)
 216     (values var-table k-table)))
 217
 218 (define (beta-reduce fun)
 219   (let-values (((var-table k-table) (compute-beta-reductions fun)))
 220     (define (subst var)
 221       (cond ((hashq-ref var-table var) => subst)
 222             (else var)))
 223     (define (must-visit-cont cont)
 224       (or (visit-cont cont)
 225           (error "continuation must not be inlined" cont)))
 226     (define (visit-cont cont)
 227       (match cont
 228         (($ $cont sym cont)
 229          (and (not (hashq-ref k-table sym))
 230               (rewrite-cps-cont cont
 231                 (($ $kargs names syms body)
 232                  (sym ($kargs names syms ,(visit-term body))))
 233                 (($ $kentry self tail clauses)
 234                  (sym ($kentry self ,tail ,(map must-visit-cont clauses))))
 235                 (($ $kclause arity body)
 236                  (sym ($kclause ,arity ,(must-visit-cont body))))
 237                 ((or ($ $kreceive) ($ $kif))
 238                  (sym ,cont)))))))
 239     (define (visit-term term)
 240       (match term
 241         (($ $letk conts body)
 242          (match (filter-map visit-cont conts)
 243            (() (visit-term body))
 244            (conts (build-cps-term
 245                     ($letk ,conts ,(visit-term body))))))
 246         (($ $letrec names syms funs body)
 247          (build-cps-term
 248            ($letrec names syms (map visit-fun funs)
 249                     ,(visit-term body))))
 250         (($ $continue k src exp)
 251          (cond
 252           ((hashq-ref k-table k) => visit-term)
 253           (else
 254            (build-cps-term
 255              ($continue k src
 256                ,(match exp
 257                   ((or ($ $void) ($ $const) ($ $prim)) exp)
 258                   (($ $fun) (visit-fun exp))
 259                   (($ $call proc args)
 260                    (let ((args (map subst args)))
 261                      (build-cps-exp ($call (subst proc) args))))
 262                   (($ $callk k proc args)
 263                    (let ((args (map subst args)))
 264                      (build-cps-exp ($callk k (subst proc) args))))
 265                   (($ $primcall name args)
 266                    (let ((args (map subst args)))
 267                      (build-cps-exp ($primcall name args))))
 268                   (($ $values args)
 269                    (let ((args (map subst args)))
 270                      (build-cps-exp ($values args))))
 271                   (($ $prompt escape? tag handler)
 272                    (build-cps-exp ($prompt escape? (subst tag) handler)))))))))))
 273     (define (visit-fun fun)
 274       (rewrite-cps-exp fun
 275         (($ $fun src meta free body)
 276          ($fun src meta (map subst free) ,(must-visit-cont body)))))
 277     (visit-fun fun)))
 278
 279 (define (simplify fun)
 280   (prune-continuations (eta-reduce (beta-reduce fun))))