1;;; Diagnostic checker for CPS
2;;; Copyright (C) 2014, 2015 Free Software Foundation, Inc.
3;;;
4;;; This library is free software: you can redistribute it and/or modify
5;;; it under the terms of the GNU Lesser General Public License as
6;;; published by the Free Software Foundation, either version 3 of the
7;;; License, or (at your option) any later version.
8;;;
9;;; This library is distributed in the hope that it will be useful, but
10;;; WITHOUT ANY WARRANTY; without even the implied warranty of
11;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
12;;; Lesser General Public License for more details.
13;;;
14;;; You should have received a copy of the GNU Lesser General Public
15;;; License along with this program.  If not, see
16;;; <http://www.gnu.org/licenses/>.
17
18;;; Commentary:
19;;;
20;;; A routine to detect invalid CPS.
21;;;
22;;; Code:
23
24(define-module (language cps verify)
25  #:use-module (ice-9 match)
26  #:use-module (language cps)
27  #:use-module (language cps utils)
28  #:use-module (language cps intmap)
29  #:use-module (language cps intset)
30  #:use-module (language cps primitives)
31  #:use-module (srfi srfi-11)
32  #:export (verify))
33
34(define (intset-pop set)
35  (match (intset-next set)
36    (#f (values set #f))
37    (i (values (intset-remove set i) i))))
38
39(define-syntax-rule (make-worklist-folder* seed ...)
40  (lambda (f worklist seed ...)
41    (let lp ((worklist worklist) (seed seed) ...)
42      (call-with-values (lambda () (intset-pop worklist))
43        (lambda (worklist i)
44          (if i
45              (call-with-values (lambda () (f i seed ...))
46                (lambda (i* seed ...)
47                  (let add ((i* i*) (worklist worklist))
48                    (match i*
49                      (() (lp worklist seed ...))
50                      ((i . i*) (add i* (intset-add worklist i)))))))
51              (values seed ...)))))))
52
53(define worklist-fold*
54  (case-lambda
55    ((f worklist seed)
56     ((make-worklist-folder* seed) f worklist seed))))
57
58(define (check-distinct-vars conts)
59  (define (adjoin-def var seen)
60    (when (intset-ref seen var)
61      (error "duplicate var name" seen var))
62    (intset-add seen var))
63  (intmap-fold
64   (lambda (label cont seen)
65     (match (intmap-ref conts label)
66       (($ $kargs names vars ($ $continue k src exp))
67        (fold1 adjoin-def vars seen))
68       (($ $kfun src meta self tail clause)
69        (adjoin-def self seen))
70       (_ seen))
71     )
72   conts
73   empty-intset))
74
75(define (compute-available-definitions conts kfun)
76  "Compute and return a map of LABEL->VAR..., where VAR... are the
77definitions that are available at LABEL."
78  (define (adjoin-def var defs)
79    (when (intset-ref defs var)
80      (error "var already present in defs" defs var))
81    (intset-add defs var))
82
83  (define (propagate defs succ out)
84    (let* ((in (intmap-ref defs succ (lambda (_) #f)))
85           (in* (if in (intset-intersect in out) out)))
86      (if (eq? in in*)
87          (values '() defs)
88          (values (list succ)
89                  (intmap-add defs succ in* (lambda (old new) new))))))
90
91  (define (visit-cont label defs)
92    (let ((in (intmap-ref defs label)))
93      (define (propagate0 out)
94        (values '() defs))
95      (define (propagate1 succ out)
96        (propagate defs succ out))
97      (define (propagate2 succ0 succ1 out)
98        (let*-values (((changed0 defs) (propagate defs succ0 out))
99                      ((changed1 defs) (propagate defs succ1 out)))
100          (values (append changed0 changed1) defs)))
101
102      (match (intmap-ref conts label)
103        (($ $kargs names vars ($ $continue k src exp))
104         (let ((out (fold1 adjoin-def vars in)))
105           (match exp
106             (($ $branch kt) (propagate2 k kt out))
107             (($ $prompt escape? tag handler) (propagate2 k handler out))
108             (_ (propagate1 k out)))))
109        (($ $kreceive arity k)
110         (propagate1 k in))
111        (($ $kfun src meta self tail clause)
112         (let ((out (adjoin-def self in)))
113           (if clause
114               (propagate1 clause out)
115               (propagate0 out))))
116        (($ $kclause arity kbody kalt)
117         (if kalt
118             (propagate2 kbody kalt in)
119             (propagate1 kbody in)))
120        (($ $ktail) (propagate0 in)))))
121
122  (worklist-fold* visit-cont
123                  (intset kfun)
124                  (intmap-add empty-intmap kfun empty-intset)))
125
126(define (intmap-for-each f map)
127  (intmap-fold (lambda (k v seed) (f k v) seed) map *unspecified*))
128
129(define (check-valid-var-uses conts kfun)
130  (define (adjoin-def var defs) (intset-add defs var))
131  (let visit-fun ((kfun kfun) (free empty-intset) (first-order empty-intset))
132    (define (visit-exp exp bound first-order)
133      (define (check-use var)
134        (unless (intset-ref bound var)
135          (error "unbound var" var)))
136      (define (visit-first-order kfun)
137        (if (intset-ref first-order kfun)
138            first-order
139            (visit-fun kfun empty-intset (intset-add first-order kfun))))
140      (match exp
141        ((or ($ $const) ($ $prim)) first-order)
142        ;; todo: $closure
143        (($ $fun kfun)
144         (visit-fun kfun bound first-order))
145        (($ $closure kfun)
146         (visit-first-order kfun))
147        (($ $rec names vars (($ $fun kfuns) ...))
148         (let ((bound (fold1 adjoin-def vars bound)))
149           (fold1 (lambda (kfun first-order)
150                   (visit-fun kfun bound first-order))
151                  kfuns first-order)))
152        (($ $values args)
153         (for-each check-use args)
154         first-order)
155        (($ $call proc args)
156         (check-use proc)
157         (for-each check-use args)
158         first-order)
159        (($ $callk kfun proc args)
160         (check-use proc)
161         (for-each check-use args)
162         (visit-first-order kfun))
163        (($ $branch kt ($ $values (arg)))
164         (check-use arg)
165         first-order)
166        (($ $branch kt ($ $primcall name args))
167         (for-each check-use args)
168         first-order)
169        (($ $primcall name args)
170         (for-each check-use args)
171         first-order)
172        (($ $prompt escape? tag handler)
173         (check-use tag)
174         first-order)))
175    (intmap-fold
176     (lambda (label bound first-order)
177       (let ((bound (intset-union free bound)))
178         (match (intmap-ref conts label)
179           (($ $kargs names vars ($ $continue k src exp))
180            (visit-exp exp (fold1 adjoin-def vars bound) first-order))
181           (_ first-order))))
182     (compute-available-definitions conts kfun)
183     first-order)))
184
185(define (check-label-partition conts kfun)
186  ;; A continuation can only belong to one function.
187  (intmap-fold
188   (lambda (kfun body seen)
189     (intset-fold
190      (lambda (label seen)
191        (intmap-add seen label kfun
192                    (lambda (old new)
193                      (error "label used by two functions" label old new))))
194      body
195      seen))
196   (compute-reachable-functions conts kfun)
197   empty-intmap))
198
199(define (compute-reachable-labels conts kfun)
200  (intmap-fold (lambda (kfun body seen) (intset-union seen body))
201               (compute-reachable-functions conts kfun)
202               empty-intset))
203
204(define (check-arities conts kfun)
205  (define (check-arity exp cont)
206    (define (assert-unary)
207      (match cont
208        (($ $kargs (_) (_)) #t)
209        (_ (error "expected unary continuation" cont))))
210    (define (assert-nullary)
211      (match cont
212        (($ $kargs () ()) #t)
213        (_ (error "expected unary continuation" cont))))
214    (define (assert-n-ary n)
215      (match cont
216        (($ $kargs names vars)
217         (unless (= (length vars) n)
218           (error "expected n-ary continuation" n cont)))
219        (_ (error "expected $kargs continuation" cont))))
220    (define (assert-kreceive-or-ktail)
221      (match cont
222        ((or ($ $kreceive) ($ $ktail)) #t)
223        (_ (error "expected $kreceive or $ktail continuation" cont))))
224    (match exp
225      ((or ($ $const) ($ $prim) ($ $closure) ($ $fun))
226       (assert-unary))
227      (($ $rec names vars funs)
228       (unless (= (length names) (length vars) (length funs))
229         (error "invalid $rec" exp))
230       (assert-n-ary (length names))
231       (match cont
232         (($ $kargs names vars*)
233          (unless (equal? vars* vars)
234            (error "bound variable mismatch" vars vars*)))))
235      (($ $values args)
236       (match cont
237         (($ $ktail) #t)
238         (_ (assert-n-ary (length args)))))
239      (($ $call proc args)
240       (assert-kreceive-or-ktail))
241      (($ $callk k proc args)
242       (assert-kreceive-or-ktail))
243      (($ $branch kt exp)
244       (assert-nullary)
245       (match (intmap-ref conts kt)
246         (($ $kargs () ()) #t)
247         (cont (error "bad kt" cont))))
248      (($ $primcall name args)
249       (match cont
250         (($ $kargs names)
251          (match (prim-arity name)
252            ((out . in)
253             (unless (= in (length args))
254               (error "bad arity to primcall" name args in))
255             (unless (= out (length names))
256               (error "bad return arity from primcall" name names out)))))
257         (($ $kreceive)
258          (when (false-if-exception (prim-arity name))
259            (error "primitive should continue to $kargs, not $kreceive" name)))
260         (($ $ktail)
261          (error "primitive should continue to $kargs, not $ktail" name))))
262      (($ $prompt escape? tag handler)
263       (assert-nullary)
264       (match (intmap-ref conts handler)
265         (($ $kreceive) #t)
266         (cont (error "bad handler" cont))))))
267  (let ((reachable (compute-reachable-labels conts kfun)))
268    (intmap-for-each
269     (lambda (label cont)
270       (when (intset-ref reachable label)
271         (match cont
272           (($ $kargs names vars ($ $continue k src exp))
273            (unless (= (length names) (length vars))
274              (error "broken $kargs" label names vars))
275            (check-arity exp (intmap-ref conts k)))
276           (_ #t))))
277     conts)))
278
279(define (check-functions-bound-once conts kfun)
280  (let ((reachable (compute-reachable-labels conts kfun)))
281    (define (add-fun fun functions)
282      (when (intset-ref functions fun)
283        (error "function already bound" fun))
284      (intset-add functions fun))
285    (intmap-fold
286     (lambda (label cont functions)
287       (if (intset-ref reachable label)
288           (match cont
289             (($ $kargs _ _ ($ $continue _ _ ($ $fun kfun)))
290              (add-fun kfun functions))
291             (($ $kargs _ _ ($ $continue _ _ ($ $rec _ _ (($ $fun kfuns) ...))))
292              (fold1 add-fun kfuns functions))
293             (_ functions))
294           functions))
295     conts
296     empty-intset)))
297
298(define (verify conts)
299  (check-distinct-vars conts)
300  (check-label-partition conts 0)
301  (check-valid-var-uses conts 0)
302  (check-arities conts 0)
303  (check-functions-bound-once conts 0)
304  conts)
305