switch.scm 18 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420
  1. ;;; Continuation-passing style (CPS) intermediate language (IL)
  2. ;; Copyright (C) 2020, 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. ;;; A pass to optimize chains of "eq-constant?" branches.
  19. ;;;
  20. ;;; For chains that are more than a few comparisons long, we partition
  21. ;;; values by type, then dispatch in type-specific ways. For fixnums
  22. ;;; and chars, we use a combination of binary search over sparse sets,
  23. ;;; table dispatch over dense sets, and comparison chains when sets are
  24. ;;; small enough. For "special" values like #f and the eof-object, we
  25. ;;; just emit comparison chains. For symbols, we do a hash dispatch
  26. ;;; using the hash code from the symbol, or a comparison chain if the
  27. ;;; set is very small.
  28. ;;;
  29. ;;; Code:
  30. (define-module (language cps switch)
  31. #:use-module (ice-9 match)
  32. #:use-module (srfi srfi-9)
  33. #:use-module (language cps)
  34. #:use-module (language cps utils)
  35. #:use-module (language cps with-cps)
  36. #:use-module (language cps intmap)
  37. #:use-module (language cps intset)
  38. #:use-module (system base target)
  39. #:export (optimize-branch-chains))
  40. (define (fold-branch-chains cps kfun body f seed)
  41. "For each chain of one or more eq-constant? branches, where each
  42. branch tests the same variable, branches to the next if the match fails,
  43. and each non-head branch has only a single predecessor, fold F over SEED
  44. by calling as (F VAR EXIT TESTS SEED), where VAR is the value being
  45. tested, EXIT is the last failure continuation, and TESTS is an ordered
  46. list of branch labels."
  47. (define single
  48. (compute-singly-referenced-labels (intmap-select cps body)))
  49. (define (start-chain var exit test)
  50. (traverse-chain var exit (list test)))
  51. (define (finish-chain var exit tests)
  52. (values var exit (reverse tests)))
  53. (define (traverse-chain var exit tests)
  54. (match (intmap-ref cps exit)
  55. (($ $kargs () ()
  56. ($ $branch kf kt src 'eq-constant? const (arg)))
  57. (if (and (eq? arg var)
  58. (intset-ref single exit))
  59. (traverse-chain var kf (cons exit tests))
  60. (finish-chain var exit tests)))
  61. (_ (finish-chain var exit tests))))
  62. (let fold-chains ((worklist (list kfun))
  63. (visited empty-intset)
  64. (seed seed))
  65. (match worklist
  66. (() seed)
  67. ((label . worklist)
  68. (if (intset-ref visited label)
  69. (fold-chains worklist visited seed)
  70. (let ((visited (intset-add! visited label)))
  71. (define (%continue worklist)
  72. (fold-chains worklist visited seed))
  73. (define (continue0) (%continue worklist))
  74. (define (continue1 k) (%continue (cons k worklist)))
  75. (define (continue2 k1 k2) (%continue (cons* k1 k2 worklist)))
  76. (define (continue* k*) (%continue (append k* worklist)))
  77. (match (intmap-ref cps label)
  78. (($ $kfun src meta self ktail #f) (continue0))
  79. (($ $kfun src meta self ktail kclause) (continue1 kclause))
  80. (($ $kclause arity kbody #f) (continue1 kbody))
  81. (($ $kclause arity kbody kalt) (continue2 kbody kalt))
  82. (($ $kargs names vars term)
  83. (match term
  84. (($ $branch kf kt src 'eq-constant? const (arg))
  85. (call-with-values (lambda () (start-chain arg kf label))
  86. (lambda (var exit tests)
  87. (fold-chains (cons exit worklist)
  88. (fold1 (lambda (k visited)
  89. (intset-add! visited k))
  90. tests visited)
  91. (f var exit tests seed)))))
  92. (($ $continue k) (continue1 k))
  93. (($ $branch kf kt) (continue2 kf kt))
  94. (($ $switch kf kt*) (continue* (cons kf kt*)))
  95. (($ $prompt k kh) (continue2 k kh))
  96. (($ $throw) (continue0))))
  97. (($ $ktail) (continue0))
  98. (($ $kreceive arity kbody) (continue1 kbody)))))))))
  99. (define (length>? ls n)
  100. (match ls
  101. (() #f)
  102. ((_ . ls)
  103. (or (zero? n)
  104. (length>? ls (1- n))))))
  105. (define (partition-targets targets)
  106. "Partition the list of (CONST . KT) values into five unordered
  107. sub-lists, ignoring duplicates, according to CONST type: fixnums, chars,
  108. \"special\" values, symbols, and other values. A special value is one
  109. of the immediates #f, (), #t, #nil, the EOF object, or the unspecified
  110. object."
  111. (define (hash-table->alist table)
  112. (hash-map->list cons table))
  113. (define (hash-table->sorted-alist table less?)
  114. (sort (hash-table->alist table) (lambda (a b) (less? (car a) (car b)))))
  115. (let ((fixnums (make-hash-table))
  116. (chars (make-hash-table))
  117. (specials (make-hash-table))
  118. (symbols (make-hash-table))
  119. (others (make-hash-table)))
  120. (for-each (match-lambda
  121. ((const . k)
  122. (let ((table (cond
  123. ((target-fixnum? const) fixnums)
  124. ((char? const) chars)
  125. ((eq? const #f) specials)
  126. ((eq? const '()) specials)
  127. ((eq? const #t) specials)
  128. ((eq? const #nil) specials)
  129. ((eof-object? const) specials)
  130. ((unspecified? const) specials)
  131. ((symbol? const) symbols)
  132. (else others))))
  133. (unless (hashq-ref table const)
  134. (hashq-set! table const k)))))
  135. targets)
  136. (values (hash-table->sorted-alist fixnums <)
  137. (hash-table->sorted-alist chars char<?)
  138. (hash-table->alist specials)
  139. (hash-table->sorted-alist symbols
  140. (lambda (s1 s2)
  141. (string< (symbol->string s1)
  142. (symbol->string s2))))
  143. (hash-table->alist others))))
  144. ;; Leave any chain this long or less as is.
  145. (define *unoptimized-chain-length* 4)
  146. ;; If we are optimizing a subset of targets, any subset this long or
  147. ;; less will be reified as a chain of comparisons.
  148. (define *leaf-chain-max-length* 3)
  149. ;; If we end up dispatching via type check with an eye to maybe doing
  150. ;; binary/table lookup but the set of targets for the type is this long
  151. ;; or less, just reify a chain instead of untagging.
  152. (define *tagged-chain-max-length* 2)
  153. ;; When deciding whether to dispatch via binary search or via a switch
  154. ;; on constants in a range, do a switch if at least this fraction of
  155. ;; constants in the range have continuations.
  156. (define *table-switch-minimum-density* 0.5)
  157. ;; When deciding whether to dispatch via hash value on a set of symbol
  158. ;; targets, reify a branch chain unless there are more than this many
  159. ;; targets. Otherwise the cost outweighs the savings.
  160. (define *symbol-hash-dispatch-min-length* 4)
  161. (define (optimize-branch-chain var exit tests cps)
  162. (define (should-optimize? targets)
  163. (define (has-duplicates? targets)
  164. (let ((consts (make-hash-table)))
  165. (or-map (match-lambda
  166. ((const . k)
  167. (or (hash-ref consts const)
  168. (begin
  169. (hash-set! consts const #t)
  170. #f))))
  171. targets)))
  172. ;; We optimize if there are "enough" targets, or if there are any
  173. ;; duplicate targets.
  174. (or (length>? targets *unoptimized-chain-length*)
  175. (has-duplicates? targets)))
  176. (define (reify-chain cps var targets op k)
  177. (match targets
  178. (() (with-cps cps k))
  179. (((const . kt) . targets)
  180. (with-cps cps
  181. (let$ ktail (reify-chain var targets op k))
  182. (letk khead ($kargs () ()
  183. ($branch ktail kt #f op const (var))))
  184. khead))))
  185. (define (reify-switch cps var targets min max exit)
  186. (cond
  187. ((zero? min)
  188. (let ((kt* (make-vector (1+ max) exit)))
  189. (for-each (match-lambda
  190. ((target . k) (vector-set! kt* target k)))
  191. targets)
  192. (with-cps cps
  193. (letv u64)
  194. (letk kswitch ($kargs ('u64) (u64)
  195. ($switch exit (vector->list kt*) #f u64)))
  196. (letk kcvt
  197. ($kargs () ()
  198. ($continue kswitch #f ($primcall 's64->u64 #f (var)))))
  199. kcvt)))
  200. (else
  201. (let ((targets (map (match-lambda
  202. ((target . k) (cons (- target min) k)))
  203. targets))
  204. (op (if (positive? min) 'ssub/immediate 'sadd/immediate)))
  205. (with-cps cps
  206. (letv idx)
  207. (let$ kcvt (reify-switch idx targets 0 (- max min) exit))
  208. (letk kzero ($kargs ('idx) (idx)
  209. ($continue kcvt #f ($values ()))))
  210. (letk ksub
  211. ($kargs () ()
  212. ($continue kzero #f ($primcall op (abs min) (var)))))
  213. ksub)))))
  214. (define (dispatch-numerics cps var targets start end exit)
  215. ;; Precondition: VAR is an s64, START < END, and TARGETS hold the
  216. ;; untagged values.
  217. (define (value-at idx)
  218. (match (vector-ref targets idx)
  219. ((const . k) const)))
  220. (define (target-list)
  221. (let lp ((i start))
  222. (if (< i end)
  223. (cons (vector-ref targets i) (lp (1+ i)))
  224. '())))
  225. (let* ((min (value-at start))
  226. (max (value-at (1- end)))
  227. (range (1+ (- max min)))
  228. (len (- end start))
  229. (density (/ len 1.0 range)))
  230. (cond
  231. ((<= len *leaf-chain-max-length*)
  232. (reify-chain cps var (target-list) 's64-imm-= exit))
  233. ((<= *table-switch-minimum-density* density)
  234. (reify-switch cps var (target-list) min max exit))
  235. (else
  236. ;; binary search
  237. (let* ((split (ash (+ start end) -1))
  238. (mid (value-at split)))
  239. (with-cps cps
  240. (let$ klo (dispatch-numerics var targets start split exit))
  241. (let$ khi (dispatch-numerics var targets split end exit))
  242. (letk ktest
  243. ($kargs () ()
  244. ($branch khi klo #f 's64-imm-< mid (var))))
  245. ktest))))))
  246. (define (reify-known-numerics cps var targets untag-var untag-val exit)
  247. (cond
  248. ((length>? targets *tagged-chain-max-length*)
  249. (let ((targets (list->vector
  250. (map (match-lambda
  251. ((const . k) (cons (untag-val const) k)))
  252. targets))))
  253. (with-cps cps
  254. (letv raw)
  255. (let$ kdispatch
  256. (dispatch-numerics raw targets 0 (vector-length targets) exit))
  257. (letk kraw ($kargs ('raw) (raw)
  258. ($continue kdispatch #f ($values ()))))
  259. (let$ untag (untag-var var kraw))
  260. (letk kuntag ($kargs () () ,untag))
  261. kuntag)))
  262. (else
  263. (reify-chain cps var targets 'eq-constant? exit))))
  264. (define (reify-numeric cps var targets pred untag-var untag-val next exit)
  265. (cond
  266. ((null? targets) (with-cps cps next))
  267. (else
  268. (with-cps cps
  269. (let$ ktype (reify-known-numerics var targets untag-var untag-val exit))
  270. (letk test ($kargs () () ($branch next ktype #f pred #f (var))))
  271. test))))
  272. (define (reify-fixnums cps var targets next exit)
  273. (reify-numeric cps var targets 'fixnum?
  274. (lambda (cps var k)
  275. (with-cps cps
  276. (build-term
  277. ($continue k #f
  278. ($primcall 'untag-fixnum #f (var))))))
  279. identity next exit))
  280. (define (reify-chars cps var targets next exit)
  281. (reify-numeric cps var targets 'char?
  282. (lambda (cps var k)
  283. (with-cps cps
  284. (letv u64)
  285. (letk kcvt
  286. ($kargs ('u64) (u64)
  287. ($continue k #f
  288. ($primcall 'u64->s64 #f (u64)))))
  289. (build-term
  290. ($continue kcvt #f
  291. ($primcall 'untag-char #f (var))))))
  292. char->integer next exit))
  293. (define (reify-specials cps var targets next exit)
  294. ;; Specials are a branch chain.
  295. (cond
  296. ((null? targets) (with-cps cps next))
  297. (else
  298. (with-cps cps
  299. (let$ kimm (reify-chain var targets 'eq-constant? exit))
  300. (letk test ($kargs () () ($branch kimm next #f 'heap-object? #f (var))))
  301. test))))
  302. (define (reify-symbols cps var targets next exit)
  303. (cond
  304. ((null? targets)
  305. (with-cps cps next))
  306. ((length>? targets *symbol-hash-dispatch-min-length*)
  307. ;; Hash dispatch. The value has symbol-hash-bits significant
  308. ;; bits. We dispatch on the bottom N bits of the significant
  309. ;; bits, where N <= symbol-hash-bits, for the smallest N for which
  310. ;; len(targets) <= 2^N.
  311. (let* ((backend (resolve-interface `(language cps ,(target-runtime))))
  312. (symbol-hash (module-ref backend 'target-symbol-hash))
  313. (symbol-hash-bits (module-ref backend 'target-symbol-hash-bits))
  314. (nbits (let ((ntargets (length targets)))
  315. (let lp ((nbits 2))
  316. (cond
  317. ((= nbits symbol-hash-bits) nbits)
  318. ((<= ntargets (ash 1 nbits)) nbits)
  319. (else (lp (1+ nbits)))))))
  320. (nbuckets (ash 1 nbits))
  321. (buckets (make-vector nbuckets '()))
  322. (kt* (make-vector nbuckets exit)))
  323. (define (symbol->bucket sym)
  324. (logand (1- nbuckets) (symbol-hash (symbol->string sym))))
  325. (define (vector-push! v i x)
  326. (vector-set! v i (cons x (vector-ref v i))))
  327. (for-each (match-lambda
  328. ((and pair (sym . target))
  329. (vector-push! buckets (symbol->bucket sym) pair)))
  330. targets)
  331. (let lp ((cps cps) (i 0))
  332. (cond
  333. ((< i nbuckets)
  334. (call-with-values (lambda ()
  335. (reify-chain cps var (vector-ref buckets i)
  336. 'eq-constant? exit))
  337. (lambda (cps k)
  338. (vector-set! kt* i k)
  339. (lp cps (1+ i)))))
  340. (else
  341. (with-cps cps
  342. (letv hash idx)
  343. (letk kswitch
  344. ($kargs ('idx) (idx)
  345. ($switch exit (vector->list kt*) #f idx)))
  346. (letk kidx
  347. ($kargs ('hash) (hash)
  348. ($continue kswitch #f
  349. ($primcall 'ulogand/immediate (1- nbuckets) (hash)))))
  350. (letk khash
  351. ($kargs () ()
  352. ($continue kidx #f
  353. ($primcall 'symbol-hash #f (var)))))
  354. (letk ksym
  355. ($kargs () ()
  356. ($branch next khash #f 'symbol? #f (var))))
  357. (letk kheap
  358. ($kargs () ()
  359. ($branch next ksym #f 'heap-object? #f (var))))
  360. kheap))))))
  361. (else
  362. (reify-chain cps var targets 'eq-constant? next))))
  363. (define (reify-others cps var targets exit)
  364. ;; Not an immediate, not a symbol -- an object without identity.
  365. ;; Perhaps it's reasonable to assume all these don't match.
  366. (reify-chain cps var targets 'eq-constant? exit))
  367. (define (apply-optimizations var exit tests targets)
  368. (call-with-values (lambda () (partition-targets targets))
  369. (lambda (fixnums chars specials symbols others)
  370. (match (intmap-ref cps (car tests))
  371. (($ $kargs names vars _)
  372. (with-cps cps
  373. ;; Reify an optimized version of the chain, and bind k to
  374. ;; its label.
  375. (let$ k (reify-others var others exit))
  376. (let$ k (reify-symbols var symbols k exit))
  377. (let$ k (reify-specials var specials k exit))
  378. (let$ k (reify-chars var chars k exit))
  379. (let$ k (reify-fixnums var fixnums k exit))
  380. (setk (car tests)
  381. ;; Here we introduce a useless forwarding node in
  382. ;; order to treat each node as being a nullary
  383. ;; $kargs. Simplification will remove it later.
  384. ($kargs names vars
  385. ($continue k #f ($values ()))))))))))
  386. (let ((targets (map (lambda (test)
  387. (match (intmap-ref cps test)
  388. (($ $kargs _ _ ($ $branch kf kt src op const (_)))
  389. (cons const kt))))
  390. tests)))
  391. (if (should-optimize? targets)
  392. (apply-optimizations var exit tests targets)
  393. cps)))
  394. (define (optimize-branch-chains cps)
  395. (with-fresh-name-state cps
  396. (persistent-intmap
  397. (intmap-fold
  398. (lambda (kfun body cps)
  399. (fold-branch-chains cps kfun body
  400. optimize-branch-chain cps))
  401. (compute-reachable-functions cps)
  402. cps))))