;;; Continuation-passing style (CPS) intermediate language (IL)
-;; Copyright (C) 2013 Free Software Foundation, Inc.
+;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
#:export (verify-cps))
(define (verify-cps fun)
- (define seen-gensyms (make-hash-table))
+ (define seen-labels (make-hash-table))
+ (define seen-vars (make-hash-table))
- (define (add sym env)
- (if (hashq-ref seen-gensyms sym)
- (error "duplicate gensym" sym)
- (begin
- (hashq-set! seen-gensyms sym #t)
- (cons sym env))))
+ (define (add sym seen env)
+ (when (hashq-ref seen sym)
+ (error "duplicate gensym" sym))
+ (hashq-set! seen sym #t)
+ (cons sym env))
- (define (add-env new env)
+ (define (add-env new seen env)
(if (null? new)
env
- (add-env (cdr new) (add (car new) env))))
+ (add-env (cdr new) seen (add (car new) seen env))))
- (define (check-var sym env)
+ (define (add-vars new env)
+ (unless (and-map exact-integer? new)
+ (error "bad vars" new))
+ (add-env new seen-vars env))
+
+ (define (add-labels new env)
+ (unless (and-map exact-integer? new)
+ (error "bad labels" new))
+ (add-env new seen-labels env))
+
+ (define (check-ref sym seen env)
(cond
- ((not (hashq-ref seen-gensyms sym))
+ ((not (hashq-ref seen sym))
(error "unbound lexical" sym))
((not (memq sym env))
(error "displaced lexical" sym))))
+ (define (check-label sym env)
+ (check-ref sym seen-labels env))
+
+ (define (check-var sym env)
+ (check-ref sym seen-vars env))
+
(define (check-src src)
(if (and src (not (and (list? src) (and-map pair? src)
(and-map symbol? (map car src)))))
(define (visit-cont-body cont k-env v-env)
(match cont
- (($ $kif kt kf)
- (check-var kt k-env)
- (check-var kf k-env))
- (($ $ktrunc ($ $arity ((? symbol?) ...) () (or #f (? symbol?)) () #f) k)
- (check-var k k-env))
- (($ $kargs ((? symbol? name) ...) ((? symbol? sym) ...) body)
+ (($ $kreceive ($ $arity ((? symbol?) ...) () (or #f (? symbol?)) () #f) k)
+ (check-label k k-env))
+ (($ $kargs (name ...) (sym ...) body)
(unless (= (length name) (length sym))
(error "name and sym lengths don't match" name sym))
- (visit-term body k-env (add-env sym v-env)))
+ (visit-term body k-env (add-vars sym v-env)))
(_
- ;; $kclause, $kentry, and $ktail are only ever seen in $fun.
+ ;; $kclause, $kfun, and $ktail are only ever seen in $fun.
(error "unexpected cont body" cont))))
(define (visit-clause clause k-env v-env)
(match clause
- (($ $cont kclause src*
+ (($ $cont kclause
($ $kclause
($ $arity
((? symbol? req) ...)
((? symbol? opt) ...)
(and rest (or #f (? symbol?)))
- (((? keyword? kw) (? symbol? kwname) (? symbol? kwsym)) ...)
+ (((? keyword? kw) (? symbol? kwname) kwsym) ...)
(or #f #t))
- ($ $cont kbody src (and body ($ $kargs names syms _)))))
- (check-src src*)
- (check-src src)
+ ($ $cont kbody (and body ($ $kargs names syms _)))
+ alternate))
(for-each (lambda (sym)
(unless (memq sym syms)
(error "bad keyword sym" sym)))
(unless (equal? (append req opt (if rest (list rest) '()) kwname)
names)
(error "clause body names do not match arity names" exp))
- (let ((k-env (add-env (list kclause kbody) k-env)))
- (visit-cont-body body k-env v-env)))
+ (let ((k-env (add-labels (list kclause kbody) k-env)))
+ (visit-cont-body body k-env v-env))
+ (when alternate
+ (visit-clause alternate k-env v-env)))
(_
(error "unexpected clause" clause))))
- (define (visit-fun fun k-env v-env)
- (match fun
- (($ $fun meta ((? symbol? free) ...)
- ($ $cont kbody src
- ($ $kentry (? symbol? self) ($ $cont ktail _ ($ $ktail)) clauses)))
+ (define (visit-entry entry k-env v-env)
+ (match entry
+ (($ $cont kbody
+ ($ $kfun src meta self ($ $cont ktail ($ $ktail)) clause))
(when (and meta (not (and (list? meta) (and-map pair? meta))))
(error "meta should be alist" meta))
- (for-each (cut check-var <> v-env) free)
(check-src src)
;; Reset the continuation environment, because Guile's
;; continuations are local.
- (let ((v-env (add-env (list self) v-env))
- (k-env (add-env (list ktail) '())))
- (for-each (cut visit-clause <> k-env v-env) clauses)))
+ (let ((v-env (add-vars (list self) v-env))
+ (k-env (add-labels (list ktail) '())))
+ (when clause
+ (visit-clause clause k-env v-env))))
+ (_ (error "unexpected $kfun" entry))))
+
+ (define (visit-fun fun k-env v-env)
+ (match fun
+ (($ $fun (free ...) entry)
+ (for-each (cut check-var <> v-env) free)
+ (visit-entry entry '() v-env))
(_
(error "unexpected $fun" fun))))
(define (visit-expression exp k-env v-env)
(match exp
- (($ $var sym)
- (check-var sym v-env))
- (($ $void)
- #t)
(($ $const val)
#t)
(($ $prim (? symbol? name))
#t)
+ (($ $closure kfun n)
+ #t)
(($ $fun)
(visit-fun exp k-env v-env))
- (($ $call (? symbol? proc) ((? symbol? arg) ...))
+ (($ $call proc (arg ...))
+ (check-var proc v-env)
+ (for-each (cut check-var <> v-env) arg))
+ (($ $callk k* proc (arg ...))
+ ;; We don't check that k* is in scope; it's actually inside some
+ ;; other function, probably. We rely on the transformation that
+ ;; introduces the $callk to be correct, and the linker to resolve
+ ;; the reference.
(check-var proc v-env)
(for-each (cut check-var <> v-env) arg))
- (($ $primcall (? symbol? name) ((? symbol? arg) ...))
+ (($ $branch kt ($ $primcall (? symbol? name) (arg ...)))
+ (check-var kt k-env)
+ (for-each (cut check-var <> v-env) arg))
+ (($ $branch kt ($ $values (arg ...)))
+ (check-var kt k-env)
+ (for-each (cut check-var <> v-env) arg))
+ (($ $primcall (? symbol? name) (arg ...))
(for-each (cut check-var <> v-env) arg))
- (($ $values ((? symbol? arg) ...))
+ (($ $values (arg ...))
(for-each (cut check-var <> v-env) arg))
- (($ $prompt escape? tag handler pop)
+ (($ $prompt escape? tag handler)
(unless (boolean? escape?) (error "escape? should be boolean" escape?))
(check-var tag v-env)
- (check-var handler k-env)
- (check-var pop k-env))
+ (check-label handler k-env))
(_
(error "unexpected expression" exp))))
(define (visit-term term k-env v-env)
(match term
- (($ $letk (($ $cont (? symbol? k) src cont) ...) body)
- (let ((k-env (add-env k k-env)))
- (for-each check-src src)
+ (($ $letk (($ $cont k cont) ...) body)
+ (let ((k-env (add-labels k k-env)))
(for-each (cut visit-cont-body <> k-env v-env) cont)
(visit-term body k-env v-env)))
- (($ $letrec ((? symbol? name) ...) ((? symbol? sym) ...) (fun ...) body)
+ (($ $letrec (name ...) (sym ...) (fun ...) body)
(unless (= (length name) (length sym) (length fun))
(error "letrec syms, names, and funs not same length" term))
- (let ((v-env (add-env sym v-env)))
+ (let ((v-env (add-vars sym v-env)))
(for-each (cut visit-fun <> k-env v-env) fun)
(visit-term body k-env v-env)))
- (($ $continue k exp)
- (check-var k k-env)
+ (($ $continue k src exp)
+ (check-label k k-env)
+ (check-src src)
(visit-expression exp k-env v-env))
(_
(error "unexpected term" term))))
- (visit-fun fun '() '())
+ (visit-entry fun '() '())
fun)
HCoop / bpt / guile.git / blobdiff