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-fun 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 (visit-cont cont scope)
  89       (rewrite-cps-cont cont
  90         (($ $cont sym ($ $kargs names syms body))
  91          (sym ($kargs names syms ,(visit-term body sym))))
  92         (($ $cont sym ($ $kfun src meta self tail clause))
  93          (sym ($kfun src meta self ,tail
  94                 ,(and clause (visit-cont clause sym)))))
  95         (($ $cont sym ($ $kclause arity body alternate))
  96          (sym ($kclause ,arity ,(visit-cont body sym)
  97                         ,(and alternate (visit-cont alternate sym)))))
  98         (($ $cont sym ($ $kreceive ($ $arity req () rest () #f) kargs))
  99          (sym ($kreceive req rest (reduce kargs scope))))
 100         (($ $cont sym ($ $kif kt kf))
 101          (sym ($kif (reduce kt scope) (reduce kf scope))))))
 102     (define (visit-term term scope)
 103       (rewrite-cps-term term
 104         (($ $letk conts body)
 105          ($letk ,(map (cut visit-cont <> scope) conts)
 106            ,(visit-term body scope)))
 107         (($ $letrec names syms funs body)
 108          ($letrec names syms (map visit-fun funs)
 109                   ,(visit-term body scope)))
 110         (($ $continue k src ($ $values args))
 111          ($continue (reduce-values k scope) src ($values args)))
 112         (($ $continue k src (and fun ($ $fun)))
 113          ($continue (reduce k scope) src ,(visit-fun fun)))
 114         (($ $continue k src exp)
 115          ($continue (reduce k scope) src ,exp))))
 116     (define (visit-fun fun)
 117       (rewrite-cps-exp fun
 118         (($ $fun free body)
 119          ($fun free ,(visit-cont body #f)))))
 120     (visit-fun fun)))
 121
 122 (define (compute-beta-reductions fun)
 123   ;; A continuation's body can be inlined in place of a $values
 124   ;; expression if the continuation is a $kargs.  It should only be
 125   ;; inlined if it is used only once, and not recursively.
 126   (let ((var-table (make-hash-table))
 127         (k-table (make-hash-table))
 128         (dfg (compute-dfg fun)))
 129     (define (visit-cont cont)
 130       (match cont
 131         (($ $cont sym ($ $kargs names syms body))
 132          (visit-term body))
 133         (($ $cont sym ($ $kfun src meta self tail clause))
 134          (when clause (visit-cont clause)))
 135         (($ $cont sym ($ $kclause arity body alternate))
 136          (visit-cont body)
 137          (when alternate (visit-cont alternate)))
 138         (($ $cont sym (or ($ $ktail) ($ $kreceive) ($ $kif)))
 139          #f)))
 140     (define (visit-term term)
 141       (match term
 142         (($ $letk conts body)
 143          (for-each visit-cont conts)
 144          (visit-term body))
 145         (($ $letrec names syms funs body)
 146          (for-each visit-fun funs)
 147          (visit-term body))
 148         (($ $continue k src ($ $values args))
 149          (match (lookup-cont k dfg)
 150            (($ $kargs names syms body)
 151             (match (lookup-predecessors k dfg)
 152               ((_)
 153                ;; There is only one use, and it is this use.  We assume
 154                ;; it's not recursive, as there would to be some other
 155                ;; use for control flow to reach this loop.  Store the k
 156                ;; -> body mapping in the table.  Also store the
 157                ;; substitutions for the variables bound by the inlined
 158                ;; continuation.
 159                (for-each (cut hashq-set! var-table <> <>) syms args)
 160                (hashq-set! k-table k body))
 161               (_ #f)))
 162            (_ #f)))
 163         (($ $continue k src (and fun ($ $fun)))
 164          (visit-fun fun))
 165         (($ $continue k src _)
 166          #f)))
 167     (define (visit-fun fun)
 168       (match fun
 169         (($ $fun free body)
 170          (visit-cont body))))
 171     (visit-fun fun)
 172     (values var-table k-table)))
 173
 174 (define (beta-reduce fun)
 175   (let-values (((var-table k-table) (compute-beta-reductions fun)))
 176     (define (subst var)
 177       (cond ((hashq-ref var-table var) => subst)
 178             (else var)))
 179     (define (must-visit-cont cont)
 180       (or (visit-cont cont)
 181           (error "continuation must not be inlined" cont)))
 182     (define (visit-cont cont)
 183       (match cont
 184         (($ $cont sym cont)
 185          (and (not (hashq-ref k-table sym))
 186               (rewrite-cps-cont cont
 187                 (($ $kargs names syms body)
 188                  (sym ($kargs names syms ,(visit-term body))))
 189                 (($ $kfun src meta self tail clause)
 190                  (sym ($kfun src meta self ,tail
 191                         ,(and clause (must-visit-cont clause)))))
 192                 (($ $kclause arity body alternate)
 193                  (sym ($kclause ,arity ,(must-visit-cont body)
 194                                 ,(and alternate (must-visit-cont alternate)))))
 195                 ((or ($ $kreceive) ($ $kif))
 196                  (sym ,cont)))))))
 197     (define (visit-term term)
 198       (match term
 199         (($ $letk conts body)
 200          (match (filter-map visit-cont conts)
 201            (() (visit-term body))
 202            (conts (build-cps-term
 203                     ($letk ,conts ,(visit-term body))))))
 204         (($ $letrec names syms funs body)
 205          (build-cps-term
 206            ($letrec names syms (map visit-fun funs)
 207                     ,(visit-term body))))
 208         (($ $continue k src exp)
 209          (cond
 210           ((hashq-ref k-table k) => visit-term)
 211           (else
 212            (build-cps-term
 213              ($continue k src
 214                ,(match exp
 215                   ((or ($ $void) ($ $const) ($ $prim)) exp)
 216                   (($ $fun) (visit-fun exp))
 217                   (($ $call proc args)
 218                    (let ((args (map subst args)))
 219                      (build-cps-exp ($call (subst proc) args))))
 220                   (($ $callk k proc args)
 221                    (let ((args (map subst args)))
 222                      (build-cps-exp ($callk k (subst proc) args))))
 223                   (($ $primcall name args)
 224                    (let ((args (map subst args)))
 225                      (build-cps-exp ($primcall name args))))
 226                   (($ $values args)
 227                    (let ((args (map subst args)))
 228                      (build-cps-exp ($values args))))
 229                   (($ $prompt escape? tag handler)
 230                    (build-cps-exp ($prompt escape? (subst tag) handler)))))))))))
 231     (define (visit-fun fun)
 232       (rewrite-cps-exp fun
 233         (($ $fun free body)
 234          ($fun (map subst free) ,(must-visit-cont body)))))
 235     (visit-fun fun)))
 236
 237 (define (simplify fun)
 238   ;; Renumbering prunes continuations that are made unreachable by
 239   ;; eta/beta reductions.
 240   (renumber (eta-reduce (beta-reduce fun))))