annotated-tree-il.scm 9.4 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235
  1. (define-module (analyzer annotated-tree-il)
  2. #:use-module (analyzer value-sets)
  3. #:use-module (analyzer set-queue)
  4. #:use-module (analyzer lexical-envs)
  5. #:use-module (ice-9 match)
  6. #:use-module (system base syntax)
  7. #:use-module (language tree-il)
  8. #:export (annotated-tree-il-src
  9. annotated-tree-il-parent
  10. annotated-tree-il-can-return?
  11. annotated-tree-il-return-value-set
  12. <a-void> a-void? make-a-void
  13. <a-const> a-const? make-a-const a-const-exp
  14. <a-primitive-ref> a-primitive-ref? a-primitive-ref-name
  15. <a-lexical-ref> a-lexical-ref? a-lexical-ref-name
  16. a-lexical-ref-gensym
  17. <a-lexical-set> a-lexical-set? a-lexical-set-target-value-set
  18. a-lexical-set-name a-lexical-set-gensym a-lexical-set-exp
  19. <a-module-ref> a-module-ref? a-module-ref-mod a-module-ref-name
  20. a-module-ref-public?
  21. <a-module-set> a-module-set? a-module-set-target-value-set
  22. a-module-set-mod a-module-set-name a-module-set-public?
  23. a-module-set-exp
  24. <a-toplevel-ref> a-toplevel-ref? a-toplevel-ref-name
  25. <a-toplevel-set> a-toplevel-set? a-toplevel-set-target-value-set
  26. a-toplevel-set-name a-toplevel-set-exp
  27. <a-toplevel-define> a-toplevel-define? a-toplevel-define-name
  28. a-toplevel-define-exp
  29. <a-conditional> a-conditional? a-conditional-test
  30. a-conditional-consequent a-conditional-alternate
  31. <a-call> a-call? a-call-proc a-call-args
  32. <a-seq> a-seq? a-seq-head a-seq-tail
  33. <a-lambda> a-lambda? a-lambda-meta a-lambda-body
  34. <a-lambda-case> a-lambda-case? a-lambda-case-req a-lambda-case-opt a-lambda-case-rest
  35. a-lambda-case-kw a-lambda-case-inits a-lambda-case-gensyms a-lambda-case-body
  36. a-lambda-case-alternate
  37. <a-let> a-let? a-let-names a-let-gensyms a-let-vals a-let-body
  38. <a-letrec> a-letrec? a-letrec-in-order? a-letrec-names
  39. a-letrec-gensyms a-letrec-vals a-letrec-body
  40. <a-dynlet> a-dynlet? a-dynlet-fluids a-dynlet-vals a-dynlet-body
  41. <a-dynref> a-dynref? a-dynref-fluid
  42. <a-dynset> a-dynset? a-dynset-target-value-set a-dynset-fluid
  43. a-dynset-exp
  44. <a-dynwind> a-dynwind? a-dynwind-winter a-dynwind-body
  45. a-dynwind-handler
  46. <a-prompt> a-prompt? a-prompt-tag a-prompt-body a-prompt-handler
  47. <a-abort> a-abort? a-abort-tag a-abort-args a-abort-tail
  48. <a-fix> a-fix? a-fix-names a-fix-gensyms a-fix-vals a-fix-body
  49. <a-let-values> a-let-values? a-let-values-exp a-let-values-body
  50. <a-verify> a-verify? a-verify-exps
  51. tree-il->annotated-tree-il!))
  52. #|
  53. The src slot is the same as for regular tree-il. The value-set slot
  54. points to the value-set of this expression's return value.
  55. |#
  56. (define-type (<annotated-tree-il>
  57. #:common-slots (src parent can-return? return-value-set))
  58. ;; to do: add printer
  59. (<a-void>)
  60. (<a-const> exp)
  61. (<a-primitive-ref> name)
  62. (<a-lexical-ref> name gensym)
  63. (<a-lexical-set> target-value-set
  64. name gensym exp)
  65. (<a-module-ref> mod name public?)
  66. (<a-module-set> target-value-set
  67. mod name public? exp)
  68. (<a-toplevel-ref> name)
  69. (<a-toplevel-set> target-value-set
  70. name exp)
  71. (<a-toplevel-define> name exp)
  72. (<a-conditional> test consequent alternate)
  73. (<a-call> proc args)
  74. (<a-seq> head tail)
  75. (<a-lambda> meta body)
  76. (<a-lambda-case> req opt rest kw inits gensyms body alternate)
  77. (<a-let> names gensyms vals body)
  78. (<a-letrec> in-order? names gensyms vals body)
  79. (<a-dynlet> fluids vals body)
  80. (<a-dynref> fluid)
  81. (<a-dynset> target-value-set fluid exp)
  82. (<a-dynwind> winder body unwinder)
  83. (<a-prompt> tag body handler)
  84. (<a-abort> tag args tail)
  85. (<a-fix> names gensyms vals body)
  86. (<a-let-values> exp body)
  87. (<a-verify> exps))
  88. ;; this procedure
  89. ;; - converts tree-il to annotated tree-il.
  90. ;; - annotates nodes with their parents.
  91. ;; - annotates references and sets with the value-sets they use.
  92. ;; (it creates value-set objects, but doesn't do inference)
  93. ;; - adds verify nodes to verifies, a variable object holding a list
  94. ;; - calls leaf-func on nodes that already have values (const nodes),
  95. ;; after annotated with parents and value sets
  96. (define (tree-il->annotated-tree-il! tree-il toplevel-env verifies leaf-func)
  97. (let rec ((parent #f)
  98. (tree tree-il)
  99. (env toplevel-env))
  100. (match tree
  101. (($ <void> src)
  102. (error "No voids yet!"))
  103. (($ <const> src exp)
  104. (let ((ret
  105. (make-a-const src parent
  106. #t ; can-return?
  107. (value-set-with-values exp) ; return-value-set
  108. exp
  109. )))
  110. (leaf-func ret)
  111. ret))
  112. (($ <primitive-ref> src name)
  113. (error "No primitive-refs yet!"))
  114. (($ <lexical-ref> src name gensym)
  115. (make-a-lexical-ref src parent
  116. #t ; can-return?
  117. (annotated-tree-il-return-value-set
  118. (environment-lookup env gensym)) ; return-value-set
  119. name gensym))
  120. (($ <lexical-set> src name gensym exp)
  121. (error "No lexical sets yet!"))
  122. (($ <module-ref> src mod name public?)
  123. (error "No module-ref yet!"))
  124. (($ <module-set> src mod name public? exp)
  125. (error "No module-set yet!"))
  126. (($ <toplevel-ref> src name)
  127. (make-a-toplevel-ref src parent
  128. #t ; can-return?
  129. (environment-lookup env name) ; return-value-set
  130. name))
  131. (($ <toplevel-set> src name exp)
  132. (error "No toplevel sets yet!"))
  133. (($ <toplevel-define> src name exp)
  134. (error "No top level defines yet!"))
  135. ;; don't need to put this in the *newly-set-value* list
  136. ;; because it will be put there once the leaves in its
  137. ;; definition have propagated a definition up to the top
  138. ;; level. until that happens we don't know enough to infer
  139. ;; anything interesting anyway.
  140. (($ <conditional> src test consequent alternate)
  141. (error "No conditionals yet!"))
  142. (($ <call> src ($ <toplevel-ref> tsrc 'verify) args)
  143. (let ((ret (make-a-verify src parent
  144. #f ; can-return?
  145. (value-set-nothing) ; return-value-se
  146. '())))
  147. (set! (a-verify-exps ret)
  148. (map (lambda (x) (rec ret x env)) args))
  149. (variable-set! verifies
  150. (cons ret (variable-ref verifies)))
  151. ret))
  152. (($ <call> src proc args)
  153. (let ((ret (make-a-call src parent
  154. #t ; can-return?
  155. (value-set-nothing) ; return-value-set
  156. #f '())))
  157. (set! (a-call-proc ret) (rec ret proc env))
  158. (set! (a-call-args ret) (map (lambda (x) (rec ret x env)) args))
  159. ret))
  160. (($ <primcall> src name args)
  161. (error "No primcalls!"))
  162. ;; To do: rewrite primcalls as (call (primitive-ref ...) ...)
  163. (($ <seq> src head tail)
  164. (error "No seqs yet!"))
  165. (($ <lambda> src meta body)
  166. (error "No lambdas yet!"))
  167. (($ <lambda-case> src req opt rest kw inits gensyms body alternate)
  168. (error "No lambda-case right now!"))
  169. (($ <let> src names gensyms vals body)
  170. (let ((ret (make-a-let src parent
  171. #t ; can-return?
  172. #f ; return-value-set
  173. names gensyms
  174. '() '())))
  175. (set! (a-let-vals ret) (map (lambda (x) (rec ret x env)) vals))
  176. (set! (a-let-body ret)
  177. (rec ret body
  178. (environment-append-names-values env
  179. gensyms
  180. (a-let-vals ret))))
  181. (set! (annotated-tree-il-return-value-set ret)
  182. (annotated-tree-il-return-value-set (a-let-body ret)))
  183. ret))
  184. (($ <letrec> src in-order? names gensyms vals body)
  185. (error "No letrecs yet!"))
  186. (($ <dynlet> src fluids vals body)
  187. (error "No dynlet yet!"))
  188. (($ <dynref> src fluid)
  189. (error "No dynref yet!"))
  190. (($ <dynset> src fluid exp)
  191. (error "No dynset yet!"))
  192. (($ <dynwind> src winder body unwinder)
  193. (error "No dynwind yet!"))
  194. (($ <prompt> src tag body handler)
  195. (error "No prompt yet!"))
  196. (($ <abort> src tag args tail)
  197. (error "No abort yet!"))
  198. (($ <let-values> src names gensyms exp body)
  199. (error "No let-values yet!"))
  200. (($ <fix> src names gensyms vals body)
  201. (error "No fix yet!"))
  202. )))