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;;; A pass that prunes successors of expressions that bail out. 22;;; 23;;; Code: 24 25(define-module (language cps prune-bailouts) 26 #:use-module (ice-9 match) 27 #:use-module (language cps) 28 #:use-module (language cps utils) 29 #:use-module (language cps with-cps) 30 #:use-module (language cps intmap) 31 #:use-module (language cps intset) 32 #:export (prune-bailouts)) 33 34(define (compute-tails conts) 35 "For each LABEL->CONT entry in the intmap CONTS, compute a 36LABEL->TAIL-LABEL indicating the tail continuation of each expression's 37containing function. In some cases TAIL-LABEL might not be available, 38for example if there is a stale $kfun pointing at a body, or for 39unreferenced terms. In that case TAIL-LABEL is either absent or #f." 40 (intmap-fold 41 (lambda (label cont out) 42 (match cont 43 (($ $kfun src meta self tail clause) 44 (intset-fold (lambda (label out) 45 (intmap-add out label tail (lambda (old new) #f))) 46 (compute-function-body conts label) 47 out)) 48 (_ out))) 49 conts 50 empty-intmap)) 51 52(define (prune-bailout out tails k src exp) 53 (match (intmap-ref out k) 54 (($ $ktail) 55 (with-cps out #f)) 56 (_ 57 (match (intmap-ref tails k (lambda (_) #f)) 58 (#f 59 (with-cps out #f)) 60 (ktail 61 (with-cps out 62 (letv prim rest) 63 (letk kresult ($kargs ('rest) (rest) 64 ($continue ktail src ($values ())))) 65 (letk kreceive ($kreceive '() 'rest kresult)) 66 (build-term ($continue kreceive src ,exp)))))))) 67 68(define (prune-bailouts conts) 69 (let ((tails (compute-tails conts))) 70 (with-fresh-name-state conts 71 (persistent-intmap 72 (intmap-fold 73 (lambda (label cont out) 74 (match cont 75 (($ $kargs names vars 76 ($ $continue k src 77 (and exp ($ $primcall (or 'error 'scm-error 'throw))))) 78 (call-with-values (lambda () (prune-bailout out tails k src exp)) 79 (lambda (out term) 80 (if term 81 (let ((cont (build-cont ($kargs names vars ,term)))) 82 (intmap-replace! out label cont)) 83 out)))) 84 (_ out))) 85 conts 86 conts))))) 87