devirtualize-integers.scm 11 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272
  1. ;;; Continuation-passing style (CPS) intermediate language (IL)
  2. ;; Copyright (C) 2017-2021 Free Software Foundation, Inc.
  3. ;;;; This library is free software; you can redistribute it and/or
  4. ;;;; modify it under the terms of the GNU Lesser General Public
  5. ;;;; License as published by the Free Software Foundation; either
  6. ;;;; version 3 of the License, or (at your option) any later version.
  7. ;;;;
  8. ;;;; This library is distributed in the hope that it will be useful,
  9. ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  11. ;;;; Lesser General Public License for more details.
  12. ;;;;
  13. ;;;; You should have received a copy of the GNU Lesser General Public
  14. ;;;; License along with this library; if not, write to the Free Software
  15. ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  16. ;;; Commentary:
  17. ;;;
  18. ;;; Some parts of programs operate on exact integers. An exact integer
  19. ;;; is either a fixnum or a bignum. It's often the case that if we know
  20. ;;; that a number is a fixnum, all operations on it can be unboxed in
  21. ;;; terms of s64 operations. But if there's a series of operations and
  22. ;;; each one works on either bignums or fixnums, then the mixing of
  23. ;;; fixnums and bignums through that one control and data flow path
  24. ;;; makes it impossible for the compiler to specialize operations to
  25. ;;; either type.
  26. ;;;
  27. ;;; This "integer devirtualization" pass tries to duplicate the control
  28. ;;; and data flow of exact integers into two flows: one for bignums and
  29. ;;; one for fixnums. This causes code growth, so it's something we need
  30. ;;; to be careful about.
  31. ;;;
  32. ;;; Code:
  33. (define-module (language cps devirtualize-integers)
  34. #:use-module (ice-9 match)
  35. #:use-module (srfi srfi-1)
  36. #:use-module (language cps)
  37. #:use-module (language cps effects-analysis)
  38. #:use-module (language cps intmap)
  39. #:use-module (language cps intset)
  40. #:use-module (language cps utils)
  41. #:use-module (language cps with-cps)
  42. #:export (devirtualize-integers))
  43. ;; Compute a map from VAR -> COUNT, where COUNT indicates the number of
  44. ;; times in the source program that VAR is used.
  45. (define (compute-use-counts cps)
  46. (define (add-use use-counts var)
  47. (let ((count (1+ (intmap-ref use-counts var (lambda (_) 0)))))
  48. (intmap-add! use-counts var count (lambda (old new) new))))
  49. (define (add-uses use-counts vars)
  50. (match vars
  51. (() use-counts)
  52. ((var . vars) (add-uses (add-use use-counts var) vars))))
  53. (persistent-intmap
  54. (intmap-fold
  55. (lambda (label cont use-counts)
  56. (match cont
  57. (($ $kargs names vars term)
  58. (match term
  59. (($ $continue k src exp)
  60. (match exp
  61. ((or ($ $const) ($ $prim) ($ $fun) ($ $const-fun) ($ $code) ($ $rec))
  62. use-counts)
  63. (($ $values args)
  64. (add-uses use-counts args))
  65. (($ $call proc args)
  66. (add-uses (add-use use-counts proc) args))
  67. (($ $callk kfun proc args)
  68. (add-uses (if proc (add-use use-counts proc) use-counts) args))
  69. (($ $calli args callee)
  70. (add-use (add-uses use-counts args) callee))
  71. (($ $primcall name param args)
  72. (add-uses use-counts args))))
  73. (($ $branch kf kt src op param args)
  74. (add-uses use-counts args))
  75. (($ $switch kf kt* src arg)
  76. (add-use use-counts arg))
  77. (($ $prompt k kh src escape? tag)
  78. (add-use use-counts tag))
  79. (($ $throw src op param args)
  80. (add-uses use-counts args))))
  81. (_ use-counts)))
  82. cps
  83. (transient-intmap))))
  84. (define (bailout? cps label)
  85. (match (intmap-ref cps label)
  86. (($ $kargs _ _ ($ $throw)) #t)
  87. (_ #f)))
  88. (define (peel-trace cps label fx kexit use-counts)
  89. "For the graph starting at LABEL, try to peel out a trace that uses
  90. the variable FX. A peelable trace consists of effect-free terms, or
  91. terms that only have &type-check effect but which use FX or some
  92. variable that was defined using FX as an input. No variable defined in
  93. the trace should be referenced outside of it."
  94. (let peel-cont ((cps cps) (label label)
  95. (live-vars empty-intmap) ;; var -> pending refcount
  96. (fresh-vars empty-intmap) ;; old-name -> new name
  97. (vars-of-interest (intset-add empty-intset fx))
  98. (defs-of-interest? #f))
  99. (define (fail) (with-cps cps #f))
  100. (define (add-live-vars live-vars vars)
  101. (match vars
  102. (() live-vars)
  103. ((var . vars)
  104. (add-live-vars
  105. (let ((count (intmap-ref use-counts var (lambda (_) 0))))
  106. (if (zero? count)
  107. live-vars
  108. (intmap-add live-vars var count)))
  109. vars))))
  110. (define (subtract-uses live-vars vars)
  111. (match vars
  112. (() live-vars)
  113. ((var . vars)
  114. (subtract-uses
  115. (let ((count (intmap-ref live-vars var (lambda (_) #f))))
  116. (cond
  117. ((not count) live-vars)
  118. ((= count 1) (intmap-remove live-vars var))
  119. (else (intmap-replace live-vars var (1- count)))))
  120. vars))))
  121. (match (intmap-ref cps label)
  122. ;; We know the initial label is a $kargs, and we won't follow the
  123. ;; graph to get to $kreceive etc, so we can stop with these two
  124. ;; continuation kinds. (For our purposes, only $values can
  125. ;; continue to $ktail.)
  126. (($ $ktail) (fail))
  127. (($ $kargs names vars term)
  128. (let* ((vars-of-interest
  129. (if defs-of-interest?
  130. (fold1 (lambda (var set) (intset-add set var))
  131. vars vars-of-interest)
  132. vars-of-interest))
  133. (live-vars (add-live-vars live-vars vars))
  134. (fresh-vars (fold (lambda (var fresh-vars)
  135. (intmap-add fresh-vars var (fresh-var)))
  136. fresh-vars vars))
  137. (peeled-vars (map (lambda (var) (intmap-ref fresh-vars var))
  138. vars)))
  139. (define (rename-uses args)
  140. (map (lambda (arg) (intmap-ref fresh-vars arg (lambda (arg) arg)))
  141. args))
  142. (define (any-use-of-interest? args)
  143. (or-map (lambda (arg) (intset-ref vars-of-interest arg))
  144. args))
  145. (define (continue k live-vars defs-of-interest? can-terminate-trace?
  146. make-term)
  147. (define (stitch cps k)
  148. (with-cps cps
  149. (letk label* ($kargs names peeled-vars ,(make-term k)))
  150. label*))
  151. (define (terminate)
  152. (stitch cps k))
  153. (with-cps cps
  154. (let$ k* (peel-cont k live-vars fresh-vars vars-of-interest
  155. defs-of-interest?))
  156. ($ ((lambda (cps)
  157. (cond
  158. (k* (stitch cps k*))
  159. ((and can-terminate-trace? (eq? live-vars empty-intmap))
  160. (terminate))
  161. (else (fail))))))))
  162. (match term
  163. (($ $branch kf kt src op param args)
  164. ;; kt or k is kf; var of interest is in args
  165. (let* ((live-vars (subtract-uses live-vars args))
  166. (uses-of-interest? (any-use-of-interest? args))
  167. (defs-of-interest? #f) ;; Branches don't define values.
  168. (can-terminate-trace? uses-of-interest?)
  169. (peeled-args (rename-uses args)))
  170. (cond
  171. ((not uses-of-interest?)
  172. (fail))
  173. ((bailout? cps kt)
  174. (continue kf live-vars defs-of-interest? can-terminate-trace?
  175. (lambda (kf)
  176. (build-term
  177. ($branch kf kt src op param peeled-args)))))
  178. ((bailout? cps kf)
  179. (continue kt live-vars defs-of-interest? can-terminate-trace?
  180. (lambda (kt)
  181. (build-term
  182. ($branch kf kt src op param peeled-args)))))
  183. ((eq? live-vars empty-intmap)
  184. (with-cps cps
  185. (letk label*
  186. ($kargs names peeled-vars
  187. ($branch kf kt src op param peeled-args)))
  188. label*))
  189. (else
  190. (fail)))))
  191. (($ $switch)
  192. ;; Don't know how to peel past a switch. The arg of a
  193. ;; switch is unboxed anyway.
  194. (fail))
  195. (($ $continue k src exp)
  196. (match exp
  197. (($ $const)
  198. ;; fine.
  199. (continue k live-vars #f #f
  200. (lambda (k)
  201. (build-term ($continue k src ,exp)))))
  202. (($ $values args)
  203. (let ((uses-of-interest? (any-use-of-interest? args))
  204. (live-vars (subtract-uses live-vars args))
  205. (peeled-args (rename-uses args)))
  206. (continue k live-vars
  207. uses-of-interest? #f
  208. (lambda (k)
  209. (build-term
  210. ($continue k src ($values peeled-args)))))))
  211. (($ $primcall name param args)
  212. ;; exp is effect-free or var of interest in args
  213. (let* ((fx (expression-effects exp))
  214. (uses-of-interest? (any-use-of-interest? args))
  215. (live-vars (subtract-uses live-vars args))
  216. (peeled-args (rename-uses args)))
  217. ;; If the primcall uses a value of interest,
  218. ;; consider it for peeling even if it would cause a
  219. ;; type check; perhaps the peeling causes the type
  220. ;; check to go away.
  221. (if (or (eqv? fx &no-effects)
  222. (and uses-of-interest? (eqv? fx &type-check)))
  223. (continue k live-vars
  224. ;; Primcalls that use values of interest
  225. ;; define values of interest.
  226. uses-of-interest? #t
  227. (lambda (k)
  228. (build-term
  229. ($continue k src
  230. ($primcall name param ,peeled-args)))))
  231. (fail))))
  232. (_ (fail))))))))))
  233. (define (peel-traces-in-function cps body use-counts)
  234. (intset-fold
  235. (lambda (label cps)
  236. (match (intmap-ref cps label)
  237. ;; Traces start with a fixnum? predicate. We could expand this
  238. ;; in the future if we wanted to.
  239. (($ $kargs names vars ($ $branch kf kt src 'fixnum? #f (x)))
  240. (if (and (bailout? cps kf) #f)
  241. ;; Don't peel traces whose alternate is just a bailout.
  242. cps
  243. (with-cps cps
  244. (let$ kt (peel-trace kt x kf use-counts))
  245. ($ ((lambda (cps)
  246. (if kt
  247. (with-cps cps
  248. (setk label
  249. ($kargs names vars
  250. ($branch kf kt src 'fixnum? #f (x)))))
  251. cps)))))))
  252. (_ cps)))
  253. body
  254. cps))
  255. (define (devirtualize-integers cps)
  256. (let ((use-counts (compute-use-counts cps)))
  257. (with-fresh-name-state cps
  258. (intmap-fold
  259. (lambda (kfun body cps)
  260. (peel-traces-in-function cps body use-counts))
  261. (compute-reachable-functions cps)
  262. cps))))