Commit | Line | Data |
---|---|---|
80b01fd0 AW |
1 | ;;; Continuation-passing style (CPS) intermediate language (IL) |
2 | ||
15e4746f | 3 | ;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc. |
80b01fd0 AW |
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 | ;;; | |
22 | ;;; Code: | |
23 | ||
24 | (define-module (language cps verify) | |
25 | #:use-module (ice-9 match) | |
26 | #:use-module (srfi srfi-26) | |
27 | #:use-module (language cps) | |
28 | #:export (verify-cps)) | |
29 | ||
30 | (define (verify-cps fun) | |
39056a81 AW |
31 | (define seen-labels (make-hash-table)) |
32 | (define seen-vars (make-hash-table)) | |
80b01fd0 | 33 | |
39056a81 AW |
34 | (define (add sym seen env) |
35 | (when (hashq-ref seen sym) | |
36 | (error "duplicate gensym" sym)) | |
37 | (hashq-set! seen sym #t) | |
38 | (cons sym env)) | |
80b01fd0 | 39 | |
39056a81 | 40 | (define (add-env new seen env) |
80b01fd0 AW |
41 | (if (null? new) |
42 | env | |
90dce16d | 43 | (add-env (cdr new) seen (add (car new) seen env)))) |
80b01fd0 | 44 | |
39056a81 | 45 | (define (add-vars new env) |
eb60b413 | 46 | (unless (and-map exact-integer? new) |
39056a81 AW |
47 | (error "bad vars" new)) |
48 | (add-env new seen-vars env)) | |
49 | ||
50 | (define (add-labels new env) | |
51 | (unless (and-map exact-integer? new) | |
52 | (error "bad labels" new)) | |
53 | (add-env new seen-labels env)) | |
54 | ||
55 | (define (check-ref sym seen env) | |
80b01fd0 | 56 | (cond |
39056a81 | 57 | ((not (hashq-ref seen sym)) |
80b01fd0 AW |
58 | (error "unbound lexical" sym)) |
59 | ((not (memq sym env)) | |
60 | (error "displaced lexical" sym)))) | |
61 | ||
39056a81 AW |
62 | (define (check-label sym env) |
63 | (check-ref sym seen-labels env)) | |
64 | ||
65 | (define (check-var sym env) | |
66 | (check-ref sym seen-vars env)) | |
67 | ||
80b01fd0 AW |
68 | (define (check-src src) |
69 | (if (and src (not (and (list? src) (and-map pair? src) | |
70 | (and-map symbol? (map car src))))) | |
71 | (error "bad src"))) | |
72 | ||
73 | (define (visit-cont-body cont k-env v-env) | |
74 | (match cont | |
36527695 | 75 | (($ $kreceive ($ $arity ((? symbol?) ...) () (or #f (? symbol?)) () #f) k) |
39056a81 | 76 | (check-label k k-env)) |
b764157a | 77 | (($ $kargs (name ...) (sym ...) body) |
80b01fd0 AW |
78 | (unless (= (length name) (length sym)) |
79 | (error "name and sym lengths don't match" name sym)) | |
39056a81 | 80 | (visit-term body k-env (add-vars sym v-env))) |
80b01fd0 | 81 | (_ |
8320f504 | 82 | ;; $kclause, $kfun, and $ktail are only ever seen in $fun. |
80b01fd0 AW |
83 | (error "unexpected cont body" cont)))) |
84 | ||
85 | (define (visit-clause clause k-env v-env) | |
86 | (match clause | |
6e422a35 | 87 | (($ $cont kclause |
80b01fd0 AW |
88 | ($ $kclause |
89 | ($ $arity | |
90 | ((? symbol? req) ...) | |
91 | ((? symbol? opt) ...) | |
92 | (and rest (or #f (? symbol?))) | |
b764157a | 93 | (((? keyword? kw) (? symbol? kwname) kwsym) ...) |
80b01fd0 | 94 | (or #f #t)) |
90dce16d AW |
95 | ($ $cont kbody (and body ($ $kargs names syms _))) |
96 | alternate)) | |
80b01fd0 AW |
97 | (for-each (lambda (sym) |
98 | (unless (memq sym syms) | |
99 | (error "bad keyword sym" sym))) | |
100 | kwsym) | |
101 | ;; FIXME: It is technically possible for kw syms to alias other | |
102 | ;; syms. | |
103 | (unless (equal? (append req opt (if rest (list rest) '()) kwname) | |
104 | names) | |
105 | (error "clause body names do not match arity names" exp)) | |
39056a81 | 106 | (let ((k-env (add-labels (list kclause kbody) k-env))) |
90dce16d AW |
107 | (visit-cont-body body k-env v-env)) |
108 | (when alternate | |
109 | (visit-clause alternate k-env v-env))) | |
80b01fd0 AW |
110 | (_ |
111 | (error "unexpected clause" clause)))) | |
112 | ||
a2acec7c AW |
113 | (define (visit-entry entry k-env v-env) |
114 | (match entry | |
115 | (($ $cont kbody | |
116 | ($ $kfun src meta self ($ $cont ktail ($ $ktail)) clause)) | |
80b01fd0 AW |
117 | (when (and meta (not (and (list? meta) (and-map pair? meta)))) |
118 | (error "meta should be alist" meta)) | |
80b01fd0 AW |
119 | (check-src src) |
120 | ;; Reset the continuation environment, because Guile's | |
121 | ;; continuations are local. | |
39056a81 AW |
122 | (let ((v-env (add-vars (list self) v-env)) |
123 | (k-env (add-labels (list ktail) '()))) | |
90dce16d AW |
124 | (when clause |
125 | (visit-clause clause k-env v-env)))) | |
a2acec7c AW |
126 | (_ (error "unexpected $kfun" entry)))) |
127 | ||
128 | (define (visit-fun fun k-env v-env) | |
129 | (match fun | |
130 | (($ $fun (free ...) entry) | |
131 | (for-each (cut check-var <> v-env) free) | |
15e4746f | 132 | (visit-entry entry '() v-env)) |
80b01fd0 AW |
133 | (_ |
134 | (error "unexpected $fun" fun)))) | |
135 | ||
136 | (define (visit-expression exp k-env v-env) | |
137 | (match exp | |
80b01fd0 AW |
138 | (($ $const val) |
139 | #t) | |
140 | (($ $prim (? symbol? name)) | |
141 | #t) | |
a2acec7c AW |
142 | (($ $closure kfun n) |
143 | #t) | |
80b01fd0 | 144 | (($ $fun) |
25833e80 | 145 | (visit-fun exp k-env v-env)) |
b764157a | 146 | (($ $call proc (arg ...)) |
80b01fd0 AW |
147 | (check-var proc v-env) |
148 | (for-each (cut check-var <> v-env) arg)) | |
39056a81 | 149 | (($ $callk k* proc (arg ...)) |
b3ae2b50 AW |
150 | ;; We don't check that k* is in scope; it's actually inside some |
151 | ;; other function, probably. We rely on the transformation that | |
152 | ;; introduces the $callk to be correct, and the linker to resolve | |
153 | ;; the reference. | |
154 | (check-var proc v-env) | |
155 | (for-each (cut check-var <> v-env) arg)) | |
92805e21 AW |
156 | (($ $branch kt ($ $primcall (? symbol? name) (arg ...))) |
157 | (check-var kt k-env) | |
158 | (for-each (cut check-var <> v-env) arg)) | |
159 | (($ $branch kt ($ $values (arg ...))) | |
160 | (check-var kt k-env) | |
161 | (for-each (cut check-var <> v-env) arg)) | |
39056a81 | 162 | (($ $primcall (? symbol? name) (arg ...)) |
80b01fd0 | 163 | (for-each (cut check-var <> v-env) arg)) |
39056a81 | 164 | (($ $values (arg ...)) |
80b01fd0 | 165 | (for-each (cut check-var <> v-env) arg)) |
7ab76a83 | 166 | (($ $prompt escape? tag handler) |
80b01fd0 AW |
167 | (unless (boolean? escape?) (error "escape? should be boolean" escape?)) |
168 | (check-var tag v-env) | |
39056a81 | 169 | (check-label handler k-env)) |
80b01fd0 AW |
170 | (_ |
171 | (error "unexpected expression" exp)))) | |
172 | ||
173 | (define (visit-term term k-env v-env) | |
174 | (match term | |
39056a81 AW |
175 | (($ $letk (($ $cont k cont) ...) body) |
176 | (let ((k-env (add-labels k k-env))) | |
80b01fd0 AW |
177 | (for-each (cut visit-cont-body <> k-env v-env) cont) |
178 | (visit-term body k-env v-env))) | |
179 | ||
b764157a | 180 | (($ $letrec (name ...) (sym ...) (fun ...) body) |
80b01fd0 AW |
181 | (unless (= (length name) (length sym) (length fun)) |
182 | (error "letrec syms, names, and funs not same length" term)) | |
39056a81 | 183 | (let ((v-env (add-vars sym v-env))) |
80b01fd0 AW |
184 | (for-each (cut visit-fun <> k-env v-env) fun) |
185 | (visit-term body k-env v-env))) | |
186 | ||
6e422a35 | 187 | (($ $continue k src exp) |
39056a81 | 188 | (check-label k k-env) |
6e422a35 | 189 | (check-src src) |
80b01fd0 AW |
190 | (visit-expression exp k-env v-env)) |
191 | ||
192 | (_ | |
193 | (error "unexpected term" term)))) | |
194 | ||
a2acec7c | 195 | (visit-entry fun '() '()) |
80b01fd0 | 196 | fun) |