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