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