1;;; Continuation-passing style (CPS) intermediate language (IL)
2
3;; Copyright (C) 2013, 2014, 2015 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 utils)
33  #:use-module (language cps intset)
34  #:use-module (language cps intmap)
35  #:export (simplify))
36
37(define (intset-maybe-add! set k add?)
38  (if add? (intset-add! set k) set))
39
40(define (intset-add*! set k*)
41  (fold1 (lambda (k set) (intset-add! set k)) k* set))
42
43(define (fold2* f l1 l2 seed)
44  (let lp ((l1 l1) (l2 l2) (seed seed))
45    (match (cons l1 l2)
46      ((() . ()) seed)
47      (((x1 . l1) . (x2 . l2)) (lp l1 l2 (f x1 x2 seed))))))
48
49(define (transform-conts f conts)
50  (persistent-intmap
51   (intmap-fold (lambda (k v out)
52                  (let ((v* (f k v)))
53                    (cond
54                     ((equal? v v*) out)
55                     (v* (intmap-replace! out k v*))
56                     (else (intmap-remove out k)))))
57                conts
58                conts)))
59
60(define (compute-singly-referenced-vars conts)
61  (define (visit label cont single multiple)
62    (define (add-ref var single multiple)
63      (if (intset-ref single var)
64          (values single (intset-add! multiple var))
65          (values (intset-add! single var) multiple)))
66    (define (ref var) (add-ref var single multiple))
67    (define (ref* vars) (fold2 add-ref vars single multiple))
68    (match cont
69      (($ $kargs _ _ ($ $continue _ _ exp))
70       (match exp
71         ((or ($ $const) ($ $prim) ($ $fun) ($ $rec) ($ $closure))
72          (values single multiple))
73         (($ $call proc args)
74          (ref* (cons proc args)))
75         (($ $callk k proc args)
76          (ref* (cons proc args)))
77         (($ $primcall name args)
78          (ref* args))
79         (($ $values args)
80          (ref* args))
81         (($ $branch kt ($ $values (var)))
82          (ref var))
83         (($ $branch kt ($ $primcall name args))
84          (ref* args))
85         (($ $prompt escape? tag handler)
86          (ref tag))))
87      (_
88       (values single multiple))))
89  (let*-values (((single multiple) (values empty-intset empty-intset))
90                ((single multiple) (intmap-fold visit conts single multiple)))
91    (intset-subtract (persistent-intset single)
92                     (persistent-intset multiple))))
93
94;;; Continuations whose values are simply forwarded to another and not
95;;; used in any other way may be elided via eta reduction over labels.
96;;;
97;;; There is an exception however: we must exclude strongly-connected
98;;; components (SCCs).  The only kind of SCC we can build out of $values
99;;; expressions are infinite loops.
100;;;
101;;; Condition A below excludes single-node SCCs.  Single-node SCCs
102;;; cannot be reduced.
103;;;
104;;; Condition B conservatively excludes edges to labels already marked
105;;; as candidates.  This prevents back-edges and so breaks SCCs, and is
106;;; optimal if labels are sorted.  If the labels aren't sorted it's
107;;; suboptimal but cheap.
108(define (compute-eta-reductions conts kfun singly-used)
109  (define (singly-used? vars)
110    (match vars
111      (() #t)
112      ((var . vars)
113       (and (intset-ref singly-used var) (singly-used? vars)))))
114  (define (visit-fun kfun body eta)
115    (define (visit-cont label eta)
116      (match (intmap-ref conts label)
117        (($ $kargs names vars ($ $continue k src ($ $values vars)))
118         (intset-maybe-add! eta label
119                            (match (intmap-ref conts k)
120                              (($ $kargs)
121                               (and (not (eqv? label k)) ; A
122                                    (not (intset-ref eta label)) ; B
123                                    (singly-used? vars)))
124                              (_ #f))))
125        (_
126         eta)))
127    (intset-fold visit-cont body eta))
128  (persistent-intset
129   (intmap-fold visit-fun
130                (compute-reachable-functions conts kfun)
131                empty-intset)))
132
133(define (eta-reduce conts kfun)
134  (let* ((singly-used (compute-singly-referenced-vars conts))
135         (label-set (compute-eta-reductions conts kfun singly-used)))
136    ;; Replace any continuation to a label in LABEL-SET with the label's
137    ;; continuation.  The label will denote a $kargs continuation, so
138    ;; only terms that can continue to $kargs need be taken into
139    ;; account.
140    (define (subst label)
141      (if (intset-ref label-set label)
142          (match (intmap-ref conts label)
143            (($ $kargs _ _ ($ $continue k)) (subst k)))
144          label))
145    (transform-conts
146     (lambda (label cont)
147       (and (not (intset-ref label-set label))
148            (rewrite-cont cont
149              (($ $kargs names syms ($ $continue kf src ($ $branch kt exp)))
150               ($kargs names syms
151                 ($continue (subst kf) src ($branch (subst kt) ,exp))))
152              (($ $kargs names syms ($ $continue k src ($ $const val)))
153               ,(match (intmap-ref conts k)
154                  (($ $kargs (_)
155                             ((? (lambda (var) (intset-ref singly-used var))
156                                 var))
157                      ($ $continue kf _ ($ $branch kt ($ $values (var)))))
158                   (build-cont
159                     ($kargs names syms
160                       ($continue (subst (if val kt kf)) src ($values ())))))
161                  (_
162                   (build-cont
163                     ($kargs names syms
164                       ($continue (subst k) src ($const val)))))))
165              (($ $kargs names syms ($ $continue k src exp))
166               ($kargs names syms
167                 ($continue (subst k) src ,exp)))
168              (($ $kreceive ($ $arity req () rest () #f) k)
169               ($kreceive req rest (subst k)))
170              (($ $kclause arity body alt)
171               ($kclause ,arity (subst body) alt))
172              (_ ,cont))))
173     conts)))
174
175(define (compute-singly-referenced-labels conts body)
176  (define (add-ref label single multiple)
177    (define (ref k single multiple)
178      (if (intset-ref single k)
179          (values single (intset-add! multiple k))
180          (values (intset-add! single k) multiple)))
181    (define (ref0) (values single multiple))
182    (define (ref1 k) (ref k single multiple))
183    (define (ref2 k k*)
184      (if k*
185          (let-values (((single multiple) (ref k single multiple)))
186            (ref k* single multiple))
187          (ref1 k)))
188    (match (intmap-ref conts label)
189      (($ $kreceive arity k) (ref1 k))
190      (($ $kfun src meta self ktail kclause) (ref2 ktail kclause))
191      (($ $ktail) (ref0))
192      (($ $kclause arity kbody kalt) (ref2 kbody kalt))
193      (($ $kargs names syms ($ $continue k src exp))
194       (ref2 k (match exp (($ $branch k) k) (($ $prompt _ _ k) k) (_ #f))))))
195  (let*-values (((single multiple) (values empty-intset empty-intset))
196                ((single multiple) (intset-fold add-ref body single multiple)))
197    (intset-subtract (persistent-intset single)
198                     (persistent-intset multiple))))
199
200(define (compute-beta-reductions conts kfun)
201  (define (visit-fun kfun body beta)
202    (let ((single (compute-singly-referenced-labels conts body)))
203      (define (visit-cont label beta)
204        (match (intmap-ref conts label)
205          ;; A continuation's body can be inlined in place of a $values
206          ;; expression if the continuation is a $kargs.  It should only
207          ;; be inlined if it is used only once, and not recursively.
208          (($ $kargs _ _ ($ $continue k src ($ $values)))
209           (intset-maybe-add! beta label
210                              (and (intset-ref single k)
211                                   (match (intmap-ref conts k)
212                                     (($ $kargs) #t)
213                                     (_ #f)))))
214          (_
215           beta)))
216      (intset-fold visit-cont body beta)))
217  (persistent-intset
218   (intmap-fold visit-fun
219                (compute-reachable-functions conts kfun)
220                empty-intset)))
221
222(define (compute-beta-var-substitutions conts label-set)
223  (define (add-var-substs label var-map)
224    (match (intmap-ref conts label)
225      (($ $kargs _ _ ($ $continue k _ ($ $values vals)))
226       (match (intmap-ref conts k)
227         (($ $kargs names vars)
228          (fold2* (lambda (var val var-map)
229                    (intmap-add! var-map var val))
230                  vars vals var-map))))))
231  (intset-fold add-var-substs label-set empty-intmap))
232
233(define (beta-reduce conts kfun)
234  (let* ((label-set (compute-beta-reductions conts kfun))
235         (var-map (compute-beta-var-substitutions conts label-set)))
236    (define (subst var)
237      (match (intmap-ref var-map var (lambda (_) #f))
238        (#f var)
239        (val (subst val))))
240    (define (transform-exp label k src exp)
241      (if (intset-ref label-set label)
242          (match (intmap-ref conts k)
243            (($ $kargs _ _ ($ $continue k* src* exp*))
244             (transform-exp k k* src* exp*)))
245          (build-term
246           ($continue k src
247             ,(rewrite-exp exp
248                ((or ($ $const) ($ $prim) ($ $fun) ($ $rec) ($ $closure))
249                 ,exp)
250                (($ $call proc args)
251                 ($call (subst proc) ,(map subst args)))
252                (($ $callk k proc args)
253                 ($callk k (subst proc) ,(map subst args)))
254                (($ $primcall name args)
255                 ($primcall name ,(map subst args)))
256                (($ $values args)
257                 ($values ,(map subst args)))
258                (($ $branch kt ($ $values (var)))
259                 ($branch kt ($values ((subst var)))))
260                (($ $branch kt ($ $primcall name args))
261                 ($branch kt ($primcall name ,(map subst args))))
262                (($ $prompt escape? tag handler)
263                 ($prompt escape? (subst tag) handler)))))))
264    (transform-conts
265     (lambda (label cont)
266       (match cont
267         (($ $kargs names syms ($ $continue k src exp))
268          (build-cont
269           ($kargs names syms ,(transform-exp label k src exp))))
270         (_ cont)))
271     conts)))
272
273(define (simplify conts)
274  (eta-reduce (beta-reduce conts 0) 0))
275