renumber.scm 10 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238
  1. ;;; Continuation-passing style (CPS) intermediate language (IL)
  2. ;; Copyright (C) 2013-2021 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 renumber variables and continuation labels so that they
  19. ;;; are contiguous within each function and, in the case of labels,
  20. ;;; topologically sorted.
  21. ;;;
  22. ;;; Code:
  23. (define-module (language cps renumber)
  24. #:use-module (ice-9 match)
  25. #:use-module (srfi srfi-1)
  26. #:use-module (srfi srfi-11)
  27. #:use-module (language cps)
  28. #:use-module (language cps utils)
  29. #:use-module (language cps intset)
  30. #:use-module (language cps intmap)
  31. #:export (renumber))
  32. (define* (compute-tail-path-lengths conts kfun preds)
  33. (define (add-lengths labels lengths length)
  34. (intset-fold (lambda (label lengths)
  35. (intmap-add! lengths label length))
  36. labels
  37. lengths))
  38. (define (compute-next labels lengths)
  39. (intset-fold (lambda (label labels)
  40. (fold1 (lambda (pred labels)
  41. (if (intmap-ref lengths pred (lambda (_) #f))
  42. labels
  43. (intset-add! labels pred)))
  44. (intmap-ref preds label)
  45. labels))
  46. labels
  47. empty-intset))
  48. (define (visit labels lengths length)
  49. (let ((lengths (add-lengths labels lengths length)))
  50. (values (compute-next labels lengths) lengths (1+ length))))
  51. (match (intmap-ref conts kfun)
  52. (($ $kfun src meta self tail clause)
  53. (worklist-fold visit (intset-add empty-intset tail) empty-intmap 0))))
  54. ;; Topologically sort the continuation tree starting at k0, using
  55. ;; reverse post-order numbering.
  56. (define (sort-labels-locally conts k0 path-lengths)
  57. (define (visit-kf-first? kf kt)
  58. ;; Visit the successor of a branch with the shortest path length to
  59. ;; the tail first, so that if the branches are unsorted, the longer
  60. ;; path length will appear first. This will move a loop exit out of
  61. ;; a loop.
  62. (let ((kf-len (intmap-ref path-lengths kf (lambda (_) #f)))
  63. (kt-len (intmap-ref path-lengths kt (lambda (_) #f))))
  64. (if kt-len
  65. (or (not kf-len) (< kf-len kt-len)
  66. ;; If the path lengths are the same, preserve original
  67. ;; order to avoid squirreliness.
  68. (and (= kf-len kt-len) (< kt kf)))
  69. (if kf-len #f (< kt kf)))))
  70. (let ((order '())
  71. (visited empty-intset))
  72. (let visit ((k k0) (order '()) (visited empty-intset))
  73. (define (visit2 k0 k1 order visited)
  74. (let-values (((order visited) (visit k0 order visited)))
  75. (visit k1 order visited)))
  76. (if (intset-ref visited k)
  77. (values order (persistent-intset visited))
  78. (let ((visited (intset-add! visited k)))
  79. (call-with-values
  80. (lambda ()
  81. (match (intmap-ref conts k)
  82. (($ $kargs names syms term)
  83. (match term
  84. (($ $continue k)
  85. (visit k order visited))
  86. (($ $branch kf kt)
  87. (if (visit-kf-first? kf kt)
  88. (visit2 kf kt order visited)
  89. (visit2 kt kf order visited)))
  90. (($ $switch kf kt*)
  91. (fold2 visit
  92. (stable-sort (cons kf kt*) visit-kf-first?)
  93. order visited))
  94. (($ $prompt k kh)
  95. (visit2 k kh order visited))
  96. (($ $throw)
  97. (values order visited))))
  98. (($ $kreceive arity k) (visit k order visited))
  99. (($ $kclause arity kbody kalt)
  100. (if kalt
  101. (visit2 kalt kbody order visited)
  102. (visit kbody order visited)))
  103. (($ $kfun src meta self tail clause)
  104. (if clause
  105. (visit2 tail clause order visited)
  106. (visit tail order visited)))
  107. (($ $ktail) (values order visited))))
  108. (lambda (order visited)
  109. ;; Add k to the reverse post-order.
  110. (values (cons k order) (persistent-intset visited)))))))))
  111. (define (compute-renaming conts kfun)
  112. ;; labels := old -> new
  113. ;; vars := old -> new
  114. (define *next-label* -1)
  115. (define *next-var* -1)
  116. (define (rename-label label labels)
  117. (set! *next-label* (1+ *next-label*))
  118. (intmap-add! labels label *next-label*))
  119. (define (rename-var sym vars)
  120. (set! *next-var* (1+ *next-var*))
  121. (intmap-add! vars sym *next-var*))
  122. (define (rename label labels vars)
  123. (values (rename-label label labels)
  124. (match (intmap-ref conts label)
  125. (($ $kargs names syms exp)
  126. (fold1 rename-var syms vars))
  127. (($ $kfun src meta (and self (not #f)) tail clause)
  128. (rename-var self vars))
  129. (_ vars))))
  130. (define (maybe-visit-fun kfun labels vars)
  131. (if (intmap-ref labels kfun (lambda (_) #f))
  132. (values labels vars)
  133. (visit-fun kfun labels vars)))
  134. (define (visit-nested-funs k labels vars)
  135. (match (intmap-ref conts k)
  136. (($ $kargs names syms ($ $continue k src ($ $fun kfun)))
  137. (visit-fun kfun labels vars))
  138. (($ $kargs names syms ($ $continue k src ($ $rec names* syms*
  139. (($ $fun kfun) ...))))
  140. (fold2 visit-fun kfun labels vars))
  141. (($ $kargs names syms ($ $continue k src ($ $const-fun kfun)))
  142. ;; Closures with zero free vars get copy-propagated so it's
  143. ;; possible to already have visited them.
  144. (maybe-visit-fun kfun labels vars))
  145. (($ $kargs names syms ($ $continue k src ($ $code kfun)))
  146. (maybe-visit-fun kfun labels vars))
  147. (($ $kargs names syms ($ $continue k src ($ $callk kfun)))
  148. (maybe-visit-fun kfun labels vars))
  149. (_ (values labels vars))))
  150. (define (visit-fun kfun labels vars)
  151. (let* ((preds (compute-predecessors conts kfun))
  152. (path-lengths (compute-tail-path-lengths conts kfun preds))
  153. (order (sort-labels-locally conts kfun path-lengths)))
  154. ;; First rename locally, then recurse on nested functions.
  155. (let-values (((labels vars) (fold2 rename order labels vars)))
  156. (fold2 visit-nested-funs order labels vars))))
  157. (let-values (((labels vars) (visit-fun kfun empty-intmap empty-intmap)))
  158. (values (persistent-intmap labels) (persistent-intmap vars))))
  159. (define* (renumber conts #:optional (kfun 0))
  160. (let-values (((label-map var-map) (compute-renaming conts kfun)))
  161. (define (rename-label label) (intmap-ref label-map label))
  162. (define (rename-var var) (intmap-ref var-map var))
  163. (define (rename-exp exp)
  164. (rewrite-exp exp
  165. ((or ($ $const) ($ $prim)) ,exp)
  166. (($ $const-fun k)
  167. ($const-fun (rename-label k)))
  168. (($ $code k)
  169. ($code (rename-label k)))
  170. (($ $fun body)
  171. ($fun (rename-label body)))
  172. (($ $rec names vars funs)
  173. ($rec names (map rename-var vars) (map rename-exp funs)))
  174. (($ $values args)
  175. ($values ,(map rename-var args)))
  176. (($ $call proc args)
  177. ($call (rename-var proc) ,(map rename-var args)))
  178. (($ $callk k proc args)
  179. ($callk (rename-label k) (and proc (rename-var proc))
  180. ,(map rename-var args)))
  181. (($ $calli args callee)
  182. ($calli ,(map rename-var args) (rename-var callee)))
  183. (($ $primcall name param args)
  184. ($primcall name param ,(map rename-var args)))))
  185. (define (rename-arity arity)
  186. (match arity
  187. (($ $arity req opt rest () aok?)
  188. arity)
  189. (($ $arity req opt rest kw aok?)
  190. (match kw
  191. (() arity)
  192. (((kw kw-name kw-var) ...)
  193. (let ((kw (map list kw kw-name (map rename-var kw-var))))
  194. (make-$arity req opt rest kw aok?)))))))
  195. (persistent-intmap
  196. (intmap-fold
  197. (lambda (old-k new-k out)
  198. (intmap-add!
  199. out
  200. new-k
  201. (rewrite-cont (intmap-ref conts old-k)
  202. (($ $kargs names syms term)
  203. ($kargs names (map rename-var syms)
  204. ,(rewrite-term term
  205. (($ $continue k src exp)
  206. ($continue (rename-label k) src ,(rename-exp exp)))
  207. (($ $branch kf kt src op param args)
  208. ($branch (rename-label kf) (rename-label kt) src
  209. op param ,(map rename-var args)))
  210. (($ $switch kf kt* src arg)
  211. ($switch (rename-label kf) (map rename-label kt*) src
  212. (rename-var arg)))
  213. (($ $prompt k kh src escape? tag)
  214. ($prompt (rename-label k) (rename-label kh) src
  215. escape? (rename-var tag)))
  216. (($ $throw src op param args)
  217. ($throw src op param ,(map rename-var args))))))
  218. (($ $kreceive ($ $arity req () rest () #f) k)
  219. ($kreceive req rest (rename-label k)))
  220. (($ $ktail)
  221. ($ktail))
  222. (($ $kfun src meta self tail clause)
  223. ($kfun src meta (and self (rename-var self)) (rename-label tail)
  224. (and clause (rename-label clause))))
  225. (($ $kclause arity body alternate)
  226. ($kclause ,(rename-arity arity) (rename-label body)
  227. (and alternate (rename-label alternate)))))))
  228. label-map
  229. empty-intmap))))