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