analyze.scm 8.2 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297
  1. ; Part of Scheme 48 1.9. See file COPYING for notices and license.
  2. ; Authors: Richard Kelsey, Jonathan Rees, Mike Sperber, Robert Ransom, Taylor Campbell
  3. ; Simple code analysis to determine whether it's a good idea to
  4. ; in-line calls to a given procedure.
  5. ; Hook into the byte code compiler.
  6. (set-optimizer! 'auto-integrate
  7. (lambda (forms package)
  8. (let ((out (current-noise-port)))
  9. (newline out)
  10. (display "Analyzing... " out) (force-output out)
  11. (let* ((forms (find-usages (map force-node forms) package))
  12. (names (analyze-forms forms package)))
  13. (cond ((not (null? names))
  14. (newline out)
  15. (display "Calls will be compiled in line: " out)
  16. (write (reverse names) out))
  17. (else
  18. (display "no in-line procedures" out)))
  19. (newline out)
  20. forms))))
  21. (define (analyze-forms scanned-nodes package)
  22. (let ((inlines '()))
  23. (for-each (lambda (node)
  24. (let ((lhs (analyze-form node package)))
  25. (if lhs
  26. (set! inlines (cons lhs inlines)))))
  27. scanned-nodes)
  28. inlines))
  29. (define (analyze-form node package) ;Return LHS iff calls will be inlined.
  30. (if (define-node? node)
  31. (let ((form (node-form node)))
  32. (let ((lhs (node-form (cadr form)))
  33. (rhs (caddr form)))
  34. (let ((type (package-lookup-type package lhs)))
  35. (if (variable-type? type)
  36. (require "not assigned" lhs #f)
  37. (let ((method (inlinable-rhs? rhs type package lhs)))
  38. (if method
  39. (begin (package-add-static! package lhs method)
  40. (if (transform? method)
  41. lhs
  42. #f))
  43. #f))))))
  44. #f))
  45. (define (inlinable-rhs? node type package lhs)
  46. (cond ((lambda-node? node)
  47. (if (simple-lambda? node lhs package)
  48. (make-inline-transform node type package lhs)
  49. #f))
  50. ((name-node? node)
  51. (let ((name (node-form node)))
  52. (if (and (require "symbol rhs" (list lhs name)
  53. (symbol? name))
  54. (require "rhs bound" (list lhs name)
  55. (binding? (package-lookup-type package name)))
  56. (require "rhs unassigned" (list lhs name)
  57. (not (variable-type? (package-lookup-type package name))))
  58. (require "definitely procedure" (list lhs name)
  59. (procedure-type? (package-lookup-type package name))))
  60. (make-inline-transform node type package lhs)
  61. #f)))
  62. ((loophole-node? node)
  63. (inlinable-rhs? (caddr (node-form node)) type package lhs))
  64. ;These should already be taken care of.
  65. ; ((primitive-procedure-node? node)
  66. ; (get-operator (cadr (node-form node))))
  67. (else
  68. #f)))
  69. ; We elect to integrate a procedure definition when
  70. ; 1. The procedure is not n-ary,
  71. ; 2. Every parameter is used exactly once and not assigned, and
  72. ; 3. The analysis phase says that the body is acceptable (see below).
  73. (define (simple-lambda? node id package)
  74. (let* ((exp (node-form node))
  75. (formals (cadr exp))
  76. (body (caddr exp))
  77. (var-nodes (normalize-formals formals)))
  78. (and (require "not n-ary" id
  79. (not (n-ary? formals)))
  80. (require "unique references" id
  81. (every (lambda (var-node)
  82. (let ((usage (node-ref var-node 'usage)))
  83. (and (= (usage-reference-count usage) 1)
  84. (= (usage-assignment-count usage) 0))))
  85. var-nodes))
  86. (require "good analysis" id
  87. (simple? (caddr exp) ret)))))
  88. ; --------------------
  89. ; SIMPLE? takes an alpha-converted expression and returns either
  90. ; - #f, meaning that the procedure in which the expression occurs
  91. ; has no chance of being fully inlinable, so we might as well give up,
  92. ; - #t, if there's no problem, or
  93. ; - 'empty, if there's no problem AND there are no lexical variable
  94. ; references at or below this node.
  95. ; Foul situations are:
  96. ; - complex quotations (we don't want to make multiple copies of them)
  97. ; - a LAMBDA occurs (too much overhead, presumably)
  98. ; - a call that is not to a primitive and not a tail call
  99. ; Main dispatch for analyzer
  100. ; The name node analyzer needs the node; all others can get by with the
  101. ; expression.
  102. (define (simple? node ret?)
  103. ((operator-table-ref analyzers (node-operator-id node))
  104. (if (name-node? node)
  105. node
  106. (node-form node))
  107. ret?))
  108. (define (simple-list? exp-list)
  109. (if (null? exp-list)
  110. 'empty
  111. (let ((s1 (simple? (car exp-list) no-ret)))
  112. (cond ((eq? s1 'empty)
  113. (simple-list? (cdr exp-list)))
  114. ((and s1
  115. (simple-list? (cdr exp-list)))
  116. #t)
  117. (else
  118. #f)))))
  119. ; Particular operators
  120. (define analyzers
  121. (make-operator-table (lambda (exp ret?)
  122. (simple-list? (cdr exp)))))
  123. (define (define-analyzer name proc)
  124. (operator-define! analyzers name #f proc))
  125. (define-analyzer 'literal
  126. (lambda (exp ret?)
  127. (if (require "repeatable literal" #f
  128. (simple-literal? exp))
  129. 'empty
  130. #f)))
  131. (define-analyzer 'unspecific
  132. (lambda (exp ret?)
  133. #t))
  134. ; It's too awkward to try to inline references to unbound variables.
  135. ; By special dispensation, this one analyzer receives the node instead of the
  136. ; expression. It needs the node to look up the binding record.
  137. (define-analyzer 'name
  138. (lambda (node ret?)
  139. ;; (if (node-ref node 'usage) #t 'empty)
  140. ;; ... (not (generated? exp)) ugh ...
  141. (not (eq? (node-ref node 'binding)
  142. 'unbound))))
  143. (define-analyzer 'quote
  144. (lambda (exp ret?)
  145. (if (require "repeatable quotation" #f
  146. (simple-literal? (cadr exp)))
  147. 'empty
  148. #f)))
  149. (define-analyzer 'lambda
  150. (lambda (exp ret?) #f))
  151. (define-analyzer 'letrec
  152. (lambda (exp ret?) #f))
  153. (define-analyzer 'letrec*
  154. (lambda (exp ret?) #f))
  155. (define-analyzer 'pure-letrec
  156. (lambda (exp ret?) #f))
  157. (define-analyzer 'lap
  158. (lambda (exp ret?) #f))
  159. ; SET! loses because we might move a variable reference past a SET! on the
  160. ; variable. This can't happen if the SET! is the last thing done.
  161. ; It's too awkward to try to inline references to unbound variables.
  162. (define-analyzer 'set!
  163. (lambda (exp ret?)
  164. (and ret?
  165. (not (eq? (node-ref (cadr exp) 'binding)
  166. 'unbound))
  167. (simple? (caddr exp) no-ret))))
  168. (define-analyzer 'loophole
  169. (lambda (exp ret?)
  170. (simple? (caddr exp) ret?)))
  171. ; Can't always fully in-line things like (lambda (a b c) (if a b c))
  172. (define-analyzer 'if
  173. (lambda (exp ret?)
  174. (and (eq? (simple? (caddr exp) ret?) 'empty)
  175. (eq? (simple? (cadddr exp) ret?) 'empty)
  176. (simple? (cadr exp) no-ret))))
  177. (define-analyzer 'begin
  178. (lambda (exp ret?)
  179. (let loop ((exps (cdr exp)))
  180. (if (null? (cdr exps))
  181. (if (simple? (car exps) ret?) #t #f)
  182. (and (simple? (car exps) no-ret)
  183. (loop (cdr exps)))))))
  184. (define-analyzer 'call
  185. (lambda (exp ret?)
  186. (let ((static (static-value (car exp))))
  187. (if (transform? static)
  188. (let ((new-node
  189. (apply-inline-transform static
  190. exp
  191. (node-form (car exp)))))
  192. (if (eq? new-node exp)
  193. (really-simple-call? exp ret?)
  194. (simple? new-node ret?)))
  195. (really-simple-call? exp ret?)))))
  196. (define (really-simple-call? exp ret?)
  197. (let ((proc (car exp)))
  198. (and (require "non-local non-tail call" proc
  199. (or (and ret? (simple? proc no-ret)) ;tail calls are ok
  200. (primitive-proc? proc))) ;as are calls to primitives
  201. (simple-list? exp))))
  202. ; Calls to primitives and lexically bound variables are okay.
  203. (define (primitive-proc? proc)
  204. (cond ((literal-node? proc)
  205. (primop? (node-form proc)))
  206. ((name-node? proc)
  207. (let ((binding (node-ref proc 'binding)))
  208. (and (binding? binding)
  209. (primop? (binding-static binding)))))
  210. (else
  211. #f)))
  212. (define no-ret #f)
  213. (define ret #t)
  214. (define (simple-literal? x) ;Things that TRANSPORT won't copy.
  215. (or (integer? x)
  216. (boolean? x)
  217. (null? x)
  218. (char? x)
  219. (symbol? x)))
  220. ; --------------------
  221. ; debugging hack
  222. (define (require reason id x)
  223. (if (and *debug?* (not x))
  224. (begin (write id)
  225. (display " lost because ")
  226. (display reason)
  227. (display " failed")
  228. (newline)))
  229. x)
  230. (define *debug?* #f)
  231. ; utility
  232. (define (package-lookup-type p name)
  233. (let ((probe (package-lookup p name)))
  234. (if (binding? probe)
  235. (binding-type probe)
  236. #f)))
  237. ;----------------
  238. ;(define (foo f p)
  239. ; (analyze-forms (alpha-forms (scan-file f p) p)))
  240. ;
  241. ;
  242. ;(define (tst e p)
  243. ; (inlinable-rhs? (alpha e p) #f))
  244. ;
  245. ;(define b (make-compiler-base))
  246. ;
  247. ;(define p (make-simple-package (list b) eval #f))
  248. ;
  249. ;; (define b-stuff (alpha-structure b))
  250. ;