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