[bpt/guile.git] / module / language / cps / simplify.scm

;;; Continuation-passing style (CPS) intermediate language (IL)

;; Copyright (C) 2013, 2014 Free Software Foundation, Inc.

;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

;;; Commentary:
;;;
;;; The fundamental lambda calculus reductions, like beta and eta
;;; reduction and so on.  Pretty lame currently.
;;;
;;; Code:

(define-module (language cps simplify)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (language cps)
  #:use-module (language cps dfg)
  #:export (simplify))

;; Currently we just try to bypass all $values nodes that we can.  This
;; is eta-reduction on continuations.  Then we prune unused
;; continuations.  Note that this pruning is just a quick clean-up; for
;; a real fixed-point pass that can eliminate unused loops, the
;; dead-code elimination pass is there for you.  But DCE introduces new
;; nullary $values nodes (as replacements for expressions whose values
;; aren't used), making it useful for this pass to include its own
;; little pruner.

(define (compute-eta-reductions fun)
  (let ((table (make-hash-table)))
    (define (visit-cont cont)
      (match cont
        (($ $cont sym ($ $kargs names syms body))
         (visit-term body sym syms))
        (($ $cont sym ($ $kentry self tail clauses))
         (for-each visit-cont clauses))
        (($ $cont sym ($ $kclause arity body))
         (visit-cont body))
        (($ $cont sym _) #f)))
    (define (visit-term term term-k term-args)
      (match term
        (($ $letk conts body)
         (for-each visit-cont conts)
         (visit-term body term-k term-args))
        (($ $letrec names syms funs body)
         (for-each visit-fun funs)
         (visit-term body term-k term-args))
        (($ $continue k src ($ $values args))
         (when (equal? term-args args)
           (hashq-set! table term-k k)))
        (($ $continue k src (and fun ($ $fun)))
         (visit-fun fun))
        (($ $continue k src _)
         #f)))
    (define (visit-fun fun)
      (match fun
        (($ $fun src meta free body)
         (visit-cont body))))
    (visit-fun fun)
    table))

(define (locally-prune-continuations fun dfg)
  (let ((cfa (analyze-control-flow fun dfg)))
    (define (must-visit-cont cont)
      (or (visit-cont cont)
          (error "cont must be reachable" cont)))
    (define (visit-cont cont)
      (match cont
        (($ $cont sym cont)
         (and (cfa-k-idx cfa sym #:default (lambda (k) #f))
              (rewrite-cps-cont cont
                (($ $kargs names syms body)
                 (sym ($kargs names syms ,(visit-term body))))
                (($ $kentry self tail clauses)
                 (sym ($kentry self ,tail ,(visit-conts clauses))))
                (($ $kclause arity body)
                 (sym ($kclause ,arity ,(must-visit-cont body))))
                ((or ($ $ktrunc) ($ $kif))
                 (sym ,cont)))))))
    (define (visit-conts conts)
      (filter-map visit-cont conts))
    (define (visit-term term)
      (match term
        (($ $letk conts body)
         (let ((body (visit-term body)))
           (match (visit-conts conts)
             (() body)
             (conts (build-cps-term ($letk ,conts ,body))))))
        (($ $letrec names syms funs body)
         (build-cps-term
           ($letrec names syms funs ,(visit-term body))))
        (($ $continue k src exp)
         term)))
    (rewrite-cps-exp fun
      (($ $fun src meta free body)
       ($fun src meta free ,(must-visit-cont body))))))

(define (eta-reduce fun)
  (let ((table (compute-eta-reductions fun))
        (dfg (compute-dfg fun)))
    (define (reduce* k scope values?)
      (match (hashq-ref table k)
        (#f k)
        (k* 
         (if (and (continuation-bound-in? k* scope dfg)
                  (or values?
                      (match (lookup-cont k* (dfg-cont-table dfg))
                        (($ $kargs) #t)
                        (_ #f))))
             (reduce* k* scope values?)
             k))))
    (define (reduce k scope)
      (reduce* k scope #f))
    (define (reduce-values k scope)
      (reduce* k scope #t))
    (define (visit-cont cont scope)
      (rewrite-cps-cont cont
        (($ $cont sym ($ $kargs names syms body))
         (sym ($kargs names syms ,(visit-term body sym))))
        (($ $cont sym ($ $kentry self tail clauses))
         (sym ($kentry self ,tail ,(map (cut visit-cont <> sym) clauses))))
        (($ $cont sym ($ $kclause arity body))
         (sym ($kclause ,arity ,(visit-cont body sym))))
        (($ $cont sym ($ $ktrunc ($ $arity req () rest () #f) kargs))
         (sym ($ktrunc req rest (reduce kargs scope))))
        (($ $cont sym ($ $kif kt kf))
         (sym ($kif (reduce kt scope) (reduce kf scope))))))
    (define (visit-term term scope)
      (rewrite-cps-term term
        (($ $letk conts body)
         ($letk ,(map (cut visit-cont <> scope) conts)
           ,(visit-term body scope)))
        (($ $letrec names syms funs body)
         ($letrec names syms (map visit-fun funs)
                  ,(visit-term body scope)))
        (($ $continue k src ($ $values args))
         ($continue (reduce-values k scope) src ($values args)))
        (($ $continue k src (and fun ($ $fun)))
         ($continue (reduce k scope) src ,(visit-fun fun)))
        (($ $continue k src exp)
         ($continue (reduce k scope) src ,exp))))
    (define (visit-fun fun)
      (locally-prune-continuations
       (rewrite-cps-exp fun
         (($ $fun src meta free body)
          ($fun src meta free ,(visit-cont body #f))))
       dfg))
    (visit-fun fun)))

(define (compute-beta-reductions fun)
  ;; A continuation's body can be inlined in place of a $values
  ;; expression if the continuation is a $kargs.  It should only be
  ;; inlined if it is used only once, and not recursively.
  (let ((table (make-hash-table))
        (dfg (compute-dfg fun)))
    (define (visit-cont cont)
      (match cont
        (($ $cont sym ($ $kargs names syms body))
         (visit-term body))
        (($ $cont sym ($ $kentry self tail clauses))
         (for-each visit-cont clauses))
        (($ $cont sym ($ $kclause arity body))
         (visit-cont body))
        (($ $cont sym (or ($ $ktail) ($ $ktrunc) ($ $kif)))
         #f)))
    (define (visit-term term)
      (match term
        (($ $letk conts body)
         (for-each visit-cont conts)
         (visit-term body))
        (($ $letrec names syms funs body)
         (for-each visit-fun funs)
         (visit-term body))
        (($ $continue k src ($ $values args))
         (match (lookup-cont k (dfg-cont-table dfg))
           (($ $kargs names syms body)
            (match (lookup-predecessors k dfg)
              ((_)
               ;; There is only one use, and it is this use.  We assume
               ;; it's not recursive, as there would to be some other
               ;; use for control flow to reach this loop.  Store the k
               ;; -> body mapping in the table.  Also store the
               ;; substitutions for the variables bound by the inlined
               ;; continuation.
               (for-each (cut hashq-set! table <> <>) syms args)
               (hashq-set! table k body))
              (_ #f)))
           (_ #f)))
        (($ $continue k src (and fun ($ $fun)))
         (visit-fun fun))
        (($ $continue k src _)
         #f)))
    (define (visit-fun fun)
      (match fun
        (($ $fun src meta free body)
         (visit-cont body))))
    (visit-fun fun)
    table))

(define (beta-reduce fun)
  (let ((table (compute-beta-reductions fun)))
    (define (subst var)
      (cond ((hashq-ref table var) => subst)
            (else var)))
    (define (must-visit-cont cont)
      (or (visit-cont cont)
          (error "continuation must not be inlined" cont)))
    (define (visit-cont cont)
      (match cont
        (($ $cont sym cont)
         (and (not (hashq-ref table sym))
              (rewrite-cps-cont cont
                (($ $kargs names syms body)
                 (sym ($kargs names syms ,(visit-term body))))
                (($ $kentry self tail clauses)
                 (sym ($kentry self ,tail ,(map must-visit-cont clauses))))
                (($ $kclause arity body)
                 (sym ($kclause ,arity ,(must-visit-cont body))))
                ((or ($ $ktrunc) ($ $kif))
                 (sym ,cont)))))))
    (define (visit-term term)
      (match term
        (($ $letk conts body)
         (match (filter-map visit-cont conts)
           (() (visit-term body))
           (conts (build-cps-term
                    ($letk ,conts ,(visit-term body))))))
        (($ $letrec names syms funs body)
         (build-cps-term
           ($letrec names syms (map visit-fun funs)
                    ,(visit-term body))))
        (($ $continue k src exp)
         (cond
          ((hashq-ref table k) => visit-term)
          (else
           (build-cps-term
             ($continue k src
               ,(match exp
                  ((or ($ $void) ($ $const) ($ $prim)) exp)
                  (($ $fun) (visit-fun exp))
                  (($ $call proc args)
                   (let ((args (map subst args)))
                     (build-cps-exp ($call (subst proc) args))))
                  (($ $primcall name args)
                   (let ((args (map subst args)))
                     (build-cps-exp ($primcall name args))))
                  (($ $values args)
                   (let ((args (map subst args)))
                     (build-cps-exp ($values args))))
                  (($ $prompt escape? tag handler)
                   (build-cps-exp ($prompt escape? (subst tag) handler)))))))))))
    (define (visit-fun fun)
      (rewrite-cps-exp fun
        (($ $fun src meta free body)
         ($fun src meta (map subst free) ,(must-visit-cont body)))))
    (visit-fun fun)))

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