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