simplify.scm 11 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270
  1. ;;; Continuation-passing style (CPS) intermediate language (IL)
  2. ;; Copyright (C) 2013-2015, 2017-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. ;;; The fundamental lambda calculus reductions, like beta and eta
  19. ;;; reduction and so on. Pretty lame currently.
  20. ;;;
  21. ;;; Code:
  22. (define-module (language cps simplify)
  23. #:use-module (ice-9 match)
  24. #:use-module (srfi srfi-1)
  25. #:use-module (srfi srfi-11)
  26. #:use-module (srfi srfi-26)
  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 (simplify))
  32. (define (intset-maybe-add! set k add?)
  33. (if add? (intset-add! set k) set))
  34. (define (intset-add*! set k*)
  35. (fold1 (lambda (k set) (intset-add! set k)) k* set))
  36. (define (fold2* f l1 l2 seed)
  37. (let lp ((l1 l1) (l2 l2) (seed seed))
  38. (match (cons l1 l2)
  39. ((() . ()) seed)
  40. (((x1 . l1) . (x2 . l2)) (lp l1 l2 (f x1 x2 seed))))))
  41. (define (transform-conts f conts)
  42. (persistent-intmap
  43. (intmap-fold (lambda (k v out)
  44. (let ((v* (f k v)))
  45. (cond
  46. ((equal? v v*) out)
  47. (v* (intmap-replace! out k v*))
  48. (else (intmap-remove out k)))))
  49. conts
  50. conts)))
  51. (define (compute-singly-referenced-vars conts)
  52. (define (visit label cont single multiple)
  53. (define (add-ref var single multiple)
  54. (if (intset-ref single var)
  55. (values single (intset-add! multiple var))
  56. (values (intset-add! single var) multiple)))
  57. (define (ref var) (add-ref var single multiple))
  58. (define (ref* vars) (fold2 add-ref vars single multiple))
  59. (match cont
  60. (($ $kargs _ _ ($ $continue _ _ exp))
  61. (match exp
  62. ((or ($ $const) ($ $prim) ($ $fun) ($ $rec) ($ $const-fun) ($ $code))
  63. (values single multiple))
  64. (($ $call proc args)
  65. (ref* (cons proc args)))
  66. (($ $callk k proc args)
  67. (ref* (if proc (cons proc args) args)))
  68. (($ $calli args callee)
  69. (ref* (cons callee args)))
  70. (($ $primcall name param args)
  71. (ref* args))
  72. (($ $values args)
  73. (ref* args))))
  74. (($ $kargs _ _ ($ $branch kf kt src op param args))
  75. (ref* args))
  76. (($ $kargs _ _ ($ $switch kf kt* src arg))
  77. (ref arg))
  78. (($ $kargs _ _ ($ $prompt k kh src escape? tag))
  79. (ref tag))
  80. (($ $kargs _ _ ($ $throw src op param args))
  81. (ref* args))
  82. (_
  83. (values single multiple))))
  84. (let*-values (((single multiple) (values empty-intset empty-intset))
  85. ((single multiple) (intmap-fold visit conts single multiple)))
  86. (intset-subtract (persistent-intset single)
  87. (persistent-intset multiple))))
  88. ;;; Continuations whose values are simply forwarded to another and not
  89. ;;; used in any other way may be elided via eta reduction over labels.
  90. ;;;
  91. ;;; There is an exception however: we must exclude strongly-connected
  92. ;;; components (SCCs). The only kind of SCC we can build out of $values
  93. ;;; expressions are infinite loops.
  94. ;;;
  95. ;;; Condition A below excludes single-node SCCs. Single-node SCCs
  96. ;;; cannot be reduced.
  97. ;;;
  98. ;;; Condition B conservatively excludes edges to labels already marked
  99. ;;; as candidates. This prevents back-edges and so breaks SCCs, and is
  100. ;;; optimal if labels are sorted. If the labels aren't sorted it's
  101. ;;; suboptimal but cheap.
  102. (define (compute-eta-reductions conts kfun singly-used)
  103. (define (singly-used? vars)
  104. (match vars
  105. (() #t)
  106. ((var . vars)
  107. (and (intset-ref singly-used var) (singly-used? vars)))))
  108. (define (visit-fun kfun body eta)
  109. (define (visit-cont label eta)
  110. (match (intmap-ref conts label)
  111. (($ $kargs names vars ($ $continue k src ($ $values vars)))
  112. (intset-maybe-add! eta label
  113. (match (intmap-ref conts k)
  114. (($ $kargs)
  115. (and (not (eqv? label k)) ; A
  116. (not (intset-ref eta label)) ; B
  117. (singly-used? vars)))
  118. (_ #f))))
  119. (_
  120. eta)))
  121. (intset-fold visit-cont body eta))
  122. (persistent-intset
  123. (intmap-fold visit-fun
  124. (compute-reachable-functions conts kfun)
  125. empty-intset)))
  126. (define (eta-reduce conts kfun)
  127. (let* ((singly-used (compute-singly-referenced-vars conts))
  128. (label-set (compute-eta-reductions conts kfun singly-used)))
  129. ;; Replace any continuation to a label in LABEL-SET with the label's
  130. ;; continuation. The label will denote a $kargs continuation, so
  131. ;; only terms that can continue to $kargs need be taken into
  132. ;; account.
  133. (define (subst label)
  134. (if (intset-ref label-set label)
  135. (match (intmap-ref conts label)
  136. (($ $kargs _ _ ($ $continue k)) (subst k)))
  137. label))
  138. (transform-conts
  139. (lambda (label cont)
  140. (and (not (intset-ref label-set label))
  141. (rewrite-cont cont
  142. (($ $kargs names syms ($ $branch kf kt src op param args))
  143. ($kargs names syms
  144. ($branch (subst kf) (subst kt) src op param args)))
  145. (($ $kargs names syms ($ $switch kf kt* src arg))
  146. ($kargs names syms
  147. ($switch (subst kf) (map subst kt*) src arg)))
  148. (($ $kargs names syms ($ $prompt k kh src escape? tag))
  149. ($kargs names syms
  150. ($prompt (subst k) (subst kh) src escape? tag)))
  151. (($ $kargs names syms ($ $continue k src ($ $const val)))
  152. ,(match (intmap-ref conts k)
  153. (($ $kargs (_)
  154. ((? (lambda (var) (intset-ref singly-used var))
  155. var))
  156. ($ $branch kf kt _ 'false? #f (var)))
  157. (build-cont
  158. ($kargs names syms
  159. ($continue (subst (if val kf kt)) src ($values ())))))
  160. (_
  161. (build-cont
  162. ($kargs names syms
  163. ($continue (subst k) src ($const val)))))))
  164. (($ $kargs names syms ($ $continue k src exp))
  165. ($kargs names syms
  166. ($continue (subst k) src ,exp)))
  167. (($ $kreceive ($ $arity req () rest () #f) k)
  168. ($kreceive req rest (subst k)))
  169. (($ $kclause arity body alt)
  170. ($kclause ,arity (subst body) alt))
  171. (($ $kfun src meta self tail entry)
  172. ($kfun src meta self tail (and entry (subst entry))))
  173. (_ ,cont))))
  174. conts)))
  175. (define (compute-beta-reductions conts kfun)
  176. (define (visit-fun kfun body beta)
  177. (let* ((conts (intmap-select conts body))
  178. (single (compute-singly-referenced-labels conts)))
  179. (define (visit-cont label cont beta)
  180. (match cont
  181. ;; A continuation's body can be inlined in place of a $values
  182. ;; expression if the continuation is a $kargs. It should only
  183. ;; be inlined if it is used only once, and not recursively.
  184. (($ $kargs _ _ ($ $continue k src ($ $values)))
  185. (intset-maybe-add! beta label
  186. (and (intset-ref single k)
  187. (match (intmap-ref conts k)
  188. (($ $kargs) #t)
  189. (_ #f)))))
  190. (_
  191. beta)))
  192. (intmap-fold visit-cont conts beta)))
  193. (persistent-intset
  194. (intmap-fold visit-fun
  195. (compute-reachable-functions conts kfun)
  196. empty-intset)))
  197. (define (compute-beta-var-substitutions conts label-set)
  198. (define (add-var-substs label var-map)
  199. (match (intmap-ref conts label)
  200. (($ $kargs _ _ ($ $continue k _ ($ $values vals)))
  201. (match (intmap-ref conts k)
  202. (($ $kargs names vars)
  203. (fold2* (lambda (var val var-map)
  204. (intmap-add! var-map var val))
  205. vars vals var-map))))))
  206. (intset-fold add-var-substs label-set empty-intmap))
  207. (define (beta-reduce conts kfun)
  208. (let* ((label-set (compute-beta-reductions conts kfun))
  209. (var-map (compute-beta-var-substitutions conts label-set)))
  210. (define (subst var)
  211. (match (intmap-ref var-map var (lambda (_) #f))
  212. (#f var)
  213. (val (subst val))))
  214. (define (transform-term label term)
  215. (if (intset-ref label-set label)
  216. (match term
  217. (($ $continue k)
  218. (match (intmap-ref conts k)
  219. (($ $kargs _ _ term)
  220. (transform-term k term)))))
  221. (rewrite-term term
  222. (($ $continue k src exp)
  223. ($continue k src
  224. ,(rewrite-exp exp
  225. ((or ($ $const) ($ $prim) ($ $fun) ($ $rec) ($ $const-fun)
  226. ($ $code))
  227. ,exp)
  228. (($ $call proc args)
  229. ($call (subst proc) ,(map subst args)))
  230. (($ $callk k proc args)
  231. ($callk k (and proc (subst proc)) ,(map subst args)))
  232. (($ $calli args callee)
  233. ($calli ,(map subst args) (subst callee)))
  234. (($ $primcall name param args)
  235. ($primcall name param ,(map subst args)))
  236. (($ $values args)
  237. ($values ,(map subst args))))))
  238. (($ $branch kf kt src op param args)
  239. ($branch kf kt src op param ,(map subst args)))
  240. (($ $switch kf kt* src arg)
  241. ($switch kf kt* src (subst arg)))
  242. (($ $prompt k kh src escape? tag)
  243. ($prompt k kh src escape? (subst tag)))
  244. (($ $throw src op param args)
  245. ($throw src op param ,(map subst args))))))
  246. (transform-conts
  247. (lambda (label cont)
  248. (rewrite-cont cont
  249. (($ $kargs names syms term)
  250. ($kargs names syms ,(transform-term label term)))
  251. (_ ,cont)))
  252. conts)))
  253. (define (simplify conts)
  254. (eta-reduce (beta-reduce conts 0) 0))