module/language/cps/verify.scm

   1 ;;; Continuation-passing style (CPS) intermediate language (IL)
   2
   3 ;; Copyright (C) 2013, 2014, 2015 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 ;;;
  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)
  31   (define seen-labels (make-hash-table))
  32   (define seen-vars (make-hash-table))
  33
  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))
  39
  40   (define (add-env new seen env)
  41     (if (null? new)
  42         env
  43         (add-env (cdr new) seen (add (car new) seen env))))
  44
  45   (define (add-vars new env)
  46     (unless (and-map exact-integer? new)
  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)
  56     (cond
  57      ((not (hashq-ref seen sym))
  58       (error "unbound lexical" sym))
  59      ((not (memq sym env))
  60       (error "displaced lexical" sym))))
  61
  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
  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
  75       (($ $kreceive ($ $arity ((? symbol?) ...) () (or #f (? symbol?)) () #f) k)
  76        (check-label k k-env))
  77       (($ $kargs (name ...) (sym ...) body)
  78        (unless (= (length name) (length sym))
  79          (error "name and sym lengths don't match" name sym))
  80        (visit-term body k-env (add-vars sym v-env)))
  81       (_
  82        ;; $kclause, $kfun, and $ktail are only ever seen in $fun.
  83        (error "unexpected cont body" cont))))
  84
  85   (define (visit-clause clause k-env v-env)
  86     (match clause
  87       (($ $cont kclause
  88           ($ $kclause
  89              ($ $arity
  90                 ((? symbol? req) ...)
  91                 ((? symbol? opt) ...)
  92                 (and rest (or #f (? symbol?)))
  93                 (((? keyword? kw) (? symbol? kwname) kwsym) ...)
  94                 (or #f #t))
  95              ($ $cont kbody (and body ($ $kargs names syms _)))
  96              alternate))
  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))
 106        (let ((k-env (add-labels (list kclause kbody) k-env)))
 107          (visit-cont-body body k-env v-env))
 108        (when alternate
 109          (visit-clause alternate k-env v-env)))
 110       (_
 111        (error "unexpected clause" clause))))
 112
 113   (define (visit-entry entry k-env v-env)
 114     (match entry
 115       (($ $cont kbody
 116           ($ $kfun src meta self ($ $cont ktail ($ $ktail)) clause))
 117        (when (and meta (not (and (list? meta) (and-map pair? meta))))
 118          (error "meta should be alist" meta))
 119        (check-src src)
 120        ;; Reset the continuation environment, because Guile's
 121        ;; continuations are local.
 122        (let ((v-env (add-vars (list self) v-env))
 123              (k-env (add-labels (list ktail) '())))
 124          (when clause
 125            (visit-clause clause k-env v-env))))
 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)
 132        (visit-entry entry '() v-env))
 133       (_
 134        (error "unexpected $fun" fun))))
 135
 136   (define (visit-expression exp k-env v-env)
 137     (match exp
 138       (($ $const val)
 139        #t)
 140       (($ $prim (? symbol? name))
 141        #t)
 142       (($ $closure kfun n)
 143        #t)
 144       (($ $fun)
 145        (visit-fun exp k-env v-env))
 146       (($ $call proc (arg ...))
 147        (check-var proc v-env)
 148        (for-each (cut check-var <> v-env) arg))
 149       (($ $callk k* proc (arg ...))
 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))
 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))
 162       (($ $primcall (? symbol? name) (arg ...))
 163        (for-each (cut check-var <> v-env) arg))
 164       (($ $values (arg ...))
 165        (for-each (cut check-var <> v-env) arg))
 166       (($ $prompt escape? tag handler)
 167        (unless (boolean? escape?) (error "escape? should be boolean" escape?))
 168        (check-var tag v-env)
 169        (check-label handler k-env))
 170       (_
 171        (error "unexpected expression" exp))))
 172
 173   (define (visit-term term k-env v-env)
 174     (match term
 175       (($ $letk (($ $cont k cont) ...) body)
 176        (let ((k-env (add-labels k k-env)))
 177          (for-each (cut visit-cont-body <> k-env v-env) cont)
 178          (visit-term body k-env v-env)))
 179
 180       (($ $letrec (name ...) (sym ...) (fun ...) body)
 181        (unless (= (length name) (length sym) (length fun))
 182          (error "letrec syms, names, and funs not same length" term))
 183        (let ((v-env (add-vars sym v-env)))
 184          (for-each (cut visit-fun <> k-env v-env) fun)
 185          (visit-term body k-env v-env)))
 186
 187       (($ $continue k src exp)
 188        (check-label k k-env)
 189        (check-src src)
 190        (visit-expression exp k-env v-env))
 191
 192       (_
 193        (error "unexpected term" term))))
 194
 195   (visit-entry fun '() '())
 196   fun)