[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 ($ $kfun src meta 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 free body)
         (visit-cont body))))
    (visit-cont 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 ($ $kfun src meta self tail clause))
         (sym ($kfun src meta 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))))))
    (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 free body)
         ($fun free ,(visit-cont body #f)))))
    (visit-cont fun #f)))

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