closure-conversion.scm 37 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899
  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. ;;; This pass converts a CPS term in such a way that no function has any
  19. ;;; free variables. Instead, closures are built explicitly as heap
  20. ;;; objects, and free variables are referenced through the closure.
  21. ;;;
  22. ;;; Closure conversion also removes any $rec expressions that
  23. ;;; contification did not handle. See (language cps) for a further
  24. ;;; discussion of $rec.
  25. ;;;
  26. ;;; Before closure conversion, function self variables are always bound.
  27. ;;; After closure conversion, well-known functions with no free
  28. ;;; variables may have no self reference.
  29. ;;;
  30. ;;; Code:
  31. (define-module (language cps closure-conversion)
  32. #:use-module (ice-9 match)
  33. #:use-module ((srfi srfi-1) #:select (fold filter-map))
  34. #:use-module (language cps)
  35. #:use-module (language cps utils)
  36. #:use-module (language cps with-cps)
  37. #:use-module (language cps intmap)
  38. #:use-module (language cps intset)
  39. #:export (convert-closures))
  40. (define (compute-program-body functions)
  41. (intmap-fold (lambda (label body out) (intset-union body out))
  42. functions
  43. empty-intset))
  44. (define (filter-reachable conts functions)
  45. (intmap-select conts (compute-program-body functions)))
  46. (define (compute-non-operator-uses conts)
  47. (persistent-intset
  48. (intmap-fold
  49. (lambda (label cont uses)
  50. (define (add-use var uses) (intset-add! uses var))
  51. (define (add-uses vars uses)
  52. (match vars
  53. (() uses)
  54. ((var . vars) (add-uses vars (add-use var uses)))))
  55. (match cont
  56. (($ $kargs _ _ ($ $continue _ _ exp))
  57. (match exp
  58. ((or ($ $const) ($ $prim) ($ $fun) ($ $rec)) uses)
  59. (($ $values args)
  60. (add-uses args uses))
  61. (($ $call proc args)
  62. (add-uses args uses))
  63. (($ $callk label proc args)
  64. (let ((uses (add-uses args uses)))
  65. (if proc
  66. (add-use proc uses)
  67. uses)))
  68. (($ $calli args callee)
  69. (add-uses args (add-use callee uses)))
  70. (($ $primcall name param args)
  71. (add-uses args uses))))
  72. (($ $kargs _ _ ($ $branch kf kt src op param args))
  73. (add-uses args uses))
  74. (($ $kargs _ _ ($ $switch kf kt* src arg))
  75. (add-use arg uses))
  76. (($ $kargs _ _ ($ $prompt k kh src escape? tag))
  77. (add-use tag uses))
  78. (($ $kargs _ _ ($ $throw src op param args))
  79. (add-uses args uses))
  80. (_ uses)))
  81. conts
  82. empty-intset)))
  83. (define (compute-function-names conts functions)
  84. "Compute a map of FUN-LABEL->BOUND-VAR... for each labelled function
  85. whose bound vars we know."
  86. (define (add-named-fun var kfun out)
  87. (let ((self (match (intmap-ref conts kfun)
  88. (($ $kfun src meta self) self))))
  89. (intmap-add out kfun (intset var self))))
  90. (intmap-fold
  91. (lambda (label body out)
  92. (let* ((conts (intmap-select conts body))
  93. (single (compute-singly-referenced-labels conts)))
  94. (intmap-fold
  95. (lambda (label cont out)
  96. (match cont
  97. (($ $kargs _ _ ($ $continue k _ ($ $fun kfun)))
  98. (if (intset-ref single k)
  99. (match (intmap-ref conts k)
  100. (($ $kargs (_) (var)) (add-named-fun var kfun out))
  101. (_ out))
  102. out))
  103. (($ $kargs _ _ ($ $continue k _ ($ $rec _ vars (($ $fun kfun) ...))))
  104. (unless (intset-ref single k)
  105. (error "$rec continuation has multiple predecessors??"))
  106. (fold add-named-fun out vars kfun))
  107. (_ out)))
  108. conts
  109. out)))
  110. functions
  111. empty-intmap))
  112. (define (compute-well-known-functions conts bound->label)
  113. "Compute a set of labels indicating the well-known functions in
  114. @var{conts}. A well-known function is a function whose bound names we
  115. know and which is never used in a non-operator position."
  116. (intset-subtract
  117. (persistent-intset
  118. (intmap-fold (lambda (bound label candidates)
  119. (intset-add! candidates label))
  120. bound->label
  121. empty-intset))
  122. (persistent-intset
  123. (intset-fold (lambda (var not-well-known)
  124. (match (intmap-ref bound->label var (lambda (_) #f))
  125. (#f not-well-known)
  126. (label (intset-add! not-well-known label))))
  127. (compute-non-operator-uses conts)
  128. empty-intset))))
  129. (define (intset-cons i set)
  130. (intset-add set i))
  131. (define (compute-shared-closures conts well-known)
  132. "Compute a map LABEL->VAR indicating the sets of functions that will
  133. share a closure. If a functions's label is in the map, it is shared.
  134. The entries indicate the var of the shared closure, which will be one of
  135. the bound vars of the closure."
  136. (intmap-fold
  137. (lambda (label cont out)
  138. (match cont
  139. (($ $kargs _ _
  140. ($ $continue _ _ ($ $rec names vars (($ $fun kfuns) ...))))
  141. ;; The split-rec pass should have ensured that this $rec forms a
  142. ;; strongly-connected component, so the free variables from all of
  143. ;; the functions will be alive as long as one of the closures is
  144. ;; alive. For that reason we can consider storing all free
  145. ;; variables in one closure and sharing it.
  146. (let* ((kfuns-set (fold intset-cons empty-intset kfuns))
  147. (unknown-kfuns (intset-subtract kfuns-set well-known)))
  148. (cond
  149. ((or (eq? empty-intset kfuns-set) (trivial-intset kfuns-set))
  150. ;; There is only zero or one function bound here. Trivially
  151. ;; shared already.
  152. out)
  153. ((eq? empty-intset unknown-kfuns)
  154. ;; All functions are well-known; we can share a closure. Use
  155. ;; the first bound variable.
  156. (let ((closure (car vars)))
  157. (intset-fold (lambda (kfun out)
  158. (intmap-add out kfun closure))
  159. kfuns-set out)))
  160. ((trivial-intset unknown-kfuns)
  161. => (lambda (unknown-kfun)
  162. ;; Only one function is not-well-known. Use that
  163. ;; function's closure as the shared closure.
  164. (let ((closure (assq-ref (map cons kfuns vars) unknown-kfun)))
  165. (intset-fold (lambda (kfun out)
  166. (intmap-add out kfun closure))
  167. kfuns-set out))))
  168. (else
  169. ;; More than one not-well-known function means we need more
  170. ;; than one proper closure, so we can't share.
  171. out))))
  172. (_ out)))
  173. conts
  174. empty-intmap))
  175. (define* (rewrite-shared-closure-calls cps functions label->bound shared kfun)
  176. "Rewrite CPS such that every call to a function with a shared closure
  177. instead is a $callk to that label, but passing the shared closure as the
  178. proc argument. For recursive calls, use the appropriate 'self'
  179. variable, if possible. Also rewrite uses of the non-well-known but
  180. shared closures to use the appropriate 'self' variable, if possible."
  181. ;; env := var -> (var . label)
  182. (define (visit-fun kfun cps env)
  183. (define (subst var)
  184. (match (intmap-ref env var (lambda (_) #f))
  185. (#f var)
  186. ((var . label) var)))
  187. (define (visit-exp exp)
  188. (rewrite-exp exp
  189. ((or ($ $const) ($ $prim)) ,exp)
  190. (($ $call proc args)
  191. ,(let ((args (map subst args)))
  192. (rewrite-exp (intmap-ref env proc (lambda (_) #f))
  193. (#f ($call proc ,args))
  194. ((closure . label) ($callk label closure ,args)))))
  195. (($ $callk label proc args)
  196. ($callk label (and proc (subst proc)) ,(map subst args)))
  197. (($ $calli args callee)
  198. ($calli ,(map subst args) (subst callee)))
  199. (($ $primcall name param args)
  200. ($primcall name param ,(map subst args)))
  201. (($ $values args)
  202. ($values ,(map subst args)))))
  203. (define (visit-term term)
  204. (rewrite-term term
  205. (($ $continue k src exp)
  206. ($continue k src ,(visit-exp exp)))
  207. (($ $branch kf kt src op param args)
  208. ($branch kf kt src op param ,(map subst args)))
  209. (($ $switch kf kt* src arg)
  210. ($switch kf kt* src (subst arg)))
  211. (($ $prompt k kh src escape? tag)
  212. ($prompt k kh src escape? (subst tag)))
  213. (($ $throw src op param args)
  214. ($throw src op param ,(map subst args)))))
  215. (define (visit-rec labels vars cps)
  216. (define (compute-env label bound self rec-bound rec-labels env)
  217. (define (add-bound-var bound label env)
  218. (intmap-add env bound (cons self label) (lambda (old new) new)))
  219. (if (intmap-ref shared label (lambda (_) #f))
  220. ;; Within a function with a shared closure, rewrite
  221. ;; references to bound vars to use the "self" var.
  222. (fold add-bound-var env rec-bound rec-labels)
  223. ;; Otherwise be sure to use "self" references in any
  224. ;; closure.
  225. (add-bound-var bound label env)))
  226. (fold (lambda (label var cps)
  227. (match (intmap-ref cps label)
  228. (($ $kfun src meta self)
  229. (visit-fun label cps
  230. (compute-env label var self vars labels env)))))
  231. cps labels vars))
  232. (define (visit-cont label cps)
  233. (match (intmap-ref cps label)
  234. (($ $kargs names vars
  235. ($ $continue k src ($ $fun label)))
  236. (visit-fun label cps env))
  237. (($ $kargs _ _
  238. ($ $continue k src ($ $rec names vars (($ $fun labels) ...))))
  239. (visit-rec labels vars cps))
  240. (($ $kargs names vars term)
  241. (with-cps cps
  242. (setk label ($kargs names vars ,(visit-term term)))))
  243. (_ cps)))
  244. (intset-fold visit-cont (intmap-ref functions kfun) cps))
  245. ;; Initial environment is bound-var -> (shared-var . label) map for
  246. ;; functions with shared closures.
  247. (let ((env (intmap-fold (lambda (label shared env)
  248. (intset-fold (lambda (bound env)
  249. (intmap-add env bound
  250. (cons shared label)))
  251. (intset-remove
  252. (intmap-ref label->bound label)
  253. (match (intmap-ref cps label)
  254. (($ $kfun src meta self) self)))
  255. env))
  256. shared
  257. empty-intmap)))
  258. (persistent-intmap (visit-fun kfun cps env))))
  259. (define (compute-free-vars conts kfun shared)
  260. "Compute a FUN-LABEL->FREE-VAR... map describing all free variable
  261. references."
  262. (define (add-def var defs) (intset-add! defs var))
  263. (define (add-defs vars defs)
  264. (match vars
  265. (() defs)
  266. ((var . vars) (add-defs vars (add-def var defs)))))
  267. (define (add-use var uses)
  268. (intset-add! uses var))
  269. (define (add-uses vars uses)
  270. (match vars
  271. (() uses)
  272. ((var . vars) (add-uses vars (add-use var uses)))))
  273. (define (visit-nested-funs body)
  274. (intset-fold
  275. (lambda (label out)
  276. (match (intmap-ref conts label)
  277. (($ $kargs _ _ ($ $continue _ _ ($ $fun kfun)))
  278. (intmap-union out (visit-fun kfun)))
  279. ;; Convention is that functions not bound by $fun / $rec and
  280. ;; thus reachable only via $callk and such have no free
  281. ;; variables.
  282. (($ $kargs _ _ ($ $continue _ _
  283. ($ $rec _ _ (($ $fun labels) ...))))
  284. (let* ((out (fold (lambda (kfun out)
  285. (intmap-union out (visit-fun kfun)))
  286. out labels))
  287. (free (fold (lambda (kfun free)
  288. (intset-union free (intmap-ref out kfun)))
  289. empty-intset labels)))
  290. (fold (lambda (kfun out)
  291. ;; For functions that share a closure, the free
  292. ;; variables for one will be the union of the free
  293. ;; variables for all.
  294. (if (intmap-ref shared kfun (lambda (_) #f))
  295. (intmap-replace out kfun free)
  296. out))
  297. out
  298. labels)))
  299. (_ out)))
  300. body
  301. empty-intmap))
  302. (define (visit-fun kfun)
  303. (let* ((body (compute-function-body conts kfun))
  304. (free (visit-nested-funs body)))
  305. (call-with-values
  306. (lambda ()
  307. (intset-fold
  308. (lambda (label defs uses)
  309. (match (intmap-ref conts label)
  310. (($ $kargs names vars term)
  311. (values
  312. (add-defs vars defs)
  313. (match term
  314. (($ $continue k src exp)
  315. (match exp
  316. ((or ($ $const) ($ $prim)) uses)
  317. (($ $fun kfun)
  318. (intset-union (persistent-intset uses)
  319. (intmap-ref free kfun)))
  320. (($ $rec names vars (($ $fun kfun) ...))
  321. (fold (lambda (kfun uses)
  322. (intset-union (persistent-intset uses)
  323. (intmap-ref free kfun)))
  324. uses kfun))
  325. (($ $values args)
  326. (add-uses args uses))
  327. (($ $call proc args)
  328. (add-use proc (add-uses args uses)))
  329. (($ $callk label proc args)
  330. (let ((uses (add-uses args uses)))
  331. (if proc
  332. (add-use proc uses)
  333. uses)))
  334. (($ $calli args callee)
  335. (add-uses args (add-use callee uses)))
  336. (($ $primcall name param args)
  337. (add-uses args uses))))
  338. (($ $branch kf kt src op param args)
  339. (add-uses args uses))
  340. (($ $switch kf kt* src arg)
  341. (add-use arg uses))
  342. (($ $prompt k kh src escape? tag)
  343. (add-use tag uses))
  344. (($ $throw src op param args)
  345. (add-uses args uses)))))
  346. (($ $kfun src meta self)
  347. (values (if self (add-def self defs) defs) uses))
  348. (_ (values defs uses))))
  349. body empty-intset empty-intset))
  350. (lambda (defs uses)
  351. (intmap-add free kfun (intset-subtract
  352. (persistent-intset uses)
  353. (persistent-intset defs)))))))
  354. ;; Ensure that functions only reachable by $callk are present in the
  355. ;; free-vars map, albeit with empty-intset. Note that if front-ends
  356. ;; start emitting $callk to targets with free variables, we will need
  357. ;; to do a better job here!
  358. (define (ensure-all-functions-have-free-vars free-vars)
  359. (intmap-fold
  360. (lambda (label cont out)
  361. (match cont
  362. (($ $kfun)
  363. (intmap-add out label empty-intset intset-union))
  364. (_ out)))
  365. conts
  366. free-vars))
  367. (ensure-all-functions-have-free-vars (visit-fun kfun)))
  368. (define (eliminate-closure? label free-vars)
  369. (eq? (intmap-ref free-vars label) empty-intset))
  370. (define (closure-label label shared bound->label)
  371. (cond
  372. ((intmap-ref shared label (lambda (_) #f))
  373. => (lambda (closure)
  374. (intmap-ref bound->label closure)))
  375. (else label)))
  376. (define (closure-alias label well-known free-vars)
  377. (and (intset-ref well-known label)
  378. (trivial-intset (intmap-ref free-vars label))))
  379. (define (prune-free-vars free-vars bound->label well-known shared)
  380. "Given the label->bound-var map @var{free-vars}, remove free variables
  381. that are known functions with zero free variables, and replace
  382. references to well-known functions with one free variable with that free
  383. variable, until we reach a fixed point on the free-vars map."
  384. (define (prune-free in-label free free-vars)
  385. (intset-fold (lambda (var free)
  386. (match (intmap-ref bound->label var (lambda (_) #f))
  387. (#f free)
  388. (label
  389. (cond
  390. ((eliminate-closure? label free-vars)
  391. (intset-remove free var))
  392. ((closure-alias (closure-label label shared bound->label)
  393. well-known free-vars)
  394. => (lambda (alias)
  395. ;; If VAR is free in LABEL, then ALIAS must
  396. ;; also be free because its definition must
  397. ;; precede VAR's definition.
  398. (intset-add (intset-remove free var) alias)))
  399. (else free)))))
  400. free free))
  401. (fixpoint (lambda (free-vars)
  402. (intmap-fold (lambda (label free free-vars)
  403. (intmap-replace free-vars label
  404. (prune-free label free free-vars)))
  405. free-vars
  406. free-vars))
  407. free-vars))
  408. (define (intset-find set i)
  409. (let lp ((idx 0) (start #f))
  410. (let ((start (intset-next set start)))
  411. (cond
  412. ((not start) (error "not found" set i))
  413. ((= start i) idx)
  414. (else (lp (1+ idx) (1+ start)))))))
  415. (define (intset-count set)
  416. (intset-fold (lambda (_ count) (1+ count)) set 0))
  417. (define (compute-elidable-closures cps well-known shared free-vars)
  418. "Compute the set of well-known callees with no free variables. Calls
  419. to these functions can avoid passing a closure parameter. Note however
  420. that we have to exclude well-known callees that are part of a shared
  421. closure that contains any not-well-known member."
  422. (define (intset-map f set)
  423. (persistent-intset
  424. (intset-fold (lambda (i out) (if (f i) (intset-add! out i) out))
  425. set
  426. empty-intset)))
  427. (let ((no-free-vars (persistent-intset
  428. (intmap-fold (lambda (label free out)
  429. (if (eq? empty-intset free)
  430. (intset-add! out label)
  431. out))
  432. free-vars empty-intset)))
  433. (shared
  434. (intmap-fold
  435. (lambda (label cont out)
  436. (match cont
  437. (($ $kargs _ _
  438. ($ $continue _ _ ($ $rec _ _ (($ $fun kfuns) ...))))
  439. ;; Either all of these functions share a closure, in
  440. ;; which all or all except one of them are well-known, or
  441. ;; none of the functions share a closure.
  442. (if (intmap-ref shared (car kfuns) (lambda (_) #f))
  443. (let* ((scc (fold intset-cons empty-intset kfuns)))
  444. (intset-fold (lambda (label out)
  445. (intmap-add out label scc))
  446. scc out))
  447. out))
  448. (_ out)))
  449. cps
  450. empty-intmap)))
  451. (intmap-fold (lambda (label labels elidable)
  452. (if (eq? labels (intset-intersect labels well-known))
  453. elidable
  454. (intset-subtract elidable labels)))
  455. shared
  456. (intset-intersect well-known no-free-vars))))
  457. (define (convert-one cps label body free-vars bound->label well-known shared
  458. elidable)
  459. (define (well-known? label)
  460. (intset-ref well-known label))
  461. (let* ((free (intmap-ref free-vars label))
  462. (nfree (intset-count free))
  463. (self-known? (well-known? (closure-label label shared bound->label)))
  464. (self (match (intmap-ref cps label) (($ $kfun _ _ self) self))))
  465. (define (convert-arg cps var k)
  466. "Convert one possibly free variable reference to a bound reference.
  467. If @var{var} is free, it is replaced by a closure reference via a
  468. @code{free-ref} primcall, and @var{k} is called with the new var.
  469. Otherwise @var{var} is bound, so @var{k} is called with @var{var}."
  470. ;; We know that var is not the name of a well-known function.
  471. (cond
  472. ((and=> (intmap-ref bound->label var (lambda (_) #f))
  473. (lambda (kfun)
  474. (and (eq? empty-intset (intmap-ref free-vars kfun))
  475. kfun)))
  476. ;; A not-well-known function with zero free vars. Copy as a
  477. ;; constant, relying on the linker to reify just one copy.
  478. => (lambda (kfun)
  479. ;; It may well be that "var" is the "self" of another
  480. ;; member of an SCC containing just one not-well-known
  481. ;; function. But here we're asking for the value of the
  482. ;; closure, which is the $const-fun of the non-well-known
  483. ;; member.
  484. (let ((kfun (closure-label kfun shared bound->label)))
  485. (with-cps cps
  486. (letv var*)
  487. (let$ body (k var*))
  488. (letk k* ($kargs (#f) (var*) ,body))
  489. (build-term ($continue k* #f ($const-fun kfun)))))))
  490. ((intset-ref free var)
  491. (if (and self-known? (eqv? 1 nfree))
  492. ;; A reference to the one free var of a well-known function.
  493. (with-cps cps
  494. ($ (k self)))
  495. (let* ((idx (intset-find free var))
  496. (ref (cond
  497. ((not self-known?)
  498. (build-exp
  499. ($primcall 'closure-ref `(,idx . ,nfree) (self))))
  500. ((= nfree 2)
  501. (build-exp
  502. ($primcall (match idx (0 'car) (1 'cdr)) #f
  503. (self))))
  504. (else
  505. (build-exp
  506. ($primcall 'vector-ref/immediate idx (self)))))))
  507. (with-cps cps
  508. (letv var*)
  509. (let$ body (k var*))
  510. (letk k* ($kargs (#f) (var*) ,body))
  511. (build-term ($continue k* #f ,ref))))))
  512. (else
  513. (with-cps cps
  514. ($ (k var))))))
  515. (define (convert-args cps vars k)
  516. "Convert a number of possibly free references to bound references.
  517. @var{k} is called with the bound references, and should return the
  518. term."
  519. (match vars
  520. (()
  521. (with-cps cps
  522. ($ (k '()))))
  523. ((var . vars)
  524. (convert-arg cps var
  525. (lambda (cps var)
  526. (convert-args cps vars
  527. (lambda (cps vars)
  528. (with-cps cps
  529. ($ (k (cons var vars)))))))))))
  530. (define (allocate-closure cps k src label known? nfree)
  531. "Allocate a new closure, and pass it to $var{k}."
  532. (match (vector known? nfree)
  533. (#(#f 0)
  534. ;; The call sites cannot be enumerated, but the closure has no
  535. ;; identity; statically allocate it.
  536. (with-cps cps
  537. (build-term ($continue k src ($const-fun label)))))
  538. (#(#f nfree)
  539. ;; The call sites cannot be enumerated; allocate a closure.
  540. (with-cps cps
  541. (letv code)
  542. (letk kalloc
  543. ($kargs ('code) (code)
  544. ($continue k src
  545. ($primcall 'make-closure nfree (code)))))
  546. (build-term
  547. ($continue kalloc src ($code label)))))
  548. (#(#t 0)
  549. (with-cps cps
  550. (build-term ($continue k src ($const #f)))))
  551. (#(#t 1)
  552. ;; A well-known closure of one free variable is replaced
  553. ;; at each use with the free variable itself, so we don't
  554. ;; need a binding at all; and yet, the continuation
  555. ;; expects one value, so give it something. DCE should
  556. ;; clean up later.
  557. (with-cps cps
  558. (build-term ($continue k src ($const #f)))))
  559. (#(#t 2)
  560. ;; Well-known closure with two free variables; the closure is a
  561. ;; pair.
  562. (with-cps cps
  563. (letv false)
  564. (letk kalloc
  565. ($kargs ('false) (false)
  566. ($continue k src ($primcall 'cons #f (false false)))))
  567. (build-term
  568. ($continue kalloc src ($const #f)))))
  569. ;; Well-known callee with more than two free variables; the closure
  570. ;; is a vector.
  571. (#(#t nfree)
  572. (unless (> nfree 2)
  573. (error "unexpected well-known nullary, unary, or binary closure"))
  574. (with-cps cps
  575. (build-term
  576. ($continue k src
  577. ($primcall 'allocate-vector/immediate nfree ())))))))
  578. (define (init-closure cps k src closure known? free)
  579. "Initialize the free variables @var{closure-free} in a closure
  580. bound to @var{closure}, and continue to @var{k}."
  581. (let ((count (intset-count free)))
  582. (cond
  583. ((and known? (<= count 1))
  584. ;; Well-known callee with zero or one free variables; no
  585. ;; initialization necessary.
  586. (with-cps cps
  587. (build-term ($continue k src ($values ())))))
  588. (else
  589. ;; Otherwise residualize initializations.
  590. (let ((make-init-exp
  591. ;; What are we initializing? A closure if the
  592. ;; procedure is not well-known; a pair if it has
  593. ;; only 2 free variables; otherwise, a vector.
  594. (cond
  595. ((not known?)
  596. (lambda (idx val)
  597. (build-exp
  598. ($primcall 'closure-set! `(,idx . ,count) (closure val)))))
  599. ((= count 2)
  600. (lambda (idx val)
  601. (match idx
  602. (0 (build-exp
  603. ($primcall 'set-car! #f (closure val))))
  604. (1 (build-exp
  605. ($primcall 'set-cdr! #f (closure val)))))))
  606. (else
  607. (lambda (idx val)
  608. (build-exp
  609. ($primcall 'vector-set!/immediate idx
  610. (closure val))))))))
  611. (let lp ((cps cps) (prev #f) (idx 0))
  612. (match (intset-next free prev)
  613. (#f (with-cps cps
  614. (build-term ($continue k src ($values ())))))
  615. (v (with-cps cps
  616. (let$ body (lp (1+ v) (1+ idx)))
  617. (letk k ($kargs () () ,body))
  618. ($ (convert-arg v
  619. (lambda (cps v)
  620. (with-cps cps
  621. (build-term
  622. ($continue k src
  623. ,(make-init-exp idx v))))))))))))))))
  624. (define (make-single-closure cps k src kfun)
  625. (let ((free (intmap-ref free-vars kfun)))
  626. (match (vector (well-known? kfun) (intset-count free))
  627. (#(#f 0)
  628. (with-cps cps
  629. (build-term ($continue k src ($const-fun kfun)))))
  630. (#(well-known? nfree)
  631. ;; A bit of a mess, but beta conversion should remove the
  632. ;; final $values if possible.
  633. (with-cps cps
  634. (letv closure)
  635. (letk k* ($kargs () () ($continue k src ($values (closure)))))
  636. (let$ init (init-closure k* src closure well-known? free))
  637. (letk knew ($kargs (#f) (closure) ,init))
  638. ($ (allocate-closure knew src kfun well-known? nfree)))))))
  639. ;; The callee is known, but not necessarily well-known.
  640. (define (convert-known-proc-call cps k src label closure args)
  641. (define (have-closure cps closure)
  642. (convert-args cps args
  643. (lambda (cps args)
  644. (with-cps cps
  645. (build-term
  646. ($continue k src ($callk label closure args)))))))
  647. (cond
  648. ((not closure)
  649. ;; No closure to begin with; done.
  650. (have-closure cps #f))
  651. ((eq? (intmap-ref free-vars label) empty-intset)
  652. ;; Known call, no free variables; no closure needed. If the
  653. ;; callee is well-known, elide the closure argument entirely.
  654. ;; Otherwise pass #f.
  655. (if (intset-ref elidable label)
  656. (have-closure cps #f)
  657. (with-cps cps
  658. ($ (with-cps-constants ((false #f))
  659. ($ (have-closure false)))))))
  660. ((and (well-known? (closure-label label shared bound->label))
  661. (trivial-intset (intmap-ref free-vars label)))
  662. ;; Well-known closures with one free variable are
  663. ;; replaced at their use sites by uses of the one free
  664. ;; variable.
  665. => (lambda (var)
  666. (convert-arg cps var have-closure)))
  667. (else
  668. ;; Otherwise just load the proc.
  669. (convert-arg cps closure have-closure))))
  670. (define (visit-term cps term)
  671. (match term
  672. (($ $continue k src (or ($ $const) ($ $prim)))
  673. (with-cps cps
  674. term))
  675. (($ $continue k src ($ $fun kfun))
  676. (with-cps cps
  677. ($ (make-single-closure k src kfun))))
  678. ;; Remove letrec.
  679. (($ $continue k src ($ $rec names vars (($ $fun kfuns) ...)))
  680. (match (vector names vars kfuns)
  681. (#(() () ())
  682. ;; Trivial empty case.
  683. (with-cps cps
  684. (build-term ($continue k src ($values ())))))
  685. (#((name) (var) (kfun))
  686. ;; Trivial single case. We have already proven that K has
  687. ;; only LABEL as its predecessor, so we have been able
  688. ;; already to rewrite free references to the bound name with
  689. ;; the self name.
  690. (with-cps cps
  691. ($ (make-single-closure k src kfun))))
  692. (#(_ _ (kfun0 . _))
  693. ;; A non-trivial strongly-connected component. Does it have
  694. ;; a shared closure?
  695. (match (intmap-ref shared kfun0 (lambda (_) #f))
  696. (#f
  697. ;; Nope. Allocate closures for each function.
  698. (let lp ((cps (match (intmap-ref cps k)
  699. ;; Steal declarations from the continuation.
  700. (($ $kargs names vals body)
  701. (intmap-replace cps k
  702. (build-cont
  703. ($kargs () () ,body))))))
  704. (in (map vector names vars kfuns))
  705. (init (lambda (cps)
  706. (with-cps cps
  707. (build-term
  708. ($continue k src ($values ())))))))
  709. (match in
  710. (() (init cps))
  711. ((#(name var kfun) . in)
  712. (let* ((known? (well-known? kfun))
  713. (free (intmap-ref free-vars kfun))
  714. (nfree (intset-count free)))
  715. (define (next-init cps)
  716. (with-cps cps
  717. (let$ body (init))
  718. (letk k ($kargs () () ,body))
  719. ($ (init-closure k src var known? free))))
  720. (with-cps cps
  721. (let$ body (lp in next-init))
  722. (letk k ($kargs (name) (var) ,body))
  723. ($ (allocate-closure k src kfun known? nfree))))))))
  724. (shared
  725. ;; If shared is in the bound->var map, that means one of
  726. ;; the functions is not well-known. Otherwise use kfun0
  727. ;; as the function label, but just so make-single-closure
  728. ;; can find the free vars, not for embedding in the
  729. ;; closure.
  730. (let* ((kfun (intmap-ref bound->label shared (lambda (_) kfun0)))
  731. (cps (match (intmap-ref cps k)
  732. ;; Make continuation declare only the shared
  733. ;; closure.
  734. (($ $kargs names vals body)
  735. (intmap-replace cps k
  736. (build-cont
  737. ($kargs (#f) (shared) ,body)))))))
  738. (with-cps cps
  739. ($ (make-single-closure k src kfun)))))))))
  740. (($ $continue k src ($ $call proc args))
  741. (match (intmap-ref bound->label proc (lambda (_) #f))
  742. (#f
  743. (convert-arg cps proc
  744. (lambda (cps proc)
  745. (convert-args cps args
  746. (lambda (cps args)
  747. (with-cps cps
  748. (build-term
  749. ($continue k src ($call proc args)))))))))
  750. (label
  751. (convert-known-proc-call cps k src label proc args))))
  752. (($ $continue k src ($ $callk label proc args))
  753. (convert-known-proc-call cps k src label proc args))
  754. (($ $continue k src ($ $calli args callee))
  755. (convert-args cps args
  756. (lambda (cps args)
  757. (convert-arg cps callee
  758. (lambda (cps callee)
  759. (with-cps cps
  760. (build-term
  761. ($continue k src ($calli args callee)))))))))
  762. (($ $continue k src ($ $primcall name param args))
  763. (convert-args cps args
  764. (lambda (cps args)
  765. (with-cps cps
  766. (build-term
  767. ($continue k src ($primcall name param args)))))))
  768. (($ $continue k src ($ $values args))
  769. (convert-args cps args
  770. (lambda (cps args)
  771. (with-cps cps
  772. (build-term
  773. ($continue k src ($values args)))))))
  774. (($ $branch kf kt src op param args)
  775. (convert-args cps args
  776. (lambda (cps args)
  777. (with-cps cps
  778. (build-term
  779. ($branch kf kt src op param args))))))
  780. (($ $switch kf kt* src arg)
  781. (convert-arg cps arg
  782. (lambda (cps arg)
  783. (with-cps cps
  784. (build-term
  785. ($switch kf kt* src arg))))))
  786. (($ $prompt k kh src escape? tag)
  787. (convert-arg cps tag
  788. (lambda (cps tag)
  789. (with-cps cps
  790. (build-term
  791. ($prompt k kh src escape? tag))))))
  792. (($ $throw src op param args)
  793. (convert-args cps args
  794. (lambda (cps args)
  795. (with-cps cps
  796. (build-term
  797. ($throw src op param args))))))))
  798. (intset-fold (lambda (label cps)
  799. (match (intmap-ref cps label (lambda (_) #f))
  800. (($ $kargs names vars term)
  801. (with-cps cps
  802. (let$ term (visit-term term))
  803. (setk label ($kargs names vars ,term))))
  804. (($ $kfun src meta self ktail kclause)
  805. (if (intset-ref elidable label)
  806. (with-cps cps
  807. (setk label ($kfun src meta #f ktail kclause)))
  808. cps))
  809. (_ cps)))
  810. body
  811. cps)))
  812. (define (convert-closures cps)
  813. "Convert free reference in @var{cps} to primcalls to @code{free-ref},
  814. and allocate and initialize flat closures."
  815. (let* ((kfun 0) ;; Ass-u-me.
  816. ;; label -> body-label...
  817. (functions (compute-reachable-functions cps kfun))
  818. (cps (filter-reachable cps functions))
  819. ;; label -> bound-var...
  820. (label->bound (compute-function-names cps functions))
  821. ;; bound-var -> label
  822. (bound->label (invert-partition label->bound))
  823. ;; label...
  824. (well-known (compute-well-known-functions cps bound->label))
  825. ;; label -> closure-var
  826. (shared (compute-shared-closures cps well-known))
  827. (cps (rewrite-shared-closure-calls cps functions label->bound shared
  828. kfun))
  829. ;; label -> free-var...
  830. (free-vars (compute-free-vars cps kfun shared))
  831. (free-vars (prune-free-vars free-vars bound->label well-known shared))
  832. ;; label...
  833. (elidable (compute-elidable-closures cps well-known shared free-vars)))
  834. (let ((free-in-program (intmap-ref free-vars kfun)))
  835. (unless (eq? empty-intset free-in-program)
  836. (error "Expected no free vars in program" free-in-program)))
  837. (with-fresh-name-state cps
  838. (persistent-intmap
  839. (intmap-fold
  840. (lambda (label body cps)
  841. (convert-one cps label body free-vars bound->label well-known shared
  842. elidable))
  843. functions
  844. cps)))))
  845. ;;; Local Variables:
  846. ;;; eval: (put 'convert-arg 'scheme-indent-function 2)
  847. ;;; eval: (put 'convert-args 'scheme-indent-function 2)
  848. ;;; End: