specialize-numbers.scm 44 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065
  1. ;;; Continuation-passing style (CPS) intermediate language (IL)
  2. ;; Copyright (C) 2015-2021, 2023 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 arithmetic operations have multiple implementations: one
  19. ;;; polymorphic implementation that works on all kinds of numbers, like
  20. ;;; `add', and one or more specialized variants for unboxed numbers of
  21. ;;; some kind, like `fadd'. If we can replace a polymorphic
  22. ;;; implementation with a monomorphic implementation, we should do so --
  23. ;;; it will speed up the runtime and avoid boxing numbers.
  24. ;;;
  25. ;;; A polymorphic operation can be specialized if its result is
  26. ;;; specialized. To specialize an operation, we manually unbox its
  27. ;;; arguments and box its return value, relying on CSE to remove boxes
  28. ;;; where possible.
  29. ;;;
  30. ;;; We also want to specialize phi variables. A phi variable is bound
  31. ;;; by a continuation with more than one predecessor. For example in
  32. ;;; this code:
  33. ;;;
  34. ;;; (+ 1.0 (if a 2.0 3.0))
  35. ;;;
  36. ;;; We want to specialize this code to:
  37. ;;;
  38. ;;; (f64->scm (fl+ (scm->f64 1.0) (if a (scm->f64 2.0) (scm->f64 3.0))))
  39. ;;;
  40. ;;; Hopefully later passes will remove the conversions. In any case,
  41. ;;; specialization will likely result in a lower heap-number allocation
  42. ;;; rate, and that cost is higher than the extra opcodes to do
  43. ;;; conversions. This transformation is especially important for loop
  44. ;;; variables.
  45. ;;;
  46. ;;; Code:
  47. (define-module (language cps specialize-numbers)
  48. #:use-module (ice-9 match)
  49. #:use-module (srfi srfi-1)
  50. #:use-module (srfi srfi-11)
  51. #:use-module (system base target)
  52. #:use-module (language cps)
  53. #:use-module (language cps intmap)
  54. #:use-module (language cps intset)
  55. #:use-module (language cps renumber)
  56. #:use-module (language cps types)
  57. #:use-module (language cps utils)
  58. #:use-module (language cps with-cps)
  59. #:export (specialize-numbers))
  60. ;; A note on how to represent unboxing and boxing operations. We want
  61. ;; to avoid diamond control flows here, like:
  62. ;;
  63. ;; s64 x = (if (fixnum? x*) (untag-fixnum x*) (untag-bignum x*))
  64. ;;
  65. ;; The reason is that the strategy that this specialize-numbers pass
  66. ;; uses to unbox values is to reify unboxing and boxing conversions
  67. ;; around every newly reified unboxed operation; it then relies heavily
  68. ;; on DCE and CSE to remove redundant conversions. However DCE and CSE
  69. ;; really work best when there's a linear control flow, so instead we
  70. ;; use a mid-level primcall:
  71. ;;
  72. ;; (define (scm->s64 x*)
  73. ;; (if (fixnum? x*) (untag-fixnum x*) (untag-bignum x*)))
  74. ;;
  75. ;; Then, unless we know that we can reduce directly to `untag-fixnum`,
  76. ;; we do:
  77. ;;
  78. ;; s64 x = (scm->s64 x*)
  79. ;;
  80. ;; That way we keep DCE and CSE happy. We can inline scm->s64 at the
  81. ;; backend if we choose to (though we might choose to not do so, for
  82. ;; code size reasons).
  83. (define (simple-primcall cps k src op arg)
  84. (with-cps cps
  85. (build-term
  86. ($continue k src
  87. ($primcall op #f (arg))))))
  88. (define-syntax-rule (define-simple-primcall name)
  89. (define (name cps k src arg) (simple-primcall cps k src 'name arg)))
  90. (define-simple-primcall untag-fixnum)
  91. (define-simple-primcall scm->s64)
  92. (define-simple-primcall tag-fixnum)
  93. (define-simple-primcall s64->scm)
  94. (define-simple-primcall tag-fixnum/unlikely)
  95. (define-simple-primcall s64->scm/unlikely)
  96. (define (fixnum->u64 cps k src fx)
  97. (with-cps cps
  98. (letv s64)
  99. (letk kcvt ($kargs ('s64) (s64)
  100. ($continue k src ($primcall 's64->u64 #f (s64)))))
  101. ($ (untag-fixnum kcvt src fx))))
  102. (define (u64->fixnum cps k src u64)
  103. (with-cps cps
  104. (letv s64)
  105. (let$ tag-body (tag-fixnum k src s64))
  106. (letk ks64 ($kargs ('s64) (s64) ,tag-body))
  107. (build-term
  108. ($continue ks64 src ($primcall 'u64->s64 #f (u64))))))
  109. (define-simple-primcall scm->u64)
  110. (define-simple-primcall scm->u64/truncate)
  111. (define-simple-primcall u64->scm)
  112. (define-simple-primcall u64->scm/unlikely)
  113. (define-simple-primcall scm->f64)
  114. (define-simple-primcall f64->scm)
  115. (define (fixnum->f64 cps k src fx)
  116. (with-cps cps
  117. (letv s64)
  118. (letk kcvt ($kargs ('s64) (s64)
  119. ($continue k src ($primcall 's64->f64 #f (s64)))))
  120. ($ (untag-fixnum kcvt src fx))))
  121. (define (specialize-unop cps k src op param a unbox-a box-result)
  122. (with-cps cps
  123. (letv a* result)
  124. (let$ box-result-body (box-result k src result))
  125. (letk kbox ($kargs ('result) (result) ,box-result-body))
  126. (letk kop ($kargs ('a) (a*)
  127. ($continue kbox src ($primcall op param (a*)))))
  128. ($ (unbox-a kop src a))))
  129. (define* (specialize-binop cps k src op a b
  130. unbox-a unbox-b box-result)
  131. (with-cps cps
  132. (letv a* b* result)
  133. (let$ box-result-body (box-result k src result))
  134. (letk kbox ($kargs ('result) (result) ,box-result-body))
  135. (letk kop ($kargs ('b) (b*)
  136. ($continue kbox src ($primcall op #f (a* b*)))))
  137. (let$ unbox-b-body (unbox-b kop src b))
  138. (letk kunbox-b ($kargs ('a) (a*) ,unbox-b-body))
  139. ($ (unbox-a kunbox-b src a))))
  140. (define (specialize-comparison cps kf kt src op a b unbox-a unbox-b)
  141. (with-cps cps
  142. (letv a* b*)
  143. (letk kop ($kargs ('b) (b*) ($branch kf kt src op #f (a* b*))))
  144. (let$ unbox-b-body (unbox-b kop src b))
  145. (letk kunbox-b ($kargs ('a) (a*) ,unbox-b-body))
  146. ($ (unbox-a kunbox-b src a))))
  147. (define* (specialize-comparison/immediate cps kf kt src op a imm
  148. unbox-a)
  149. (with-cps cps
  150. (letv ia)
  151. (letk kop ($kargs ('ia) (ia) ($branch kf kt src op imm (ia))))
  152. ($ (unbox-a kop src a))))
  153. (define (specialize-comparison/s64-integer cps kf kt src op a-s64 b-int
  154. unbox-a rebox-a)
  155. (let ((s64-op (match op ('= 's64-=) ('< 's64-<))))
  156. (with-cps cps
  157. (letv a b sunk)
  158. (letk kheap ($kargs ('sunk) (sunk)
  159. ($branch kf kt src op #f (sunk b-int))))
  160. ;; Re-box the variable. FIXME: currently we use a specially
  161. ;; marked s64->scm to avoid CSE from hoisting the allocation
  162. ;; again. Instead we should just use a-s64 directly and implement
  163. ;; an allocation sinking pass that should handle this..
  164. (let$ rebox-a-body (rebox-a kheap src a))
  165. (letk kretag ($kargs () () ,rebox-a-body))
  166. (letk kb ($kargs ('b) (b) ($branch kf kt src s64-op #f (a b))))
  167. (letk kfix ($kargs () ()
  168. ($continue kb src
  169. ($primcall 'untag-fixnum #f (b-int)))))
  170. (letk ka ($kargs ('a) (a)
  171. ($branch kretag kfix src 'fixnum? #f (b-int))))
  172. ($ (unbox-a ka src a-s64)))))
  173. (define (specialize-comparison/integer-s64 cps kf kt src op a-int b-s64
  174. unbox-b rebox-b)
  175. (match op
  176. ('= (specialize-comparison/s64-integer cps kf kt src op b-s64 a-int
  177. unbox-b rebox-b))
  178. ('<
  179. (with-cps cps
  180. (letv a b sunk)
  181. (letk kheap ($kargs ('sunk) (sunk)
  182. ($branch kf kt src '< #f (a-int sunk))))
  183. ;; FIXME: We should just use b-s64 directly and implement an
  184. ;; allocation sinking pass so that the box op that creates b-64
  185. ;; should float down here. Instead, for now we just rebox the
  186. ;; variable, relying on the reboxing op not being available for
  187. ;; CSE.
  188. (let$ rebox-b-body (rebox-b kheap src b))
  189. (letk kretag ($kargs () () ,rebox-b-body))
  190. (letk ka ($kargs ('a) (a) ($branch kf kt src 's64-< #f (a b))))
  191. (letk kfix ($kargs () ()
  192. ($continue ka src
  193. ($primcall 'untag-fixnum #f (a-int)))))
  194. (letk kb ($kargs ('b) (b)
  195. ($branch kretag kfix src 'fixnum? #f (a-int))))
  196. ($ (unbox-b kb src b-s64))))))
  197. (define (specialize-comparison/immediate-s64-integer cps kf kt src op a b-int
  198. compare-integers)
  199. (with-cps cps
  200. (letv b sunk)
  201. (letk kheap ($kargs ('sunk) (sunk) ,(compare-integers kf kt src sunk)))
  202. ;; Re-box the variable. FIXME: currently we use a specially marked
  203. ;; load-const to avoid CSE from hoisting the constant. Instead we
  204. ;; should just use a $const directly and implement an allocation
  205. ;; sinking pass that should handle this..
  206. (letk kretag ($kargs () ()
  207. ($continue kheap src
  208. ($primcall 'load-const/unlikely a ()))))
  209. (letk kb ($kargs ('b) (b)
  210. ($branch kf kt src op a (b))))
  211. (letk kfix ($kargs () ()
  212. ($continue kb src
  213. ($primcall 'untag-fixnum #f (b-int)))))
  214. (build-term ($branch kretag kfix src 'fixnum? #f (b-int)))))
  215. ;; compute-significant-bits solves a flow equation to compute a
  216. ;; least-fixed-point over the lattice VAR -> BITMASK, where X > Y if
  217. ;; X[VAR] > Y[VAR] for any VAR. Adjoining VAR -> BITMASK to X results
  218. ;; in a distinct value X' (in the sense of eq?) if and only if X' > X.
  219. ;; This property is used in compute-significant-bits to know when to
  220. ;; stop iterating, and is ensured by intmaps, provided that the `meet'
  221. ;; function passed to `intmap-add' and so on also preserves this
  222. ;; property.
  223. ;;
  224. ;; The meet function for adding bits is `sigbits-union'; the first
  225. ;; argument is the existing value, and the second is the bitmask to
  226. ;; adjoin. For fixnums, BITMASK' will indeed be distinct if and only if
  227. ;; bits were added. However for bignums it's possible that (= X' X) but
  228. ;; not (eq? X' X). This preserve-eq? helper does the impedance matching
  229. ;; for bignums, returning the first value if the values are =.
  230. (define (preserve-eq? x x*)
  231. (if (= x x*)
  232. x
  233. x*))
  234. (define (sigbits-union x y)
  235. (and x y
  236. (preserve-eq? x (logior x y))))
  237. (define (sigbits-intersect x y)
  238. (cond
  239. ((not x) y)
  240. ((not y) x)
  241. (else (logand x y))))
  242. (define (sigbits-intersect3 a b c)
  243. (sigbits-intersect a (sigbits-intersect b c)))
  244. (define (next-power-of-two n)
  245. (let lp ((out 1))
  246. (if (< n out)
  247. out
  248. (lp (ash out 1)))))
  249. (define (range->sigbits min max)
  250. (cond
  251. ((or (< min 0) (> max #xffffFFFFffffFFFF)) #f)
  252. ((eqv? min max) min)
  253. (else (1- (next-power-of-two max)))))
  254. (define (inferred-sigbits types label var)
  255. (call-with-values (lambda () (lookup-pre-type types label var))
  256. (lambda (type min max)
  257. (and (type<=? type (logior &exact-integer &u64 &s64))
  258. (range->sigbits min max)))))
  259. (define significant-bits-handlers (make-hash-table))
  260. (define-syntax-rule (define-significant-bits-handler
  261. ((primop label types out def ...) param arg ...)
  262. body ...)
  263. (hashq-set! significant-bits-handlers 'primop
  264. (lambda (label types out param args defs)
  265. (match args ((arg ...) (match defs ((def ...) body ...)))))))
  266. (define-significant-bits-handler ((logand label types out res) param a b)
  267. (let ((sigbits (sigbits-intersect3 (inferred-sigbits types label a)
  268. (inferred-sigbits types label b)
  269. (intmap-ref out res (lambda (_) 0)))))
  270. (intmap-add (intmap-add out a sigbits sigbits-union)
  271. b sigbits sigbits-union)))
  272. (define-significant-bits-handler ((logand/immediate label types out res) param a)
  273. (let ((sigbits (sigbits-intersect3 (inferred-sigbits types label a)
  274. param
  275. (intmap-ref out res (lambda (_) 0)))))
  276. (intmap-add out a sigbits sigbits-union)))
  277. (define (significant-bits-handler primop)
  278. (hashq-ref significant-bits-handlers primop))
  279. (define (compute-significant-bits cps types kfun)
  280. "Given the locally inferred types @var{types}, compute a map of VAR ->
  281. BITS indicating the significant bits needed for a variable. BITS may be
  282. #f to indicate all bits, or a non-negative integer indicating a bitmask."
  283. (let ((preds (invert-graph (compute-successors cps kfun))))
  284. (let lp ((worklist (intmap-keys preds)) (visited empty-intset)
  285. (out empty-intmap))
  286. (match (intset-prev worklist)
  287. (#f out)
  288. (label
  289. (let ((worklist (intset-remove worklist label))
  290. (visited* (intset-add visited label)))
  291. (define (continue out*)
  292. (if (and (eq? out out*) (eq? visited visited*))
  293. (lp worklist visited out)
  294. (lp (intset-union worklist (intmap-ref preds label))
  295. visited* out*)))
  296. (define (add-def out var)
  297. (intmap-add out var 0 sigbits-union))
  298. (define (add-defs out vars)
  299. (match vars
  300. (() out)
  301. ((var . vars) (add-defs (add-def out var) vars))))
  302. (define (add-unknown-use out var)
  303. (intmap-add out var (inferred-sigbits types label var)
  304. sigbits-union))
  305. (define (add-unknown-uses out vars)
  306. (match vars
  307. (() out)
  308. ((var . vars)
  309. (add-unknown-uses (add-unknown-use out var) vars))))
  310. (continue
  311. (match (intmap-ref cps label)
  312. (($ $kfun src meta self)
  313. (if self (add-def out self) out))
  314. (($ $kargs names vars term)
  315. (let ((out (add-defs out vars)))
  316. (match term
  317. (($ $continue k src exp)
  318. (match exp
  319. ((or ($ $const) ($ $prim) ($ $fun) ($ $const-fun)
  320. ($ $code) ($ $rec))
  321. ;; No uses, so no info added to sigbits.
  322. out)
  323. (($ $values args)
  324. (match (intmap-ref cps k)
  325. (($ $kargs _ vars)
  326. (if (intset-ref visited k)
  327. (fold (lambda (arg var out)
  328. (intmap-add out arg (intmap-ref out var)
  329. sigbits-union))
  330. out args vars)
  331. out))
  332. (($ $ktail)
  333. (add-unknown-uses out args))))
  334. (($ $call proc args)
  335. (add-unknown-use (add-unknown-uses out args) proc))
  336. (($ $callk label proc args)
  337. (let ((out (add-unknown-uses out args)))
  338. (if proc
  339. (add-unknown-use out proc)
  340. out)))
  341. (($ $calli args callee)
  342. (add-unknown-uses (add-unknown-use out callee) args))
  343. (($ $primcall name param args)
  344. (let ((h (significant-bits-handler name)))
  345. (if h
  346. (match (intmap-ref cps k)
  347. (($ $kargs _ defs)
  348. (h label types out param args defs)))
  349. (add-unknown-uses out args))))))
  350. (($ $branch kf kt src op param args)
  351. (add-unknown-uses out args))
  352. (($ $switch kf kt src arg)
  353. (add-unknown-use out arg))
  354. (($ $prompt k kh src escape? tag)
  355. (add-unknown-use out tag))
  356. (($ $throw src op param args)
  357. (add-unknown-uses out args)))))
  358. (_ out)))))))))
  359. (define (specialize-operations cps)
  360. (define (u6-parameter? param)
  361. (<= 0 param 63))
  362. (define (s64-parameter? param)
  363. (<= (ash -1 63) param (1- (ash 1 63))))
  364. (define (u64-parameter? param)
  365. (<= 0 param (1- (ash 1 64))))
  366. (define (visit-cont label cont cps types sigbits)
  367. (define (operand-in-range? var &type &min &max)
  368. (call-with-values (lambda ()
  369. (lookup-pre-type types label var))
  370. (lambda (type min max)
  371. (and (type<=? type &type) (<= &min min max &max)))))
  372. (define (u64-operand? var)
  373. (operand-in-range? var &exact-integer 0 (1- (ash 1 64))))
  374. (define (u6-operand? var)
  375. ;; This predicate is only used for the "count" argument to
  376. ;; rsh/lsh, which is already unboxed to &u64.
  377. (operand-in-range? var &u64 0 63))
  378. (define (s64-operand? var)
  379. (operand-in-range? var &exact-integer (ash -1 63) (1- (ash 1 63))))
  380. (define (fixnum-operand? var)
  381. (operand-in-range? var &exact-integer
  382. (target-most-negative-fixnum)
  383. (target-most-positive-fixnum)))
  384. (define (exact-integer-operand? var)
  385. (operand-in-range? var &exact-integer -inf.0 +inf.0))
  386. (define (all-u64-bits-set? var)
  387. (operand-in-range? var &exact-integer (1- (ash 1 64)) (1- (ash 1 64))))
  388. (define (only-fixnum-bits-used? var)
  389. (let ((bits (intmap-ref sigbits var)))
  390. (and bits (= bits (logand bits (target-most-positive-fixnum))))))
  391. (define (fixnum-result? result)
  392. (or (only-fixnum-bits-used? result)
  393. (call-with-values
  394. (lambda ()
  395. (lookup-post-type types label result 0))
  396. (lambda (type min max)
  397. (and (type<=? type &exact-integer)
  398. (<= (target-most-negative-fixnum)
  399. min max
  400. (target-most-positive-fixnum)))))))
  401. (define (only-u64-bits-used? var)
  402. (let ((bits (intmap-ref sigbits var)))
  403. (and bits (= bits (logand bits (1- (ash 1 64)))))))
  404. (define (u64-result? result)
  405. (or (only-u64-bits-used? result)
  406. (call-with-values
  407. (lambda ()
  408. (lookup-post-type types label result 0))
  409. (lambda (type min max)
  410. (and (type<=? type &exact-integer)
  411. (<= 0 min max (1- (ash 1 64))))))))
  412. (define (s64-result? result)
  413. (call-with-values
  414. (lambda ()
  415. (lookup-post-type types label result 0))
  416. (lambda (type min max)
  417. (and (type<=? type &exact-integer)
  418. (<= (ash -1 63) min max (1- (ash 1 63)))))))
  419. (define (f64-result? result)
  420. (call-with-values
  421. (lambda ()
  422. (lookup-post-type types label result 0))
  423. (lambda (type min max)
  424. (eqv? type &flonum))))
  425. (define (f64-operands? vara varb)
  426. (let-values (((typea mina maxa) (lookup-pre-type types label vara))
  427. ((typeb minb maxb) (lookup-pre-type types label varb)))
  428. (and (type<=? (logior typea typeb) &real)
  429. (or (eqv? typea &flonum)
  430. (eqv? typeb &flonum)))))
  431. (define (constant-arg arg)
  432. (let-values (((type min max) (lookup-pre-type types label arg)))
  433. (and (= min max) min)))
  434. (define (fixnum-range? min max)
  435. (<= (target-most-negative-fixnum) min max (target-most-positive-fixnum)))
  436. (define (unbox-u64 arg)
  437. (if (fixnum-operand? arg) fixnum->u64 scm->u64))
  438. (define (unbox-u64/truncate arg)
  439. (cond
  440. ((fixnum-operand? arg) fixnum->u64)
  441. ((u64-operand? arg) scm->u64)
  442. (else scm->u64/truncate)))
  443. (define (unbox-s64 arg)
  444. (if (fixnum-operand? arg) untag-fixnum scm->s64))
  445. (define (rebox-s64 arg)
  446. (if (fixnum-operand? arg) tag-fixnum/unlikely s64->scm/unlikely))
  447. (define (unbox-f64 arg)
  448. ;; Could be more precise here.
  449. (if (fixnum-operand? arg) fixnum->f64 scm->f64))
  450. (define (box-s64 result)
  451. (if (fixnum-result? result) tag-fixnum s64->scm))
  452. (define (box-u64 result)
  453. (if (fixnum-result? result) u64->fixnum u64->scm))
  454. (define (box-f64 result)
  455. f64->scm)
  456. (define (specialize-primcall cps k src op param args)
  457. (match (intmap-ref cps k)
  458. (($ $kargs (_) (result))
  459. (match (cons* op result param args)
  460. (((or 'add 'sub 'mul 'div 'atan2)
  461. (? f64-result?) #f a b)
  462. (let ((op (match op
  463. ('add 'fadd) ('sub 'fsub) ('mul 'fmul) ('div 'fdiv)
  464. ('atan2 'fatan2))))
  465. (specialize-binop cps k src op a b
  466. (unbox-f64 a) (unbox-f64 b) (box-f64 result))))
  467. (((or 'sqrt 'abs 'floor 'ceiling 'sin 'cos 'tan 'asin 'acos 'atan)
  468. (? f64-result?) #f a)
  469. (let ((op (match op
  470. ('sqrt 'fsqrt) ('abs 'fabs)
  471. ('floor 'ffloor) ('ceiling 'fceiling)
  472. ('sin 'fsin) ('cos 'fcos) ('tan 'ftan)
  473. ('asin 'fasin) ('acos 'facos) ('atan 'fatan))))
  474. (specialize-unop cps k src op #f a
  475. (unbox-f64 a) (box-f64 result))))
  476. (((or 'add 'sub 'mul 'logand 'logior 'logxor 'logsub)
  477. (? u64-result?) #f (? u64-operand? a) (? u64-operand? b))
  478. (let ((op (match op
  479. ('add 'uadd) ('sub 'usub) ('mul 'umul)
  480. ('logand 'ulogand) ('logior 'ulogior)
  481. ('logxor 'ulogxor) ('logsub 'ulogsub))))
  482. (specialize-binop cps k src op a b
  483. (unbox-u64 a) (unbox-u64 b) (box-u64 result))))
  484. (((or 'logand 'logior 'logxor 'logsub)
  485. (? u64-result?) #f (? s64-operand? a) (? s64-operand? b))
  486. (let ((op (match op
  487. ('logand 'ulogand) ('logior 'ulogior)
  488. ('logxor 'ulogxor) ('logsub 'ulogsub))))
  489. (define (unbox-u64* x)
  490. (let ((unbox-s64 (unbox-s64 x)))
  491. (lambda (cps k src x)
  492. (with-cps cps
  493. (letv s64)
  494. (letk ks64 ($kargs ('s64) (s64)
  495. ($continue k src
  496. ($primcall 's64->u64 #f (s64)))))
  497. ($ (unbox-s64 k src x))))))
  498. (specialize-binop cps k src op a b
  499. (unbox-u64* a) (unbox-u64* b) (box-u64 result))))
  500. (((or 'add 'sub 'mul)
  501. (? s64-result?) #f (? s64-operand? a) (? s64-operand? b))
  502. (let ((op (match op
  503. ('add 'sadd) ('sub 'ssub) ('mul 'smul))))
  504. (specialize-binop cps k src op a b
  505. (unbox-s64 a) (unbox-s64 b) (box-s64 result))))
  506. (('sub/immediate
  507. (? f64-result?) param a)
  508. (specialize-unop cps k src 'fadd/immediate (- param) a
  509. (unbox-f64 a) (box-f64 result)))
  510. (((or 'add/immediate 'mul/immediate)
  511. (? f64-result?) param a)
  512. (let ((op (match op
  513. ('add/immediate 'fadd/immediate)
  514. ('mul/immediate 'fmul/immediate))))
  515. (specialize-unop cps k src op param a
  516. (unbox-f64 a) (box-f64 result))))
  517. (((or 'add/immediate 'sub/immediate 'mul/immediate)
  518. (? u64-result?) (? u64-parameter?) (? u64-operand? a))
  519. (let ((op (match op
  520. ('add/immediate 'uadd/immediate)
  521. ('sub/immediate 'usub/immediate)
  522. ('mul/immediate 'umul/immediate))))
  523. (specialize-unop cps k src op param a
  524. (unbox-u64 a) (box-u64 result))))
  525. (('logand/immediate (? u64-result? ) param (? u64-operand? a))
  526. (specialize-unop cps k src 'ulogand/immediate
  527. (logand param (1- (ash 1 64)))
  528. a
  529. (unbox-u64 a) (box-u64 result)))
  530. (((or 'add/immediate 'sub/immediate 'mul/immediate)
  531. (? s64-result?) (? s64-parameter?) (? s64-operand? a))
  532. (let ((op (match op
  533. ('add/immediate 'sadd/immediate)
  534. ('sub/immediate 'ssub/immediate)
  535. ('mul/immediate 'smul/immediate))))
  536. (specialize-unop cps k src op param a
  537. (unbox-s64 a) (box-s64 result))))
  538. (((or 'lsh 'rsh)
  539. (? u64-result?) #f (? u64-operand? a) (? u6-operand? b))
  540. (let ((op (match op ('lsh 'ulsh) ('rsh 'ursh))))
  541. (define (pass-u64 cps k src b)
  542. (with-cps cps
  543. (build-term ($continue k src ($values (b))))))
  544. (specialize-binop cps k src op a b
  545. (unbox-u64 a) pass-u64 (box-u64 result))))
  546. (((or 'lsh 'rsh)
  547. (? s64-result?) #f (? s64-operand? a) (? u6-operand? b))
  548. (let ((op (match op ('lsh 'slsh) ('rsh 'srsh))))
  549. (define (pass-u64 cps k src b)
  550. (with-cps cps
  551. (build-term ($continue k src ($values (b))))))
  552. (specialize-binop cps k src op a b
  553. (unbox-s64 a) pass-u64 (box-s64 result))))
  554. (((or 'lsh/immediate 'rsh/immediate)
  555. (? u64-result?) (? u6-parameter?) (? u64-operand? a))
  556. (let ((op (match op
  557. ('lsh/immediate 'ulsh/immediate)
  558. ('rsh/immediate 'ursh/immediate))))
  559. (specialize-unop cps k src op param a
  560. (unbox-u64 a) (box-u64 result))))
  561. (((or 'lsh/immediate 'rsh/immediate)
  562. (? s64-result?) (? u6-parameter?) (? s64-operand? a))
  563. (let ((op (match op
  564. ('lsh/immediate 'slsh/immediate)
  565. ('rsh/immediate 'srsh/immediate))))
  566. (specialize-unop cps k src op param a
  567. (unbox-s64 a) (box-s64 result))))
  568. (_ (with-cps cps #f))))
  569. (_ (with-cps cps #f))))
  570. (define (specialize-branch cps kf kt src op param args)
  571. (match (cons op args)
  572. (('<= a b)
  573. (cond
  574. ((f64-operands? a b)
  575. (specialize-comparison cps kf kt src 'f64-<= a b
  576. (unbox-f64 a) (unbox-f64 b)))
  577. ((and (exact-integer-operand? a) (exact-integer-operand? b))
  578. ;; If NaN is impossible, reduce (<= a b) to (not (< b a)) and
  579. ;; try again.
  580. (specialize-branch cps kt kf src '< param (list b a)))
  581. (else
  582. (with-cps cps #f))))
  583. (((or '< '=) a b)
  584. (cond
  585. ((f64-operands? a b)
  586. (let ((op (match op ('= 'f64-=) ('< 'f64-<))))
  587. (specialize-comparison cps kf kt src op a b
  588. (unbox-f64 a) (unbox-f64 b))))
  589. ((and (s64-operand? a) (s64-operand? b))
  590. (cond
  591. ((constant-arg a)
  592. => (lambda (a)
  593. (let ((op (match op ('= 's64-imm-=) ('< 'imm-s64-<))))
  594. (specialize-comparison/immediate cps kf kt src op b a
  595. (unbox-s64 b)))))
  596. ((constant-arg b)
  597. => (lambda (b)
  598. (let ((op (match op ('= 's64-imm-=) ('< 's64-imm-<))))
  599. (specialize-comparison/immediate cps kf kt src op a b
  600. (unbox-s64 a)))))
  601. (else
  602. (let ((op (match op ('= 's64-=) ('< 's64-<))))
  603. (specialize-comparison cps kf kt src op a b
  604. (unbox-s64 a) (unbox-s64 b))))))
  605. ((and (u64-operand? a) (u64-operand? b))
  606. (cond
  607. ((constant-arg a)
  608. => (lambda (a)
  609. (let ((op (match op ('= 'u64-imm-=) ('< 'imm-u64-<))))
  610. (specialize-comparison/immediate cps kf kt src op b a
  611. (unbox-u64 b)))))
  612. ((constant-arg b)
  613. => (lambda (b)
  614. (let ((op (match op ('= 'u64-imm-=) ('< 'u64-imm-<))))
  615. (specialize-comparison/immediate cps kf kt src op a b
  616. (unbox-u64 a)))))
  617. (else
  618. (let ((op (match op ('= 'u64-=) ('< 'u64-<))))
  619. (specialize-comparison cps kf kt src op a b
  620. (unbox-u64 a) (unbox-u64 b))))))
  621. ((and (exact-integer-operand? a) (exact-integer-operand? b))
  622. (cond
  623. ((s64-operand? a)
  624. (cond
  625. ((constant-arg a)
  626. => (lambda (a)
  627. (let ((imm-op (match op ('= 's64-imm-=) ('< 'imm-s64-<))))
  628. (specialize-comparison/immediate-s64-integer
  629. cps kf kt src imm-op a b
  630. (lambda (kf kt src a)
  631. (build-term ($branch kf kt src op #f (a b))))))))
  632. (else
  633. (specialize-comparison/s64-integer cps kf kt src op a b
  634. (unbox-s64 a)
  635. (rebox-s64 a)))))
  636. ((s64-operand? b)
  637. (cond
  638. ((constant-arg b)
  639. => (lambda (b)
  640. (let ((imm-op (match op ('= 's64-imm-=) ('< 's64-imm-<))))
  641. (specialize-comparison/immediate-s64-integer
  642. cps kf kt src imm-op b a
  643. (lambda (kf kt src b)
  644. (build-term ($branch kf kt src op #f (a b))))))))
  645. (else
  646. (specialize-comparison/integer-s64 cps kf kt src op a b
  647. (unbox-s64 b)
  648. (rebox-s64 b)))))
  649. (else (with-cps cps #f))))
  650. (else (with-cps cps #f))))
  651. (_ (with-cps cps #f))))
  652. (match cont
  653. (($ $kfun)
  654. (let* ((types (infer-types cps label))
  655. (sigbits (compute-significant-bits cps types label)))
  656. (values cps types sigbits)))
  657. (($ $kargs names vars ($ $continue k src ($ $primcall op param args)))
  658. (call-with-values
  659. (lambda () (specialize-primcall cps k src op param args))
  660. (lambda (cps term)
  661. (values (if term
  662. (with-cps cps
  663. (setk label ($kargs names vars ,term)))
  664. cps)
  665. types sigbits))))
  666. (($ $kargs names vars ($ $branch kf kt src op param args))
  667. (call-with-values
  668. (lambda () (specialize-branch cps kf kt src op param args))
  669. (lambda (cps term)
  670. (values (if term
  671. (with-cps cps
  672. (setk label ($kargs names vars ,term)))
  673. cps)
  674. types sigbits))))
  675. (_ (values cps types sigbits))))
  676. (values (intmap-fold visit-cont cps cps #f #f)))
  677. ;; Compute a map from VAR -> LABEL, where LABEL indicates the cont that
  678. ;; binds VAR.
  679. (define (compute-defs conts labels)
  680. (intset-fold
  681. (lambda (label defs)
  682. (match (intmap-ref conts label)
  683. (($ $kfun src meta self tail clause)
  684. (if self (intmap-add defs self label) defs))
  685. (($ $kargs names vars)
  686. (fold1 (lambda (var defs)
  687. (intmap-add defs var label))
  688. vars defs))
  689. (_ defs)))
  690. labels empty-intmap))
  691. ;; Compute vars whose definitions are all unboxable and whose uses
  692. ;; include an unbox operation.
  693. (define (compute-specializable-vars cps body preds defs
  694. exp-result-unboxable?
  695. unbox-ops)
  696. ;; Compute a map of VAR->LABEL... indicating the set of labels that
  697. ;; define VAR with unboxable values, given the set of vars
  698. ;; UNBOXABLE-VARS which is known already to be unboxable.
  699. (define (collect-unboxable-def-labels unboxable-vars)
  700. (define (add-unboxable-def unboxable-defs var label)
  701. (intmap-add unboxable-defs var (intset label) intset-union))
  702. (intset-fold (lambda (label unboxable-defs)
  703. (match (intmap-ref cps label)
  704. (($ $kargs _ _ ($ $continue k _ exp))
  705. (match exp
  706. ((? exp-result-unboxable?)
  707. (match (intmap-ref cps k)
  708. (($ $kargs (_) (def))
  709. (add-unboxable-def unboxable-defs def label))))
  710. (($ $values vars)
  711. (match (intmap-ref cps k)
  712. (($ $kargs _ defs)
  713. (fold
  714. (lambda (var def unboxable-defs)
  715. (if (intset-ref unboxable-vars var)
  716. (add-unboxable-def unboxable-defs def label)
  717. unboxable-defs))
  718. unboxable-defs vars defs))
  719. ;; Could be $ktail for $values.
  720. (_ unboxable-defs)))
  721. (_ unboxable-defs)))
  722. (_ unboxable-defs)))
  723. body empty-intmap))
  724. ;; Compute the set of vars which are always unboxable.
  725. (define (compute-unboxable-defs)
  726. (fixpoint
  727. (lambda (unboxable-vars)
  728. (intmap-fold
  729. (lambda (def unboxable-pred-labels unboxable-vars)
  730. (if (and (not (intset-ref unboxable-vars def))
  731. ;; Are all defining expressions unboxable?
  732. (and-map (lambda (pred)
  733. (intset-ref unboxable-pred-labels pred))
  734. (intmap-ref preds (intmap-ref defs def))))
  735. (intset-add unboxable-vars def)
  736. unboxable-vars))
  737. (collect-unboxable-def-labels unboxable-vars)
  738. unboxable-vars))
  739. empty-intset))
  740. ;; Compute the set of vars that may ever be unboxed.
  741. (define (compute-unbox-uses unboxable-defs)
  742. (intset-fold
  743. (lambda (label unbox-uses)
  744. (match (intmap-ref cps label)
  745. (($ $kargs _ _ ($ $continue k _ exp))
  746. (match exp
  747. (($ $primcall (? (lambda (op) (memq op unbox-ops))) #f (var))
  748. (intset-add unbox-uses var))
  749. (($ $values vars)
  750. (match (intmap-ref cps k)
  751. (($ $kargs _ defs)
  752. (fold (lambda (var def unbox-uses)
  753. (if (intset-ref unboxable-defs def)
  754. (intset-add unbox-uses var)
  755. unbox-uses))
  756. unbox-uses vars defs))
  757. (($ $ktail)
  758. ;; Assume return is rare and that any unboxable def can
  759. ;; be reboxed when leaving the procedure.
  760. (fold (lambda (var unbox-uses)
  761. (intset-add unbox-uses var))
  762. unbox-uses vars))))
  763. (_ unbox-uses)))
  764. (_ unbox-uses)))
  765. body empty-intset))
  766. (let ((unboxable-defs (compute-unboxable-defs)))
  767. (intset-intersect unboxable-defs (compute-unbox-uses unboxable-defs))))
  768. ;; Compute vars whose definitions are all inexact reals and whose uses
  769. ;; include an unbox operation.
  770. (define (compute-specializable-f64-vars cps body preds defs)
  771. ;; Can the result of EXP definitely be unboxed as an f64?
  772. (define (exp-result-f64? exp)
  773. (match exp
  774. ((or ($ $primcall 'f64->scm #f (_))
  775. ($ $const (and (? number?) (? inexact?) (? real?))))
  776. #t)
  777. (_ #f)))
  778. (compute-specializable-vars cps body preds defs exp-result-f64? '(scm->f64)))
  779. ;; Compute vars whose definitions are all exact integers in the u64
  780. ;; range and whose uses include an unbox operation.
  781. (define (compute-specializable-u64-vars cps body preds defs)
  782. ;; Can the result of EXP definitely be unboxed as a u64?
  783. (define (exp-result-u64? exp)
  784. (define (u64? n)
  785. (and (number? n) (exact-integer? n)
  786. (<= 0 n #xffffffffffffffff)))
  787. (match exp
  788. ((or ($ $primcall 'u64->scm #f (_))
  789. ($ $primcall 'u64->scm/unlikely #f (_))
  790. ($ $primcall 'load-const/unlikely (? u64?) ())
  791. ($ $const (? u64?)))
  792. #t)
  793. (_ #f)))
  794. (compute-specializable-vars cps body preds defs exp-result-u64?
  795. '(scm->u64 scm->u64/truncate)))
  796. ;; Compute vars whose definitions are all exact integers in the fixnum
  797. ;; range and whose uses include an untag operation.
  798. (define (compute-specializable-fixnum-vars cps body preds defs)
  799. ;; Is the result of EXP definitely a fixnum?
  800. (define (exp-result-fixnum? exp)
  801. (define (fixnum? n)
  802. (and (number? n) (exact-integer? n)
  803. (<= (target-most-negative-fixnum)
  804. n
  805. (target-most-positive-fixnum))))
  806. (match exp
  807. ((or ($ $primcall 'tag-fixnum #f (_))
  808. ($ $primcall 'tag-fixnum/unlikely #f (_))
  809. ($ $const (? fixnum?))
  810. ($ $primcall 'load-const/unlikely (? fixnum?) ()))
  811. #t)
  812. (_ #f)))
  813. (compute-specializable-vars cps body preds defs exp-result-fixnum?
  814. '(untag-fixnum)))
  815. ;; Compute vars whose definitions are all exact integers in the s64
  816. ;; range and whose uses include an untag operation.
  817. (define (compute-specializable-s64-vars cps body preds defs)
  818. ;; Is the result of EXP definitely a fixnum?
  819. (define (exp-result-fixnum? exp)
  820. (define (s64? n)
  821. (and (number? n) (exact-integer? n)
  822. (<= (ash -1 63) n (1- (ash 1 63)))))
  823. (match exp
  824. ((or ($ $primcall 's64->scm #f (_))
  825. ($ $const (? s64?))
  826. ($ $primcall 'load-const/unlikely (? s64?) ()))
  827. #t)
  828. (_ #f)))
  829. (compute-specializable-vars cps body preds defs exp-result-fixnum?
  830. '(scm->s64)))
  831. (define (compute-phi-vars cps preds)
  832. (intmap-fold (lambda (label preds phis)
  833. (match preds
  834. (() phis)
  835. ((_) phis)
  836. (_
  837. (match (intmap-ref cps label)
  838. (($ $kargs names vars)
  839. (fold1 (lambda (var phis)
  840. (intset-add phis var))
  841. vars phis))
  842. (_ phis)))))
  843. preds empty-intset))
  844. ;; Compute the set of variables which have more than one definition,
  845. ;; whose definitions are always f64-valued or u64-valued, and which have
  846. ;; at least one use that is an unbox operation.
  847. (define (compute-specializable-phis cps body preds defs)
  848. (let ((phi-vars (compute-phi-vars cps preds)))
  849. (fold1 (lambda (in out)
  850. (match in
  851. ((kind vars)
  852. (intset-fold
  853. (lambda (var out)
  854. (intmap-add out var kind (lambda (old new) old)))
  855. (intset-intersect phi-vars vars)
  856. out))))
  857. `((f64 ,(compute-specializable-f64-vars cps body preds defs))
  858. (fx ,(compute-specializable-fixnum-vars cps body preds defs))
  859. (s64 ,(compute-specializable-s64-vars cps body preds defs))
  860. (u64 ,(compute-specializable-u64-vars cps body preds defs)))
  861. empty-intmap)))
  862. ;; Each definition of a f64/u64 variable should unbox that variable.
  863. ;; The cont that binds the variable should re-box it under its original
  864. ;; name, and rely on CSE to remove the boxing as appropriate.
  865. (define (apply-specialization cps kfun body preds defs phis)
  866. (define (compute-unbox-labels)
  867. (intmap-fold (lambda (phi kind labels)
  868. (fold1 (lambda (pred labels)
  869. (intset-add labels pred))
  870. (intmap-ref preds (intmap-ref defs phi))
  871. labels))
  872. phis empty-intset))
  873. (define (unbox-op var)
  874. (match (intmap-ref phis var)
  875. ('f64 'scm->f64)
  876. ('fx 'untag-fixnum)
  877. ('s64 'scm->s64)
  878. ('u64 'scm->u64)))
  879. (define (box-op var)
  880. (match (intmap-ref phis var)
  881. ('f64 'f64->scm)
  882. ('fx 'tag-fixnum)
  883. ('s64 's64->scm)
  884. ('u64 'u64->scm)))
  885. (define (unbox-operands)
  886. (define (unbox-arg cps arg def-var have-arg)
  887. (if (intmap-ref phis def-var (lambda (_) #f))
  888. (with-cps cps
  889. (letv unboxed)
  890. (let$ body (have-arg unboxed))
  891. (letk kunboxed ($kargs ('unboxed) (unboxed) ,body))
  892. (build-term
  893. ($continue kunboxed #f ($primcall (unbox-op def-var) #f (arg)))))
  894. (have-arg cps arg)))
  895. (define (unbox-args cps args def-vars have-args)
  896. (match args
  897. (() (have-args cps '()))
  898. ((arg . args)
  899. (match def-vars
  900. ((def-var . def-vars)
  901. (unbox-arg cps arg def-var
  902. (lambda (cps arg)
  903. (unbox-args cps args def-vars
  904. (lambda (cps args)
  905. (have-args cps (cons arg args)))))))))))
  906. (intset-fold
  907. (lambda (label cps)
  908. (match (intmap-ref cps label)
  909. (($ $kargs names vars ($ $continue k src exp))
  910. (match (intmap-ref cps k)
  911. (($ $kargs _ defs)
  912. (match exp
  913. ;; For expressions that define a single value, we know we need
  914. ;; to unbox that value. For $values though we might have to
  915. ;; unbox just a subset of values.
  916. (($ $values args)
  917. (with-cps cps
  918. (let$ term (unbox-args
  919. args defs
  920. (lambda (cps args)
  921. (with-cps cps
  922. (build-term
  923. ($continue k src ($values args)))))))
  924. (setk label ($kargs names vars ,term))))
  925. (_
  926. (match defs
  927. ((def)
  928. (with-cps cps
  929. (letv boxed)
  930. (letk kunbox ($kargs ('boxed) (boxed)
  931. ($continue k src
  932. ($primcall (unbox-op def) #f (boxed)))))
  933. (setk label ($kargs names vars
  934. ($continue kunbox src ,exp)))))))))))))
  935. (compute-unbox-labels)
  936. cps))
  937. (define (compute-box-labels)
  938. (intmap-fold (lambda (phi kind labels)
  939. (intset-add labels (intmap-ref defs phi)))
  940. phis empty-intset))
  941. (define (box-results cps)
  942. (intset-fold
  943. (lambda (label cps)
  944. (match (intmap-ref cps label)
  945. (($ $kargs names vars term)
  946. (let* ((boxed (fold1 (lambda (var boxed)
  947. (if (intmap-ref phis var (lambda (_) #f))
  948. (intmap-add boxed var (fresh-var))
  949. boxed))
  950. vars empty-intmap))
  951. (bound-vars (map (lambda (var)
  952. (intmap-ref boxed var (lambda (var) var)))
  953. vars)))
  954. (define (box-var cps name var done)
  955. (let ((unboxed (intmap-ref boxed var (lambda (_) #f))))
  956. (if unboxed
  957. (with-cps cps
  958. (let$ term (done))
  959. (letk kboxed ($kargs (name) (var) ,term))
  960. (build-term
  961. ($continue kboxed #f
  962. ($primcall (box-op var) #f (unboxed)))))
  963. (done cps))))
  964. (define (box-vars cps names vars done)
  965. (match vars
  966. (() (done cps))
  967. ((var . vars)
  968. (match names
  969. ((name . names)
  970. (box-var cps name var
  971. (lambda (cps)
  972. (box-vars cps names vars done))))))))
  973. (with-cps cps
  974. (let$ box-term (box-vars names vars
  975. (lambda (cps)
  976. (with-cps cps term))))
  977. (setk label ($kargs names bound-vars ,box-term)))))))
  978. (compute-box-labels)
  979. cps))
  980. (box-results (unbox-operands)))
  981. (define (specialize-phis cps)
  982. (intmap-fold
  983. (lambda (kfun body cps)
  984. (let* ((preds (compute-predecessors cps kfun #:labels body))
  985. (defs (compute-defs cps body))
  986. (phis (compute-specializable-phis cps body preds defs)))
  987. (if (eq? phis empty-intmap)
  988. cps
  989. (apply-specialization cps kfun body preds defs phis))))
  990. (compute-reachable-functions cps)
  991. cps))
  992. (define (specialize-numbers cps)
  993. ;; Type inference wants a renumbered graph; OK.
  994. (let ((cps (renumber cps)))
  995. (with-fresh-name-state cps
  996. (specialize-phis (specialize-operations cps)))))