node-check.scm 6.4 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195
  1. ;;; Ported from Scheme 48 1.9. See file COPYING for notices and license.
  2. ;;;
  3. ;;; Port Author: Andrew Whatson
  4. ;;;
  5. ;;; Original Authors: Mike Sperber
  6. ;;;
  7. ;;; scheme48-1.9.2/ps-compiler/node/node-check.scm
  8. ;;;
  9. ;;; Check that a node is well-formed
  10. (define-module (ps-compiler node node-check)
  11. #:use-module (prescheme scheme48)
  12. #:use-module (ps-compiler node node)
  13. #:use-module (ps-compiler node node-util)
  14. #:use-module (ps-compiler node primop)
  15. #:use-module (ps-compiler node variable)
  16. #:use-module (ps-compiler util util)
  17. #:export (check-node))
  18. (define (check-node node)
  19. (cond
  20. ((lambda-node? node)
  21. (check-lambda node))
  22. ((call-node? node)
  23. (check-call node))
  24. ((literal-node? node)
  25. (check-literal node))
  26. ((reference-node? node)
  27. (check-reference node))
  28. (else
  29. (assertion-violation 'check-node "unknown node type" node))))
  30. (define (check-lambda node)
  31. (if (not (memq (lambda-type node) '(cont proc jump)))
  32. (assertion-violation 'check-node "invalid lambda type" node))
  33. (if (and (eq? 'jump (lambda-type node))
  34. (not (memq (call-primop-id (node-parent node)) '(let letrec2))))
  35. (assertion-violation 'check-node "jump lambda must be bound by let or letrec2" node))
  36. (for-each (lambda (var)
  37. (set-variable-flag! var #t))
  38. (lambda-variables node))
  39. (let ((body (lambda-body node)))
  40. (if (not (call-node? body))
  41. (assertion-violation 'check-node "lambda body is not a call" node))
  42. (if (trivial-primop-call? body)
  43. (assertion-violation 'check-node "body call of a lambda must have non-trivial primop" node))
  44. (check-nontrivial-primop-call body))
  45. (for-each (lambda (var)
  46. (set-variable-flag! var #f))
  47. (lambda-variables node)))
  48. (define (trivial-primop-call? node)
  49. (primop-trivial? (call-primop node)))
  50. (define (check-call node)
  51. (if (> (call-exits node) (call-arg-count node))
  52. (assertion-violation 'check-node "call node has more exits than arguments"))
  53. (if (trivial-primop-call? node)
  54. (check-trivial-primop-call node)
  55. (check-nontrivial-primop-call node)))
  56. (define (check-trivial-primop-call node)
  57. (walk-vector (lambda (arg)
  58. (if (not (yields-value? node))
  59. (assertion-violation 'check-node "argument to trivial-primop call must yield value" arg))
  60. (check-node arg))
  61. (call-args node)))
  62. (define (cont-lambda? node)
  63. (and (lambda-node? node)
  64. (eq? 'cont (lambda-type node))))
  65. (define (call-primop-id node)
  66. (primop-id (call-primop node)))
  67. (define (call-primop-name node)
  68. (symbol->string (primop-id (call-primop node))))
  69. ; check that first argument is a continuation variable
  70. (define (check-cont-var node)
  71. (if (positive? (call-exits node))
  72. (assertion-violation 'check-node
  73. (string-append (call-primop-name node)
  74. " node has non-zero exit count")
  75. node))
  76. (if (not (and (positive? (call-arg-count node))
  77. (reference-node? (call-arg node 0))))
  78. (assertion-violation 'check-node
  79. (string-append (call-primop-name node)
  80. " node must have cont var as first argument"
  81. (call-arg node 0)))))
  82. ; check that the call has single continuation
  83. (define (check-cont node)
  84. (if (not (= 1 (call-exits node)))
  85. (assertion-violation 'check-node
  86. (string-append (call-primop-name node)
  87. " node must have single continuation")
  88. node))
  89. (if (not (and (positive? (call-arg-count node))
  90. (cont-lambda? (call-arg node 0))))
  91. (assertion-violation 'check-node
  92. (string-append (symbol->string primop-id)
  93. " node must have cont lambda as first argument" (call-arg node 0)))))
  94. (define (check-nontrivial-primop-call node)
  95. (let ((exit-count (call-exits node))
  96. (arg-count (call-arg-count node))
  97. (primop-id (call-primop-id node)))
  98. (do ((i 0 (+ 1 i)))
  99. ((= i arg-count))
  100. (let ((arg (call-arg node i)))
  101. (cond
  102. ((< i exit-count)
  103. (if (not (cont-lambda? arg))
  104. (assertion-violation 'check-node "exit argument must be cont lambda" arg)))
  105. ((not (yields-value? arg))
  106. (assertion-violation 'check-node "regular call argument must yield value" arg)))
  107. (check-node arg)))
  108. (let ((check-proc-arg
  109. (lambda ()
  110. (if (< arg-count 2)
  111. (assertion-violation 'check-node "call node must have >=2 arguments" node)))))
  112. (case primop-id
  113. ((let)
  114. (check-cont node)
  115. (if (not (= (length (lambda-variables (call-arg node 0)))
  116. (- arg-count 1)))
  117. (assertion-violation 'check-node
  118. "variable and value count don't match up in let node" node)))
  119. ((letrec1)
  120. (check-cont node)
  121. (if (not (= 1 arg-count))
  122. (assertion-violation 'check-node
  123. "letrec1 node must have exactly 1 arg" node))
  124. (let* ((cont (call-arg node 0))
  125. (cont-args (lambda-variables cont))
  126. (cont-arg-count (length cont-args))
  127. (next (lambda-body cont)))
  128. (check-cont next)
  129. (if (not (eq? 'letrec2 (call-primop-id next)))
  130. (assertion-violation 'check-node
  131. "letrec1 node must be followed by letrec2 node" node))
  132. (if (zero? cont-arg-count)
  133. (assertion-violation 'check-node
  134. "letrec1 cont lambda must have at least one variable" node))
  135. (if (not (= cont-arg-count
  136. (- (call-arg-count next) 1)))
  137. (assertion-violation 'check-node
  138. "letrec1 and letrec2 nodes must have matching arity" node))
  139. (let ((var (car cont-args)))
  140. (if (not (= 1 (length (variable-refs var))))
  141. (assertion-violation 'check-node
  142. "letrec id variable must have exactly one reference" node))
  143. (if (or (not (eq? next (node-parent (car (variable-refs var)))))
  144. (not (= 1 (node-index (car (variable-refs var))))))
  145. (assertion-violation 'check-node
  146. "letrec id binding invalid" node)))))
  147. ((call unknown-call)
  148. (check-proc-arg)
  149. (check-cont node))
  150. ((tail-call unknown-tail-call)
  151. (check-proc-arg)
  152. (check-cont-var node))
  153. ((return unknown-return)
  154. (check-cont-var node))
  155. ((jump)
  156. (check-cont-var node) ; sort of
  157. (let ((jump-target (get-lambda-value (call-arg node 0))))
  158. (if (not (eq? 'jump (lambda-type jump-target)))
  159. (assertion-violation 'check-node
  160. "jump must go to jump lambda"
  161. node jump-target))))))))
  162. (define (check-reference ref)
  163. (let ((var (reference-variable ref)))
  164. (if (and (variable-binder var)
  165. (not (variable-flag var)))
  166. (assertion-violation 'check-node
  167. "unbound variable reference" ref))))
  168. (define (check-literal node)
  169. (values)) ; nothing to check
  170. (define (yields-value? node)
  171. (or (lambda-node? node)
  172. (and (call-node? node)
  173. (trivial-primop-call? node))
  174. (literal-node? node)
  175. (reference-node? node)))