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 self-references)
26 #:use-module (ice-9 match)
27 #:use-module (language cps)
28 #:export (resolve-self-references))
30 (define* (resolve-self-references fun #:optional (env '()))
32 (or (assq-ref env var) var))
34 (define (visit-cont cont)
35 (rewrite-cps-cont cont
36 (($ $cont label ($ $kargs names vars body))
37 (label ($kargs names vars ,(visit-term body))))
38 (($ $cont label ($ $kfun src meta self tail clause))
39 (label ($kfun src meta self ,tail
40 ,(and clause (visit-cont clause)))))
41 (($ $cont label ($ $kclause arity body alternate))
42 (label ($kclause ,arity ,(visit-cont body)
43 ,(and alternate (visit-cont alternate)))))
46 (define (visit-term term)
47 (rewrite-cps-term term
48 (($ $letrec names vars funs body)
49 ($letrec names vars (map visit-recursive-fun funs vars)
52 ($letk ,(map visit-cont conts)
54 (($ $continue k src exp)
55 ($continue k src ,(visit-exp exp)))))
57 (define (visit-exp exp)
59 ((or ($ $const) ($ $prim)) ,exp)
61 ($fun free ,(resolve-self-references body env)))
63 ($call (subst proc) ,(map subst args)))
64 (($ $callk k proc args)
65 ($callk k (subst proc) ,(map subst args)))
66 (($ $primcall name args)
67 ($primcall name ,(map subst args)))
69 ($branch k ,(visit-exp exp)))
71 ($values ,(map subst args)))
72 (($ $prompt escape? tag handler)
73 ($prompt escape? (subst tag) handler))))
75 (define (visit-recursive-fun fun var)
77 (($ $fun free (and cont ($ $cont _ ($ $kfun src meta self))))
78 ($fun free ,(resolve-self-references cont (acons var self env))))))