1 ;;; Continuation-passing style (CPS) intermediate language (IL)
3 ;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
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.
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.
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
21 ;;; A pass that prunes successors of expressions that bail out.
25 (define-module (language cps prune-bailouts)
26 #:use-module (ice-9 match)
27 #:use-module (language cps)
28 #:export (prune-bailouts))
30 (define (module-box src module name public? bound? val-proc)
31 (let-fresh (kbox) (module-sym name-sym public?-sym bound?-sym box)
33 ($letconst (('module module-sym module)
35 ('public? public?-sym public?)
36 ('bound? bound?-sym bound?))
37 ($letk ((kbox ($kargs ('box) (box) ,(val-proc box))))
39 ($primcall 'cached-module-box
40 (module-sym name-sym public?-sym bound?-sym))))))))
42 (define (primitive-ref name k src)
43 (module-box #f '(guile) name #f #t
46 ($continue k src ($primcall 'box-ref (box)))))))
48 (define (prune-bailouts* fun)
49 (define (visit-cont cont ktail)
50 (rewrite-cps-cont cont
51 (($ $cont label ($ $kargs names vars body))
52 (label ($kargs names vars ,(visit-term body ktail))))
53 (($ $cont label ($ $kfun src meta self tail clause))
54 (label ($kfun src meta self ,tail
55 ,(and clause (visit-cont clause ktail)))))
56 (($ $cont label ($ $kclause arity body alternate))
57 (label ($kclause ,arity ,(visit-cont body ktail)
58 ,(and alternate (visit-cont alternate ktail)))))
61 (define (visit-term term ktail)
62 (rewrite-cps-term term
64 ($letk ,(map (lambda (cont) (visit-cont cont ktail)) conts)
65 ,(visit-term body ktail)))
66 (($ $continue k src exp)
67 ,(visit-exp k src exp ktail))))
69 (define (visit-exp k src exp ktail)
71 (($ $fun) ($continue k src ,(visit-fun exp)))
72 (($ $rec names vars funs)
73 ($continue k src ($rec names vars (map visit-fun funs))))
74 (($ $primcall (and name (or 'error 'scm-error 'throw)) args)
76 (build-cps-term ($continue k src ,exp))
77 (let-fresh (kprim kresult kreceive) (prim rest)
79 ($letk ((kresult ($kargs ('rest) (rest)
80 ($continue ktail src ($values ()))))
81 (kreceive ($kreceive '() 'rest kresult))
82 (kprim ($kargs ('prim) (prim)
83 ($continue kreceive src
85 ,(primitive-ref name kprim src))))))
86 (_ ($continue k src ,exp))))
88 (define (visit-fun fun)
91 ($fun ,(prune-bailouts* body)))))
95 ($ $kfun src meta self ($ $cont ktail ($ $ktail)) clause))
96 (kfun ($kfun src meta self (ktail ($ktail))
97 ,(and clause (visit-cont clause ktail)))))))
99 (define (prune-bailouts fun)
100 (with-fresh-name-state fun
101 (prune-bailouts* fun)))