contification.scm 23 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577
  1. ;;; Continuation-passing style (CPS) intermediate language (IL)
  2. ;; Copyright (C) 2013-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. ;;; Contification is a pass that turns $fun instances into $cont
  19. ;;; instances if all calls to the $fun return to the same continuation.
  20. ;;; This is a more rigorous variant of our old "fixpoint labels
  21. ;;; allocation" optimization.
  22. ;;;
  23. ;;; See Kennedy's "Compiling with Continuations, Continued", and Fluet
  24. ;;; and Weeks's "Contification using Dominators".
  25. ;;;
  26. ;;; Code:
  27. (define-module (language cps contification)
  28. #:use-module (ice-9 match)
  29. #:use-module (srfi srfi-11)
  30. #:use-module ((srfi srfi-1) #:select (fold))
  31. #:use-module (language cps)
  32. #:use-module (language cps renumber)
  33. #:use-module (language cps utils)
  34. #:use-module (language cps intmap)
  35. #:use-module (language cps intset)
  36. #:use-module (language cps with-cps)
  37. #:export (contify))
  38. (define (compute-first-class-functions conts)
  39. "Compute the set of $kfun labels in @var{conts} that can be called by
  40. value rather than by label. Assumes @var{conts} contains only reachable
  41. conts. Assumes each $kfun is only made into a first class value by a
  42. single label. Returns an intmap map from $kfun label to label in which
  43. the first-class function is defined."
  44. (define (add kdef kfun first-class)
  45. (intmap-add! first-class kfun kdef))
  46. (persistent-intmap
  47. (intmap-fold
  48. (lambda (label cont first-class)
  49. (match cont
  50. (($ $kargs _ _ ($ $continue k src ($ $fun kfun)))
  51. (add label kfun first-class))
  52. (($ $kargs _ _ ($ $continue k src
  53. ($ $rec _ vars (($ $fun kfuns) ...))))
  54. (fold (lambda (kfun first-class)
  55. (add label kfun first-class))
  56. first-class
  57. kfuns))
  58. (_ first-class)))
  59. conts
  60. empty-intmap)))
  61. (define (compute-functions-called-by-label conts)
  62. "Compute the set of $kfun labels in @var{conts} which are targets of
  63. $callk."
  64. (persistent-intset
  65. (intmap-fold
  66. (lambda (label cont by-label)
  67. (match cont
  68. (($ $kargs _ _ ($ $continue k src ($ $callk kfun)))
  69. (intset-add! by-label kfun))
  70. (_ by-label)))
  71. conts
  72. empty-intset)))
  73. (define (compute-functions conts)
  74. "Compute a map from $kfun label to bound variable names for all
  75. functions in CONTS. Functions have two bound variable names: their self
  76. binding, and the name they are given in their continuation. If their
  77. continuation has more than one predecessor, then the bound variable name
  78. doesn't uniquely identify the function, so we exclude that function from
  79. the set."
  80. (define (function-self label)
  81. (match (intmap-ref conts label)
  82. (($ $kfun src meta self) self)))
  83. (let* ((single (compute-singly-referenced-labels conts))
  84. (first-class (compute-first-class-functions conts))
  85. (first-class-defs (persistent-intset
  86. (intmap-fold (lambda (kfun def all-defs)
  87. (intset-add! all-defs def))
  88. first-class
  89. empty-intset)))
  90. (by-label (compute-functions-called-by-label conts)))
  91. (define (first-class-bound-names)
  92. (intset-fold
  93. (lambda (kdef bound-names)
  94. (match (intmap-ref conts kdef)
  95. (($ $kargs _ _ ($ $continue k src ($ $fun kfun)))
  96. (if (intset-ref single k)
  97. (match (intmap-ref conts k)
  98. (($ $kargs (name) (var))
  99. (intmap-add bound-names kfun
  100. (intset var (function-self kfun)))))
  101. bound-names))
  102. (($ $kargs _ _ ($ $continue k src
  103. ($ $rec _ vars (($ $fun kfuns) ...))))
  104. (if (intset-ref single k)
  105. (fold (lambda (var kfun bound-names)
  106. (intmap-add bound-names kfun
  107. (intset var (function-self kfun))))
  108. bound-names vars kfuns)
  109. bound-names))))
  110. first-class-defs
  111. empty-intmap))
  112. (define (add-second-class-functions bound-names)
  113. (intset-fold
  114. (lambda (label bound-names)
  115. (cond
  116. ((intmap-ref first-class label (lambda (_) #f))
  117. ;; This function which is called by label also has
  118. ;; first-class uses. Either the bound names are known, in
  119. ;; which case the label is in bound-names, or they aren't, in
  120. ;; which case they aren't. Either way the presence of $callk
  121. ;; doesn't change the contifiability of a first-class
  122. ;; function.
  123. bound-names)
  124. (else
  125. ;; Otherwise this function is second-class: it has no value
  126. ;; and is only called by label. No bound names, but a
  127. ;; candidate for contification nonetheless.
  128. (intmap-add bound-names label empty-intset))))
  129. by-label
  130. bound-names))
  131. (persistent-intmap
  132. (add-second-class-functions
  133. (first-class-bound-names)))))
  134. (define (compute-arities conts functions)
  135. "Given the map FUNCTIONS whose keys are $kfun labels, return a map
  136. from label to arities."
  137. (define (clause-arities clause)
  138. (if clause
  139. (match (intmap-ref conts clause)
  140. (($ $kclause arity body alt)
  141. (cons arity (clause-arities alt)))
  142. (($ $kargs names vars _)
  143. ;; If this function's entry is a $kargs, all callers have
  144. ;; compatible arity; no need to check.
  145. #f))
  146. '()))
  147. (intmap-map (lambda (label vars)
  148. (match (intmap-ref conts label)
  149. (($ $kfun src meta self tail clause)
  150. (clause-arities clause))))
  151. functions))
  152. ;; For now, we don't contify functions with optional, keyword, or rest
  153. ;; arguments.
  154. (define (contifiable-arity? arity)
  155. (match arity
  156. (($ $arity req () #f () aok?)
  157. #t)
  158. (_
  159. #f)))
  160. (define (arity-matches? arity nargs)
  161. (match arity
  162. (($ $arity req () #f () aok?)
  163. (= nargs (length req)))
  164. (_
  165. #f)))
  166. (define (compute-contification-candidates conts)
  167. "Compute and return a label -> (variable ...) map describing all
  168. functions with known uses that are only ever used as the operator of a
  169. $call, and are always called with a compatible arity."
  170. (let* ((functions (compute-functions conts))
  171. (vars (invert-partition functions))
  172. (arities (compute-arities conts functions)))
  173. (define (restrict-arity functions proc nargs)
  174. (match (intmap-ref vars proc (lambda (_) #f))
  175. (#f functions)
  176. (label
  177. (let lp ((arities (intmap-ref arities label)))
  178. (match arities
  179. (() (intmap-remove functions label))
  180. ((arity . arities)
  181. (cond
  182. ((not (contifiable-arity? arity)) (lp '()))
  183. ((arity-matches? arity nargs) functions)
  184. (else (lp arities)))))))))
  185. (define (visit-cont label cont functions)
  186. (define (exclude-var functions var)
  187. (match (intmap-ref vars var (lambda (_) #f))
  188. (#f functions)
  189. (label (intmap-remove functions label))))
  190. (define (exclude-vars functions vars)
  191. (match vars
  192. (() functions)
  193. ((var . vars)
  194. (exclude-vars (exclude-var functions var) vars))))
  195. (match cont
  196. (($ $kargs _ _ ($ $continue _ _ exp))
  197. (match exp
  198. ((or ($ $const) ($ $prim) ($ $fun) ($ $rec))
  199. functions)
  200. (($ $const-fun kfun)
  201. (intmap-remove functions kfun))
  202. (($ $code kfun)
  203. (intmap-remove functions kfun))
  204. (($ $values args)
  205. (exclude-vars functions args))
  206. (($ $call proc args)
  207. (let ((functions (exclude-vars functions args)))
  208. ;; Note that this contification algorithm is happy to
  209. ;; contify the `lp' in this example into a shared tail
  210. ;; between clauses:
  211. ;;
  212. ;; (letrec ((lp (lambda () (lp))))
  213. ;; (case-lambda
  214. ;; ((a) (lp))
  215. ;; ((a b) (lp))))
  216. ;;
  217. ;; This can cause cross-clause jumps. The rest of the
  218. ;; compiler handles this fine though, so we allow it.
  219. (restrict-arity functions proc (length args))))
  220. (($ $callk k proc args)
  221. (exclude-vars functions (if proc (cons proc args) args)))
  222. (($ $calli args callee)
  223. ;; While callee is a var and not a label, it is a var that
  224. ;; holds a code label, not a function value.
  225. (exclude-vars functions args))
  226. (($ $primcall name param args)
  227. (exclude-vars functions args))))
  228. (($ $kargs _ _ ($ $branch kf kt src op param args))
  229. (exclude-vars functions args))
  230. (($ $kargs _ _ ($ $switch kf kt* src arg))
  231. (exclude-var functions arg))
  232. (($ $kargs _ _ ($ $prompt k kh src escape? tag))
  233. (exclude-var functions tag))
  234. (($ $kargs _ _ ($ $throw src op param args))
  235. (exclude-vars functions args))
  236. (_ functions)))
  237. (intmap-fold visit-cont conts functions)))
  238. (define (compute-call-graph conts labels vars)
  239. "Given the set of contifiable functions LABELS and associated bound
  240. variables VARS, compute and return two values: a map
  241. LABEL->LABEL... indicating the contifiable functions called by a
  242. function, and a map LABEL->LABEL... indicating the return continuations
  243. for a function. The first return value also has an entry
  244. 0->LABEL... indicating all contifiable functions called by
  245. non-contifiable functions. We assume that 0 is not in the contifiable
  246. function set."
  247. (let ((bodies
  248. ;; label -> fun-label for all labels in bodies of contifiable
  249. ;; functions
  250. (intset-fold (lambda (fun-label bodies)
  251. (intset-fold (lambda (label bodies)
  252. (intmap-add bodies label fun-label))
  253. (compute-function-body conts fun-label)
  254. bodies))
  255. labels
  256. empty-intmap)))
  257. (when (intset-ref labels 0)
  258. (error "internal error: label 0 should not be contifiable"))
  259. (intmap-fold
  260. (lambda (label cont calls returns)
  261. (match cont
  262. (($ $kargs _ _ ($ $continue k src ($ $call proc)))
  263. (match (intmap-ref vars proc (lambda (_) #f))
  264. (#f (values calls returns))
  265. (callee
  266. (let ((caller (intmap-ref bodies label (lambda (_) 0))))
  267. (values (intmap-add calls caller callee intset-add)
  268. (intmap-add returns callee k intset-add))))))
  269. (($ $kargs _ _ ($ $continue k src ($ $callk callee)))
  270. (let ((caller (intmap-ref bodies label (lambda (_) 0))))
  271. (values (intmap-add calls caller callee intset-add)
  272. (intmap-add returns callee k intset-add))))
  273. (_ (values calls returns))))
  274. conts
  275. (intset->intmap (lambda (label) empty-intset) (intset-add labels 0))
  276. (intset->intmap (lambda (label) empty-intset) labels))))
  277. (define (tail-label conts label)
  278. (match (intmap-ref conts label)
  279. (($ $kfun src meta self tail body)
  280. tail)))
  281. (define (compute-return-labels labels tails returns return-substs)
  282. (define (subst k)
  283. (match (intmap-ref return-substs k (lambda (_) #f))
  284. (#f k)
  285. (k (subst k))))
  286. ;; Compute all return labels, then subtract tail labels of the
  287. ;; functions in question.
  288. (intset-subtract
  289. ;; Return labels for all calls to these labels.
  290. (intset-fold (lambda (label out)
  291. (intset-fold (lambda (k out)
  292. (intset-add out (subst k)))
  293. (intmap-ref returns label)
  294. out))
  295. labels
  296. empty-intset)
  297. (intset-fold (lambda (label out)
  298. (intset-add out (intmap-ref tails label)))
  299. labels
  300. empty-intset)))
  301. (define (intmap->intset map)
  302. (define (add-key label cont labels)
  303. (intset-add labels label))
  304. (intmap-fold add-key map empty-intset))
  305. (define (filter-contifiable contified groups)
  306. (intmap-fold (lambda (id labels groups)
  307. (let ((labels (intset-subtract labels contified)))
  308. (if (eq? empty-intset labels)
  309. groups
  310. (intmap-add groups id labels))))
  311. groups
  312. empty-intmap))
  313. (define (trivial-set set)
  314. (let ((first (intset-next set)))
  315. (and first
  316. (not (intset-next set (1+ first)))
  317. first)))
  318. (define (compute-contification conts)
  319. (let*-values
  320. (;; label -> (var ...)
  321. ((candidates) (compute-contification-candidates conts))
  322. ((labels) (intmap->intset candidates))
  323. ;; var -> label
  324. ((vars) (intmap-fold (lambda (label vars out)
  325. (intset-fold (lambda (var out)
  326. (intmap-add out var label))
  327. vars out))
  328. candidates
  329. empty-intmap))
  330. ;; caller-label -> callee-label..., callee-label -> return-label...
  331. ((calls returns) (compute-call-graph conts labels vars))
  332. ;; callee-label -> tail-label
  333. ((tails) (intset-fold
  334. (lambda (label tails)
  335. (intmap-add tails label (tail-label conts label)))
  336. labels
  337. empty-intmap))
  338. ;; Strongly connected components, allowing us to contify mutually
  339. ;; tail-recursive functions. Since `compute-call-graph' added on
  340. ;; a synthetic 0->LABEL... entry for contifiable functions called
  341. ;; by non-contifiable functions, we need to remove that entry
  342. ;; from the partition. It will be in its own component, as it
  343. ;; has no predecessors.
  344. ;;
  345. ;; id -> label...
  346. ((groups) (intmap-remove
  347. (compute-strongly-connected-components calls 0)
  348. 0)))
  349. ;; todo: thread groups through contification
  350. (define (attempt-contification labels contified return-substs)
  351. (let ((returns (compute-return-labels labels tails returns
  352. return-substs)))
  353. (cond
  354. ((trivial-set returns)
  355. => (lambda (k)
  356. ;; Success!
  357. (values (intset-union contified labels)
  358. (intset-fold (lambda (label return-substs)
  359. (let ((tail (intmap-ref tails label)))
  360. (intmap-add return-substs tail k)))
  361. labels return-substs))))
  362. ((trivial-set labels)
  363. ;; Single-label SCC failed to contify.
  364. (values contified return-substs))
  365. (else
  366. ;; Multi-label SCC failed to contify. Try instead to contify
  367. ;; each one.
  368. (intset-fold
  369. (lambda (label contified return-substs)
  370. (let ((labels (intset-add empty-intset label)))
  371. (attempt-contification labels contified return-substs)))
  372. labels contified return-substs)))))
  373. (call-with-values
  374. (lambda ()
  375. (fixpoint
  376. (lambda (contified return-substs)
  377. (intmap-fold
  378. (lambda (id group contified return-substs)
  379. (attempt-contification group contified return-substs))
  380. (filter-contifiable contified groups)
  381. contified
  382. return-substs))
  383. empty-intset
  384. empty-intmap))
  385. (lambda (contified return-substs)
  386. (values contified
  387. (intset-fold (lambda (label call-substs)
  388. (intset-fold
  389. (lambda (var call-substs)
  390. (intmap-add call-substs var label))
  391. (intmap-ref candidates label)
  392. call-substs))
  393. contified
  394. empty-intmap)
  395. return-substs)))))
  396. (define (apply-contification conts contified call-substs return-substs)
  397. (define (call-subst proc)
  398. (intmap-ref call-substs proc (lambda (_) #f)))
  399. (define (return-subst k)
  400. (intmap-ref return-substs k (lambda (_) #f)))
  401. (define (find-body kfun nargs)
  402. (match (intmap-ref conts kfun)
  403. (($ $kfun src meta self tail clause)
  404. (let lp ((clause clause))
  405. (match (intmap-ref conts clause)
  406. (($ $kclause arity body alt)
  407. (if (arity-matches? arity nargs)
  408. body
  409. (lp alt))))))))
  410. (define (inline-return cps k* kargs src nreq rest vals)
  411. (define (build-list cps k src vals)
  412. (match vals
  413. (()
  414. (with-cps cps
  415. (build-term ($continue k src ($const '())))))
  416. ((v . vals)
  417. (with-cps cps
  418. (letv tail)
  419. (letk ktail
  420. ($kargs ('tail) (tail)
  421. ($continue k src
  422. ($primcall 'cons #f (v tail)))))
  423. ($ (build-list ktail src vals))))))
  424. (cond
  425. ((and (not rest) (eqv? (length vals) nreq))
  426. (with-cps cps
  427. (build-term ($continue kargs src ($values vals)))))
  428. ((and rest (<= nreq (length vals)))
  429. (with-cps cps
  430. (letv rest)
  431. (letk krest ($kargs ('rest) (rest)
  432. ($continue kargs src
  433. ($values ,(append (list-head vals nreq)
  434. (list rest))))))
  435. ($ (build-list krest src (list-tail vals nreq)))))
  436. (else
  437. ;; Fallback case if values don't match.
  438. (with-cps cps
  439. (letv prim)
  440. (letk kprim ($kargs ('prim) (prim)
  441. ($continue k* src ($call prim vals))))
  442. (build-term ($continue kprim src ($prim 'values)))))))
  443. (define (continue cps k src exp)
  444. (define (lookup-return-cont k)
  445. (match (return-subst k)
  446. (#f k)
  447. (k (lookup-return-cont k))))
  448. (let ((k* (lookup-return-cont k)))
  449. (if (eq? k k*)
  450. (with-cps cps (build-term ($continue k src ,exp)))
  451. ;; We are contifying this return. It must be a call or a
  452. ;; $values expression. k* will be a $ktail or a $kreceive
  453. ;; continuation, or a $kargs continuation for a
  454. ;; known-number-of-values return.
  455. (match (intmap-ref conts k*)
  456. (($ $kreceive ($ $arity req () rest () #f) kargs)
  457. (match exp
  458. ((or ($ $call) ($ $callk) ($ $calli))
  459. (with-cps cps (build-term ($continue k* src ,exp))))
  460. ;; We need to punch through the $kreceive; otherwise we'd
  461. ;; have to rewrite as a call to the 'values primitive.
  462. (($ $values vals)
  463. (inline-return cps k* kargs src (length req) rest vals))))
  464. (($ $kargs)
  465. (match exp
  466. ((or ($ $callk) ($ $values))
  467. (with-cps cps (build-term ($continue k* src ,exp))))))
  468. (($ $ktail)
  469. (with-cps cps (build-term ($continue k* src ,exp))))))))
  470. (define (contify-unchecked-function cps kfun)
  471. ;; Precondition: kfun is "unchecked": the entry is a $kargs, and
  472. ;; thus all callers are $callk. If the front-end changes to produce
  473. ;; $callk to a $kfun with $kclause, this will have to change.
  474. (match (intmap-ref cps kfun)
  475. (($ $kfun src meta self tail entry)
  476. ;; This is the first caller to be visited; twiddle the kfun
  477. ;; to be a $kargs with an additional closure arg if needed.
  478. (match (intmap-ref cps entry)
  479. (($ $kargs names vars term)
  480. (let* ((vars' (map (lambda (_) (fresh-var)) vars))
  481. (names+ (if self (cons 'closure names) names))
  482. (vars+ (if self (cons self vars') vars')))
  483. (with-cps cps
  484. (setk kfun ($kargs names+ vars+
  485. ($continue entry src ($values vars')))))))))
  486. (($ $kargs names vars)
  487. ;; Callee $kfun already replaced with $kargs of the right
  488. ;; arity.
  489. cps)))
  490. (define (visit-exp cps k src exp)
  491. (match exp
  492. (($ $call proc args)
  493. ;; If proc is contifiable, replace call with jump.
  494. (match (call-subst proc)
  495. (#f (continue cps k src exp))
  496. (kfun
  497. (let ((body (find-body kfun (length args))))
  498. (with-cps cps
  499. (build-term ($continue body src ($values args))))))))
  500. (($ $callk kfun proc args)
  501. ;; If proc is contifiable, replace call with jump.
  502. (cond
  503. ((intset-ref contified kfun)
  504. (let ((args (if proc (cons proc args) args)))
  505. (with-cps (contify-unchecked-function cps kfun)
  506. (build-term ($continue kfun src ($values args))))))
  507. (else
  508. (continue cps k src exp))))
  509. (($ $fun kfun)
  510. ;; If the function's tail continuation has been
  511. ;; substituted, that means it has been contified.
  512. (if (return-subst (tail-label conts kfun))
  513. (continue cps k src (build-exp ($values ())))
  514. (continue cps k src exp)))
  515. (($ $rec names vars funs)
  516. (match (filter (match-lambda ((n v f) (not (call-subst v))))
  517. (map list names vars funs))
  518. (() (continue cps k src (build-exp ($values ()))))
  519. (((names vars funs) ...)
  520. (continue cps k src (build-exp ($rec names vars funs))))))
  521. (_ (continue cps k src exp))))
  522. (define (visit-term cps term)
  523. (match term
  524. (($ $continue k src exp)
  525. (visit-exp cps k src exp))
  526. ((or ($ $branch) ($ $switch) ($ $prompt) ($ $throw))
  527. (with-cps cps term))))
  528. ;; Renumbering is not strictly necessary but some passes may not be
  529. ;; equipped to deal with stale $kfun nodes whose bodies have been
  530. ;; wired into other functions.
  531. (renumber
  532. (with-fresh-name-state conts
  533. (intmap-fold
  534. (lambda (label cont out)
  535. (match cont
  536. (($ $kargs names vars term)
  537. ;; Remove bindings for functions that have been contified.
  538. (match (filter (match-lambda ((name var) (not (call-subst var))))
  539. (map list names vars))
  540. (((names vars) ...)
  541. (with-cps out
  542. (let$ term (visit-term term))
  543. (setk label ($kargs names vars ,term))))))
  544. (_ out)))
  545. conts
  546. conts))))
  547. (define (contify conts)
  548. ;; FIXME: Renumbering isn't really needed but dead continuations may
  549. ;; cause compute-singly-referenced-labels to spuriously mark some
  550. ;; conts as irreducible. For now we punt and renumber so that there
  551. ;; are only live conts.
  552. (let ((conts (renumber conts)))
  553. (call-with-values (lambda () (compute-contification conts))
  554. (lambda (contified call-substs return-substs)
  555. (apply-contification conts contified call-substs return-substs)))))