[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-11)
  #:use-module (srfi srfi-26)
  #:use-module (language cps)
  #:use-module (language cps dfg)
  #:use-module (language cps renumber)
  #:export (simplify))

(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 clause))
         (when clause (visit-cont clause)))
        (($ $cont sym ($ $kclause arity body alternate))
         (visit-cont body)
         (when alternate (visit-cont alternate)))
        (($ $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 (and (equal? term-args args) (not (eq? k term-k)))
           (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 (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)
                        (($ $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 clause))
         (sym ($kentry self ,tail ,(and clause (visit-cont clause sym)))))
        (($ $cont sym ($ $kclause arity body alternate))
         (sym ($kclause ,arity ,(visit-cont body sym)
                        ,(and alternate (visit-cont alternate sym)))))
        (($ $cont sym ($ $kreceive ($ $arity req () rest () #f) kargs))
         (sym ($kreceive 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)
      (rewrite-cps-exp fun
        (($ $fun src meta free body)
         ($fun src meta free ,(visit-cont body #f)))))
    (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 ((var-table (make-hash-table))
        (k-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 clause))
         (when clause (visit-cont clause)))
        (($ $cont sym ($ $kclause arity body alternate))
         (visit-cont body)
         (when alternate (visit-cont alternate)))
        (($ $cont sym (or ($ $ktail) ($ $kreceive) ($ $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)
           (($ $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! var-table <> <>) syms args)
               (hashq-set! k-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)
    (values var-table k-table)))

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