Commit | Line | Data |
---|---|---|
dd692618 AW |
1 | ;;; Continuation-passing style (CPS) intermediate language (IL) |
2 | ||
3 | ;; Copyright (C) 2014 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 simple pass to prune unneeded top-level scopes. | |
22 | ;;; | |
23 | ;;; Code: | |
24 | ||
25 | (define-module (language cps prune-top-level-scopes) | |
26 | #:use-module (ice-9 match) | |
27 | #:use-module (language cps) | |
28 | #:export (prune-top-level-scopes)) | |
29 | ||
30 | (define (compute-referenced-scopes fun) | |
b7dc00b1 AW |
31 | (let ((scope-name->used? (make-hash-table)) |
32 | (scope-var->used? (make-hash-table)) | |
33 | (k->scope-var (make-hash-table))) | |
34 | ;; Visit uses before defs. That way we know when visiting defs | |
35 | ;; whether the scope is used or not. | |
dd692618 AW |
36 | (define (visit-cont cont) |
37 | (match cont | |
b7dc00b1 | 38 | (($ $cont k ($ $kargs (name) (var) body)) |
dd692618 | 39 | (visit-term body) |
b7dc00b1 AW |
40 | (when (hashq-get-handle scope-var->used? var) |
41 | (hashq-set! k->scope-var k var))) | |
dd692618 AW |
42 | (($ $cont k ($ $kargs names syms body)) |
43 | (visit-term body)) | |
24b611e8 | 44 | (($ $cont k ($ $kentry src meta self tail clause)) |
90dce16d AW |
45 | (when clause (visit-cont clause))) |
46 | (($ $cont k ($ $kclause arity body alternate)) | |
47 | (visit-cont body) | |
48 | (when alternate (visit-cont alternate))) | |
dd692618 AW |
49 | (($ $cont k (or ($ $kreceive) ($ $kif))) |
50 | #t))) | |
51 | (define (visit-term term) | |
52 | (match term | |
53 | (($ $letk conts body) | |
54 | (for-each visit-cont conts) | |
55 | (visit-term body)) | |
56 | (($ $letrec names syms funs body) | |
57 | (for-each visit-fun funs) | |
58 | (visit-term body)) | |
59 | (($ $continue k src exp) | |
60 | (match exp | |
61 | (($ $fun) (visit-fun exp)) | |
62 | (($ $primcall 'cached-toplevel-box (scope name bound?)) | |
b7dc00b1 | 63 | (hashq-set! scope-var->used? scope #t)) |
dd692618 | 64 | (($ $primcall 'cache-current-module! (module scope)) |
b7dc00b1 | 65 | (hashq-set! scope-var->used? scope #f)) |
dd692618 AW |
66 | (($ $const val) |
67 | ;; If there is an entry in the table for "k", it means "val" | |
68 | ;; is a scope symbol, bound for use by cached-toplevel-box | |
69 | ;; or cache-current-module!, or possibly both (though this | |
70 | ;; is not currently the case). | |
b7dc00b1 AW |
71 | (and=> (hashq-ref k->scope-var k) |
72 | (lambda (scope-var) | |
73 | (when (hashq-ref scope-var->used? scope-var) | |
dd692618 AW |
74 | ;; We have a use via cached-toplevel-box. Mark |
75 | ;; this scope as used. | |
b7dc00b1 AW |
76 | (hashq-set! scope-name->used? val #t)) |
77 | (when (and (hashq-ref scope-name->used? val) | |
78 | (not (hashq-ref scope-var->used? scope-var))) | |
dd692618 AW |
79 | ;; There is a use, and this sym is used by |
80 | ;; cache-current-module!. | |
b7dc00b1 | 81 | (hashq-set! scope-var->used? scope-var #t))))) |
dd692618 AW |
82 | (_ #t))))) |
83 | (define (visit-fun fun) | |
84 | (match fun | |
24b611e8 | 85 | (($ $fun free body) |
dd692618 AW |
86 | (visit-cont body)))) |
87 | ||
88 | (visit-fun fun) | |
b7dc00b1 | 89 | scope-var->used?)) |
dd692618 AW |
90 | |
91 | (define (prune-top-level-scopes fun) | |
b7dc00b1 | 92 | (let ((scope-var->used? (compute-referenced-scopes fun))) |
dd692618 AW |
93 | (define (visit-cont cont) |
94 | (rewrite-cps-cont cont | |
95 | (($ $cont sym ($ $kargs names syms body)) | |
96 | (sym ($kargs names syms ,(visit-term body)))) | |
24b611e8 AW |
97 | (($ $cont sym ($ $kentry src meta self tail clause)) |
98 | (sym ($kentry src meta self ,tail ,(and clause (visit-cont clause))))) | |
90dce16d AW |
99 | (($ $cont sym ($ $kclause arity body alternate)) |
100 | (sym ($kclause ,arity ,(visit-cont body) | |
101 | ,(and alternate (visit-cont alternate))))) | |
dd692618 AW |
102 | (($ $cont sym (or ($ $kreceive) ($ $kif))) |
103 | ,cont))) | |
104 | (define (visit-term term) | |
105 | (rewrite-cps-term term | |
106 | (($ $letk conts body) | |
107 | ($letk ,(map visit-cont conts) ,(visit-term body))) | |
108 | (($ $letrec names syms funs body) | |
109 | ($letrec names syms funs ,(visit-term body))) | |
110 | (($ $continue k src | |
111 | (and ($ $primcall 'cache-current-module! (module scope)) | |
112 | (? (lambda _ | |
b7dc00b1 | 113 | (not (hashq-ref scope-var->used? scope)))))) |
dd692618 AW |
114 | ($continue k src ($primcall 'values ()))) |
115 | (($ $continue) | |
116 | ,term))) | |
117 | (rewrite-cps-exp fun | |
24b611e8 AW |
118 | (($ $fun free body) |
119 | ($fun free ,(visit-cont body)))))) |