123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195 |
- ;;; Ported from Scheme 48 1.9. See file COPYING for notices and license.
- ;;;
- ;;; Port Author: Andrew Whatson
- ;;;
- ;;; Original Authors: Mike Sperber
- ;;;
- ;;; scheme48-1.9.2/ps-compiler/node/node-check.scm
- ;;;
- ;;; Check that a node is well-formed
- (define-module (ps-compiler node node-check)
- #:use-module (prescheme scheme48)
- #:use-module (ps-compiler node node)
- #:use-module (ps-compiler node node-util)
- #:use-module (ps-compiler node primop)
- #:use-module (ps-compiler node variable)
- #:use-module (ps-compiler util util)
- #:export (check-node))
- (define (check-node node)
- (cond
- ((lambda-node? node)
- (check-lambda node))
- ((call-node? node)
- (check-call node))
- ((literal-node? node)
- (check-literal node))
- ((reference-node? node)
- (check-reference node))
- (else
- (assertion-violation 'check-node "unknown node type" node))))
- (define (check-lambda node)
- (if (not (memq (lambda-type node) '(cont proc jump)))
- (assertion-violation 'check-node "invalid lambda type" node))
- (if (and (eq? 'jump (lambda-type node))
- (not (memq (call-primop-id (node-parent node)) '(let letrec2))))
- (assertion-violation 'check-node "jump lambda must be bound by let or letrec2" node))
- (for-each (lambda (var)
- (set-variable-flag! var #t))
- (lambda-variables node))
- (let ((body (lambda-body node)))
- (if (not (call-node? body))
- (assertion-violation 'check-node "lambda body is not a call" node))
- (if (trivial-primop-call? body)
- (assertion-violation 'check-node "body call of a lambda must have non-trivial primop" node))
- (check-nontrivial-primop-call body))
- (for-each (lambda (var)
- (set-variable-flag! var #f))
- (lambda-variables node)))
- (define (trivial-primop-call? node)
- (primop-trivial? (call-primop node)))
- (define (check-call node)
- (if (> (call-exits node) (call-arg-count node))
- (assertion-violation 'check-node "call node has more exits than arguments"))
- (if (trivial-primop-call? node)
- (check-trivial-primop-call node)
- (check-nontrivial-primop-call node)))
- (define (check-trivial-primop-call node)
- (walk-vector (lambda (arg)
- (if (not (yields-value? node))
- (assertion-violation 'check-node "argument to trivial-primop call must yield value" arg))
- (check-node arg))
- (call-args node)))
- (define (cont-lambda? node)
- (and (lambda-node? node)
- (eq? 'cont (lambda-type node))))
- (define (call-primop-id node)
- (primop-id (call-primop node)))
- (define (call-primop-name node)
- (symbol->string (primop-id (call-primop node))))
- ; check that first argument is a continuation variable
- (define (check-cont-var node)
- (if (positive? (call-exits node))
- (assertion-violation 'check-node
- (string-append (call-primop-name node)
- " node has non-zero exit count")
- node))
- (if (not (and (positive? (call-arg-count node))
- (reference-node? (call-arg node 0))))
- (assertion-violation 'check-node
- (string-append (call-primop-name node)
- " node must have cont var as first argument"
- (call-arg node 0)))))
- ; check that the call has single continuation
- (define (check-cont node)
- (if (not (= 1 (call-exits node)))
- (assertion-violation 'check-node
- (string-append (call-primop-name node)
- " node must have single continuation")
- node))
- (if (not (and (positive? (call-arg-count node))
- (cont-lambda? (call-arg node 0))))
- (assertion-violation 'check-node
- (string-append (symbol->string primop-id)
- " node must have cont lambda as first argument" (call-arg node 0)))))
- (define (check-nontrivial-primop-call node)
- (let ((exit-count (call-exits node))
- (arg-count (call-arg-count node))
- (primop-id (call-primop-id node)))
- (do ((i 0 (+ 1 i)))
- ((= i arg-count))
- (let ((arg (call-arg node i)))
- (cond
- ((< i exit-count)
- (if (not (cont-lambda? arg))
- (assertion-violation 'check-node "exit argument must be cont lambda" arg)))
- ((not (yields-value? arg))
- (assertion-violation 'check-node "regular call argument must yield value" arg)))
- (check-node arg)))
- (let ((check-proc-arg
- (lambda ()
- (if (< arg-count 2)
- (assertion-violation 'check-node "call node must have >=2 arguments" node)))))
- (case primop-id
- ((let)
- (check-cont node)
- (if (not (= (length (lambda-variables (call-arg node 0)))
- (- arg-count 1)))
- (assertion-violation 'check-node
- "variable and value count don't match up in let node" node)))
- ((letrec1)
- (check-cont node)
- (if (not (= 1 arg-count))
- (assertion-violation 'check-node
- "letrec1 node must have exactly 1 arg" node))
- (let* ((cont (call-arg node 0))
- (cont-args (lambda-variables cont))
- (cont-arg-count (length cont-args))
- (next (lambda-body cont)))
- (check-cont next)
- (if (not (eq? 'letrec2 (call-primop-id next)))
- (assertion-violation 'check-node
- "letrec1 node must be followed by letrec2 node" node))
- (if (zero? cont-arg-count)
- (assertion-violation 'check-node
- "letrec1 cont lambda must have at least one variable" node))
- (if (not (= cont-arg-count
- (- (call-arg-count next) 1)))
- (assertion-violation 'check-node
- "letrec1 and letrec2 nodes must have matching arity" node))
- (let ((var (car cont-args)))
- (if (not (= 1 (length (variable-refs var))))
- (assertion-violation 'check-node
- "letrec id variable must have exactly one reference" node))
- (if (or (not (eq? next (node-parent (car (variable-refs var)))))
- (not (= 1 (node-index (car (variable-refs var))))))
- (assertion-violation 'check-node
- "letrec id binding invalid" node)))))
- ((call unknown-call)
- (check-proc-arg)
- (check-cont node))
- ((tail-call unknown-tail-call)
- (check-proc-arg)
- (check-cont-var node))
- ((return unknown-return)
- (check-cont-var node))
- ((jump)
- (check-cont-var node) ; sort of
- (let ((jump-target (get-lambda-value (call-arg node 0))))
- (if (not (eq? 'jump (lambda-type jump-target)))
- (assertion-violation 'check-node
- "jump must go to jump lambda"
- node jump-target))))))))
- (define (check-reference ref)
- (let ((var (reference-variable ref)))
- (if (and (variable-binder var)
- (not (variable-flag var)))
- (assertion-violation 'check-node
- "unbound variable reference" ref))))
- (define (check-literal node)
- (values)) ; nothing to check
- (define (yields-value? node)
- (or (lambda-node? node)
- (and (call-node? node)
- (trivial-primop-call? node))
- (literal-node? node)
- (reference-node? node)))
|