utils.scm 19 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493
  1. ;;; Continuation-passing style (CPS) intermediate language (IL)
  2. ;; Copyright (C) 2013, 2014, 2015, 2017, 2018, 2019, 2020, 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. ;;; Helper facilities for working with CPS.
  19. ;;;
  20. ;;; Code:
  21. (define-module (language cps utils)
  22. #:use-module (ice-9 match)
  23. #:use-module (srfi srfi-1)
  24. #:use-module (srfi srfi-11)
  25. #:use-module (system base target)
  26. #:use-module (language cps)
  27. #:use-module (language cps intset)
  28. #:use-module (language cps intmap)
  29. #:use-module (language cps graphs)
  30. #:export (;; Fresh names.
  31. label-counter var-counter
  32. fresh-label fresh-var
  33. with-fresh-name-state compute-max-label-and-var
  34. let-fresh
  35. ;; Graphs.
  36. compute-function-body
  37. compute-singly-referenced-labels
  38. compute-reachable-functions
  39. compute-successors
  40. compute-predecessors
  41. compute-idoms
  42. compute-dom-edges
  43. compute-defs-and-uses
  44. primcall-raw-representations
  45. compute-var-representations)
  46. #:re-export (fold1 fold2
  47. trivial-intset
  48. intmap-map
  49. intmap-keys
  50. invert-bijection invert-partition
  51. intset->intmap
  52. intmap-select
  53. worklist-fold
  54. fixpoint
  55. ;; Flow analysis.
  56. invert-graph
  57. compute-reverse-post-order
  58. compute-strongly-connected-components
  59. compute-sorted-strongly-connected-components
  60. solve-flow-equations))
  61. (define label-counter (make-parameter #f))
  62. (define var-counter (make-parameter #f))
  63. (define (fresh-label)
  64. (let ((count (or (label-counter)
  65. (error "fresh-label outside with-fresh-name-state"))))
  66. (label-counter (1+ count))
  67. count))
  68. (define (fresh-var)
  69. (let ((count (or (var-counter)
  70. (error "fresh-var outside with-fresh-name-state"))))
  71. (var-counter (1+ count))
  72. count))
  73. (define-syntax-rule (let-fresh (label ...) (var ...) body ...)
  74. (let* ((label (fresh-label)) ...
  75. (var (fresh-var)) ...)
  76. body ...))
  77. (define-syntax-rule (with-fresh-name-state fun body ...)
  78. (call-with-values (lambda () (compute-max-label-and-var fun))
  79. (lambda (max-label max-var)
  80. (parameterize ((label-counter (1+ max-label))
  81. (var-counter (1+ max-var)))
  82. body ...))))
  83. (define (compute-max-label-and-var conts)
  84. (values (or (intmap-prev conts) -1)
  85. (intmap-fold (lambda (k cont max-var)
  86. (match cont
  87. (($ $kargs names syms body)
  88. (apply max max-var syms))
  89. (($ $kfun src meta (and self (not #f)))
  90. (max max-var self))
  91. (_ max-var)))
  92. conts
  93. -1)))
  94. (define (compute-function-body conts kfun)
  95. (persistent-intset
  96. (let visit-cont ((label kfun) (labels empty-intset))
  97. (cond
  98. ((intset-ref labels label) labels)
  99. (else
  100. (let ((labels (intset-add! labels label)))
  101. (match (intmap-ref conts label)
  102. (($ $kreceive arity k) (visit-cont k labels))
  103. (($ $kfun src meta self ktail kclause)
  104. (let ((labels (visit-cont ktail labels)))
  105. (if kclause
  106. (visit-cont kclause labels)
  107. labels)))
  108. (($ $ktail) labels)
  109. (($ $kclause arity kbody kalt)
  110. (if kalt
  111. (visit-cont kalt (visit-cont kbody labels))
  112. (visit-cont kbody labels)))
  113. (($ $kargs names syms term)
  114. (match term
  115. (($ $continue k)
  116. (visit-cont k labels))
  117. (($ $branch kf kt)
  118. (visit-cont kf (visit-cont kt labels)))
  119. (($ $switch kf kt*)
  120. (visit-cont kf (fold1 visit-cont kt* labels)))
  121. (($ $prompt k kh)
  122. (visit-cont k (visit-cont kh labels)))
  123. (($ $throw)
  124. labels))))))))))
  125. (define (compute-singly-referenced-labels conts)
  126. "Compute the set of labels in CONTS that have exactly one
  127. predecessor."
  128. (define (add-ref label cont single multiple)
  129. (define (ref k single multiple)
  130. (if (intset-ref single k)
  131. (values single (intset-add! multiple k))
  132. (values (intset-add! single k) multiple)))
  133. (define (ref0) (values single multiple))
  134. (define (ref1 k) (ref k single multiple))
  135. (define (ref2 k k*)
  136. (if k*
  137. (let-values (((single multiple) (ref k single multiple)))
  138. (ref k* single multiple))
  139. (ref1 k)))
  140. (match cont
  141. (($ $kreceive arity k) (ref1 k))
  142. (($ $kfun src meta self ktail kclause) (ref2 ktail kclause))
  143. (($ $ktail) (ref0))
  144. (($ $kclause arity kbody kalt) (ref2 kbody kalt))
  145. (($ $kargs names syms ($ $continue k)) (ref1 k))
  146. (($ $kargs names syms ($ $branch kf kt)) (ref2 kf kt))
  147. (($ $kargs names syms ($ $switch kf kt*))
  148. (fold2 ref (cons kf kt*) single multiple))
  149. (($ $kargs names syms ($ $prompt k kh)) (ref2 k kh))
  150. (($ $kargs names syms ($ $throw)) (ref0))))
  151. (let*-values (((single multiple) (values empty-intset empty-intset))
  152. ((single multiple) (intmap-fold add-ref conts single multiple)))
  153. (intset-subtract (persistent-intset single)
  154. (persistent-intset multiple))))
  155. (define* (compute-reachable-functions conts #:optional (kfun 0))
  156. "Compute a mapping LABEL->LABEL..., where each key is a reachable
  157. $kfun and each associated value is the body of the function, as an
  158. intset."
  159. (define (intset-cons i set) (intset-add set i))
  160. (define (visit-fun kfun body to-visit)
  161. (intset-fold
  162. (lambda (label to-visit)
  163. (define (return kfun*) (fold intset-cons to-visit kfun*))
  164. (define (return1 kfun) (intset-add to-visit kfun))
  165. (define (return0) to-visit)
  166. (match (intmap-ref conts label)
  167. (($ $kargs _ _ ($ $continue _ _ exp))
  168. (match exp
  169. (($ $fun label) (return1 label))
  170. (($ $rec _ _ (($ $fun labels) ...)) (return labels))
  171. (($ $const-fun label) (return1 label))
  172. (($ $code label) (return1 label))
  173. (($ $callk label) (return1 label))
  174. (_ (return0))))
  175. (_ (return0))))
  176. body
  177. to-visit))
  178. (let lp ((to-visit (intset kfun)) (visited empty-intmap))
  179. (let ((to-visit (intset-subtract to-visit (intmap-keys visited))))
  180. (if (eq? to-visit empty-intset)
  181. visited
  182. (call-with-values
  183. (lambda ()
  184. (intset-fold
  185. (lambda (kfun to-visit visited)
  186. (let ((body (compute-function-body conts kfun)))
  187. (values (visit-fun kfun body to-visit)
  188. (intmap-add visited kfun body))))
  189. to-visit
  190. empty-intset
  191. visited))
  192. lp)))))
  193. (define* (compute-successors conts #:optional (kfun (intmap-next conts)))
  194. (define (visit label succs)
  195. (let visit ((label kfun) (succs empty-intmap))
  196. (define (propagate0)
  197. (intmap-add! succs label empty-intset))
  198. (define (propagate1 succ)
  199. (visit succ (intmap-add! succs label (intset succ))))
  200. (define (propagate2 succ0 succ1)
  201. (let ((succs (intmap-add! succs label (intset succ0 succ1))))
  202. (visit succ1 (visit succ0 succs))))
  203. (define (propagate* k*)
  204. (define (list->intset ls)
  205. (fold1 (lambda (elt set) (intset-add set elt)) ls empty-intset))
  206. (fold1 visit k* (intmap-add! succs label (list->intset k*))))
  207. (if (intmap-ref succs label (lambda (_) #f))
  208. succs
  209. (match (intmap-ref conts label)
  210. (($ $kargs names vars term)
  211. (match term
  212. (($ $continue k) (propagate1 k))
  213. (($ $branch kf kt) (propagate2 kf kt))
  214. (($ $switch kf kt*) (propagate* (cons kf kt*)))
  215. (($ $prompt k kh) (propagate2 k kh))
  216. (($ $throw) (propagate0))))
  217. (($ $kreceive arity k)
  218. (propagate1 k))
  219. (($ $kfun src meta self tail clause)
  220. (if clause
  221. (propagate2 clause tail)
  222. (propagate1 tail)))
  223. (($ $kclause arity kbody kalt)
  224. (if kalt
  225. (propagate2 kbody kalt)
  226. (propagate1 kbody)))
  227. (($ $ktail) (propagate0))))))
  228. (persistent-intmap (visit kfun empty-intmap)))
  229. (define* (compute-predecessors conts kfun #:key
  230. (labels (compute-function-body conts kfun)))
  231. (define (meet cdr car)
  232. (cons car cdr))
  233. (define (add-preds label preds)
  234. (define (add-pred k preds)
  235. (intmap-add! preds k label meet))
  236. (match (intmap-ref conts label)
  237. (($ $kreceive arity k)
  238. (add-pred k preds))
  239. (($ $kfun src meta self ktail kclause)
  240. (add-pred ktail (if kclause (add-pred kclause preds) preds)))
  241. (($ $ktail)
  242. preds)
  243. (($ $kclause arity kbody kalt)
  244. (add-pred kbody (if kalt (add-pred kalt preds) preds)))
  245. (($ $kargs names syms term)
  246. (match term
  247. (($ $continue k) (add-pred k preds))
  248. (($ $branch kf kt) (add-pred kf (add-pred kt preds)))
  249. (($ $switch kf kt*) (fold1 add-pred (cons kf kt*) preds))
  250. (($ $prompt k kh) (add-pred k (add-pred kh preds)))
  251. (($ $throw) preds)))))
  252. (persistent-intmap
  253. (intset-fold add-preds labels
  254. (intset->intmap (lambda (label) '()) labels))))
  255. ;; Precondition: For each function in CONTS, the continuation names are
  256. ;; topologically sorted.
  257. (define (compute-idoms conts kfun)
  258. ;; This is the iterative O(n^2) fixpoint algorithm, originally from
  259. ;; Allen and Cocke ("Graph-theoretic constructs for program flow
  260. ;; analysis", 1972). See the discussion in Cooper, Harvey, and
  261. ;; Kennedy's "A Simple, Fast Dominance Algorithm", 2001.
  262. (let ((preds-map (compute-predecessors conts kfun)))
  263. (define (compute-idom idoms preds)
  264. (define (idom-ref label)
  265. (intmap-ref idoms label (lambda (_) #f)))
  266. (match preds
  267. (() -1)
  268. ((pred) pred) ; Shortcut.
  269. ((pred . preds)
  270. (define (common-idom d0 d1)
  271. ;; We exploit the fact that a reverse post-order is a
  272. ;; topological sort, and so the idom of a node is always
  273. ;; numerically less than the node itself.
  274. (let lp ((d0 d0) (d1 d1))
  275. (cond
  276. ;; d0 or d1 can be false on the first iteration.
  277. ((not d0) d1)
  278. ((not d1) d0)
  279. ((= d0 d1) d0)
  280. ((< d0 d1) (lp d0 (idom-ref d1)))
  281. (else (lp (idom-ref d0) d1)))))
  282. (fold1 common-idom preds pred))))
  283. (define (adjoin-idom label preds idoms)
  284. (let ((idom (compute-idom idoms preds)))
  285. ;; Don't use intmap-add! here.
  286. (intmap-add idoms label idom (lambda (old new) new))))
  287. (fixpoint (lambda (idoms)
  288. (intmap-fold adjoin-idom preds-map idoms))
  289. empty-intmap)))
  290. ;; Compute a vector containing, for each node, a list of the nodes that
  291. ;; it immediately dominates. These are the "D" edges in the DJ tree.
  292. (define (compute-dom-edges idoms)
  293. (define (snoc cdr car) (cons car cdr))
  294. (persistent-intmap
  295. (intmap-fold (lambda (label idom doms)
  296. (let ((doms (intmap-add! doms label '())))
  297. (cond
  298. ((< idom 0) doms) ;; No edge to entry.
  299. (else (intmap-add! doms idom label snoc)))))
  300. idoms
  301. empty-intmap)))
  302. (define (compute-defs-and-uses cps)
  303. "Return two LABEL->VAR... maps indicating values defined at and used
  304. by a label, respectively."
  305. (define (vars->intset vars)
  306. (fold (lambda (var set) (intset-add set var)) empty-intset vars))
  307. (define-syntax-rule (persistent-intmap2 exp)
  308. (call-with-values (lambda () exp)
  309. (lambda (a b)
  310. (values (persistent-intmap a) (persistent-intmap b)))))
  311. (persistent-intmap2
  312. (intmap-fold
  313. (lambda (label cont defs uses)
  314. (define (get-defs k)
  315. (match (intmap-ref cps k)
  316. (($ $kargs names vars) (vars->intset vars))
  317. (_ empty-intset)))
  318. (define (return d u)
  319. (values (intmap-add! defs label d)
  320. (intmap-add! uses label u)))
  321. (match cont
  322. (($ $kfun src meta self tail clause)
  323. (return (intset-union
  324. (if clause (get-defs clause) empty-intset)
  325. (if self (intset self) empty-intset))
  326. empty-intset))
  327. (($ $kargs _ _ ($ $continue k src exp))
  328. (match exp
  329. ((or ($ $const) ($ $const-fun) ($ $code) ($ $prim))
  330. (return (get-defs k) empty-intset))
  331. (($ $call proc args)
  332. (return (get-defs k) (intset-add (vars->intset args) proc)))
  333. (($ $callk _ proc args)
  334. (let ((args (vars->intset args)))
  335. (return (get-defs k) (if proc (intset-add args proc) args))))
  336. (($ $calli args callee)
  337. (return (get-defs k) (intset-add (vars->intset args) callee)))
  338. (($ $primcall name param args)
  339. (return (get-defs k) (vars->intset args)))
  340. (($ $values args)
  341. (return (get-defs k) (vars->intset args)))))
  342. (($ $kargs _ _ ($ $branch kf kt src op param args))
  343. (return empty-intset (vars->intset args)))
  344. (($ $kargs _ _ ($ $switch kf kt* src arg))
  345. (return empty-intset (intset arg)))
  346. (($ $kargs _ _ ($ $prompt k kh src escape? tag))
  347. (return empty-intset (intset tag)))
  348. (($ $kargs _ _ ($ $throw src op param args))
  349. (return empty-intset (vars->intset args)))
  350. (($ $kclause arity body alt)
  351. (return (get-defs body) empty-intset))
  352. (($ $kreceive arity kargs)
  353. (return (get-defs kargs) empty-intset))
  354. (($ $ktail)
  355. (return empty-intset empty-intset))))
  356. cps
  357. empty-intmap
  358. empty-intmap)))
  359. (define (primcall-raw-representations name param)
  360. (case name
  361. ((scm->f64
  362. load-f64 s64->f64
  363. f32-ref f64-ref
  364. fadd fsub fmul fdiv fsqrt fabs
  365. fadd/immediate fmul/immediate
  366. ffloor fceiling
  367. fsin fcos ftan fasin facos fatan fatan2)
  368. '(f64))
  369. ((scm->u64
  370. scm->u64/truncate load-u64
  371. s64->u64
  372. assume-u64
  373. uadd usub umul
  374. ulogand ulogior ulogxor ulogsub ursh ulsh
  375. uadd/immediate usub/immediate umul/immediate
  376. ursh/immediate ulsh/immediate
  377. ulogand/immediate
  378. u8-ref u16-ref u32-ref u64-ref
  379. word-ref word-ref/immediate
  380. untag-char
  381. vector-length vtable-size bv-length
  382. string-length string-ref
  383. symbol-hash)
  384. '(u64))
  385. ((untag-fixnum
  386. assume-s64
  387. scm->s64 load-s64 u64->s64
  388. sadd ssub smul
  389. sadd/immediate ssub/immediate smul/immediate
  390. slsh slsh/immediate
  391. srsh srsh/immediate
  392. s8-ref s16-ref s32-ref s64-ref)
  393. '(s64))
  394. ((pointer-ref/immediate
  395. tail-pointer-ref/immediate)
  396. '(ptr))
  397. ((bv-contents)
  398. '(bv-contents))
  399. (else #f)))
  400. (define* (compute-var-representations cps #:key (primcall-raw-representations
  401. primcall-raw-representations))
  402. (define (get-defs k)
  403. (match (intmap-ref cps k)
  404. (($ $kargs names vars) vars)
  405. (_ '())))
  406. (intmap-fold
  407. (lambda (label cont representations)
  408. (match cont
  409. (($ $kargs _ _ ($ $continue k _ exp))
  410. (match (get-defs k)
  411. (() representations)
  412. ((var)
  413. (match exp
  414. (($ $values (arg))
  415. (intmap-add representations var
  416. (intmap-ref representations arg)))
  417. (($ $callk)
  418. (intmap-add representations var 'scm))
  419. (($ $primcall name param args)
  420. (intmap-add representations var
  421. (match (primcall-raw-representations name param)
  422. (#f 'scm)
  423. ((repr) repr))))
  424. (($ $code)
  425. (intmap-add representations var 'code))
  426. ((or ($ $const) ($ $prim) ($ $const-fun) ($ $callk) ($ $calli))
  427. (intmap-add representations var 'scm))))
  428. (vars
  429. (match exp
  430. (($ $values args)
  431. (fold (lambda (arg var representations)
  432. (intmap-add representations var
  433. (intmap-ref representations arg)))
  434. representations args vars))
  435. (($ $primcall name param args)
  436. (match (primcall-raw-representations name param)
  437. (#f (error "unknown multi-valued primcall" exp))
  438. (reprs
  439. (unless (eqv? (length vars) (length reprs))
  440. (error "wrong number of reprs" exp reprs))
  441. (fold (lambda (var repr representations)
  442. (intmap-add representations var repr))
  443. representations vars reprs))))
  444. ((or ($ $callk) ($ $calli))
  445. (fold1 (lambda (var representations)
  446. (intmap-add representations var 'scm))
  447. vars representations))))))
  448. (($ $kargs _ _ (or ($ $branch) ($ $switch) ($ $prompt) ($ $throw)))
  449. representations)
  450. (($ $kfun src meta self tail entry)
  451. (let* ((representations (if self
  452. (intmap-add representations self 'scm)
  453. representations))
  454. (defs (get-defs entry))
  455. (reprs (or (assq-ref meta 'arg-representations)
  456. (map (lambda (_) 'scm) defs))))
  457. (fold (lambda (var repr representations)
  458. (intmap-add representations var repr))
  459. representations defs reprs)))
  460. (($ $kclause arity body alt)
  461. (fold1 (lambda (var representations)
  462. (intmap-add representations var 'scm))
  463. (get-defs body) representations))
  464. (($ $kreceive arity kargs)
  465. (fold1 (lambda (var representations)
  466. (intmap-add representations var 'scm))
  467. (get-defs kargs) representations))
  468. (($ $ktail) representations)))
  469. cps
  470. empty-intmap))