effects-analysis.scm 32 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847
  1. ;;; Effects analysis on CPS
  2. ;; Copyright (C) 2011-2015,2017-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. ;;; A helper module to compute the set of effects caused by an
  19. ;;; expression. This information is useful when writing algorithms that
  20. ;;; move code around, while preserving the semantics of an input
  21. ;;; program.
  22. ;;;
  23. ;;; The effects set is represented as an integer with three parts. The
  24. ;;; low 4 bits indicate effects caused by an expression, as a bitfield.
  25. ;;; The next 4 bits indicate the kind of memory accessed by the
  26. ;;; expression, if it accesses mutable memory. Finally the rest of the
  27. ;;; bits indicate the field in the object being accessed, if known, or
  28. ;;; -1 for unknown.
  29. ;;;
  30. ;;; In this way we embed a coarse type-based alias analysis in the
  31. ;;; effects analysis. For example, a "car" call is modelled as causing
  32. ;;; a read to field 0 on a &pair, and causing a &type-check effect. If
  33. ;;; any intervening code sets the car of any pair, that will block
  34. ;;; motion of the "car" call, because any write to field 0 of a pair is
  35. ;;; seen by effects analysis as being a write to field 0 of all pairs.
  36. ;;;
  37. ;;; Code:
  38. (define-module (language cps effects-analysis)
  39. #:use-module (language cps)
  40. #:use-module (language cps utils)
  41. #:use-module (language cps intset)
  42. #:use-module (language cps intmap)
  43. #:use-module (ice-9 match)
  44. #:export (expression-effects
  45. compute-effects
  46. synthesize-definition-effects
  47. &allocation
  48. &type-check
  49. &read
  50. &write
  51. &fluid
  52. &prompt
  53. &vector
  54. &box
  55. &module
  56. &struct
  57. &string
  58. &thread
  59. &bytevector
  60. &closure
  61. &header
  62. &object
  63. &field
  64. &allocate
  65. &read-object
  66. &read-field
  67. &write-object
  68. &write-field
  69. &no-effects
  70. &all-effects
  71. causes-effect?
  72. causes-all-effects?
  73. effect-clobbers?
  74. compute-clobber-map))
  75. (define-syntax define-flags
  76. (lambda (x)
  77. (syntax-case x ()
  78. ((_ all shift name ...)
  79. (let ((count (length #'(name ...))))
  80. (with-syntax (((n ...) (iota count))
  81. (count count))
  82. #'(begin
  83. (define-syntax name (identifier-syntax (ash 1 n)))
  84. ...
  85. (define-syntax all (identifier-syntax (1- (ash 1 count))))
  86. (define-syntax shift (identifier-syntax count)))))))))
  87. (define-syntax define-enumeration
  88. (lambda (x)
  89. (define (count-bits n)
  90. (let lp ((out 1))
  91. (if (< n (ash 1 (1- out)))
  92. out
  93. (lp (1+ out)))))
  94. (syntax-case x ()
  95. ((_ mask shift name ...)
  96. (let* ((len (length #'(name ...)))
  97. (bits (count-bits len)))
  98. (with-syntax (((n ...) (iota len))
  99. (bits bits))
  100. #'(begin
  101. (define-syntax name (identifier-syntax n))
  102. ...
  103. (define-syntax mask (identifier-syntax (1- (ash 1 bits))))
  104. (define-syntax shift (identifier-syntax bits)))))))))
  105. (define-flags &all-effect-kinds &effect-kind-bits
  106. ;; Indicates that an expression may cause a type check. A type check,
  107. ;; for the purposes of this analysis, is the possibility of throwing
  108. ;; an exception the first time an expression is evaluated. If the
  109. ;; expression did not cause an exception to be thrown, users can
  110. ;; assume that evaluating the expression again will not cause an
  111. ;; exception to be thrown.
  112. ;;
  113. ;; For example, (+ x y) might throw if X or Y are not numbers. But if
  114. ;; it doesn't throw, it should be safe to elide a dominated, common
  115. ;; subexpression (+ x y).
  116. &type-check
  117. ;; Indicates that an expression may return a fresh object. The kind
  118. ;; of object is indicated in the object kind field.
  119. &allocation
  120. ;; Indicates that an expression may cause a read from memory. The
  121. ;; kind of memory is given in the object kind field. Some object
  122. ;; kinds have finer-grained fields; those are expressed in the "field"
  123. ;; part of the effects value. -1 indicates "the whole object".
  124. &read
  125. ;; Indicates that an expression may cause a write to memory.
  126. &write)
  127. (define-enumeration &memory-kind-mask &memory-kind-bits
  128. ;; Indicates than an expression may access unknown kinds of memory.
  129. &unknown-memory-kinds
  130. ;; Indicates that an expression depends on the value of a fluid
  131. ;; variable, or on the current fluid environment.
  132. &fluid
  133. ;; Indicates that an expression depends on the current prompt
  134. ;; stack.
  135. &prompt
  136. ;; Indicates that an expression depends on the value of the car or cdr
  137. ;; of a pair.
  138. &pair
  139. ;; Indicates that an expression depends on the value of a vector
  140. ;; field. The effect field indicates the specific field, or zero for
  141. ;; an unknown field.
  142. &vector
  143. ;; Indicates that an expression depends on the value of a variable
  144. ;; cell.
  145. &box
  146. ;; Indicates that an expression depends on the current module.
  147. &module
  148. ;; Indicates that an expression depends on the current thread.
  149. &thread
  150. ;; Indicates that an expression depends on the value of a struct
  151. ;; field. The effect field indicates the specific field, or zero for
  152. ;; an unknown field.
  153. &struct
  154. ;; Indicates that an expression depends on the contents of a string.
  155. &string
  156. ;; Indicates that an expression depends on the contents of a
  157. ;; bytevector. We cannot be more precise, as bytevectors may alias
  158. ;; other bytevectors.
  159. &bytevector
  160. ;; Indicates a dependency on a free variable of a closure.
  161. &closure
  162. ;; Indicates a dependency on a raw bitmask, measured in 32-bit units.
  163. &bitmask
  164. ;; Indicates a dependency on the value of a cache cell.
  165. &cache
  166. ;; Indicates that an expression depends on a value extracted from the
  167. ;; fixed, unchanging part of an object -- for example the length of a
  168. ;; vector or the vtable of a struct.
  169. &header)
  170. (define-inlinable (&field kind field)
  171. (ash (logior (ash field &memory-kind-bits) kind) &effect-kind-bits))
  172. (define-inlinable (&object kind)
  173. (&field kind -1))
  174. (define-inlinable (&allocate kind)
  175. (logior &allocation (&object kind)))
  176. (define-inlinable (&read-field kind field)
  177. (logior &read (&field kind field)))
  178. (define-inlinable (&read-object kind)
  179. (logior &read (&object kind)))
  180. (define-inlinable (&write-field kind field)
  181. (logior &write (&field kind field)))
  182. (define-inlinable (&write-object kind)
  183. (logior &write (&object kind)))
  184. (define-syntax &no-effects (identifier-syntax 0))
  185. (define-syntax &all-effects
  186. (identifier-syntax
  187. (logior &all-effect-kinds (&object &unknown-memory-kinds))))
  188. (define-inlinable (causes-effect? x effects)
  189. (logtest x effects))
  190. (define-inlinable (causes-all-effects? x)
  191. (eqv? x &all-effects))
  192. (define (effect-clobbers? a b)
  193. "Return true if A clobbers B. This is the case if A is a write, and B
  194. is or might be a read or a write to the same location as A."
  195. (define (locations-same?)
  196. (let ((a (ash a (- &effect-kind-bits)))
  197. (b (ash b (- &effect-kind-bits))))
  198. (or (eqv? &unknown-memory-kinds (logand a &memory-kind-mask))
  199. (eqv? &unknown-memory-kinds (logand b &memory-kind-mask))
  200. (and (eqv? (logand a &memory-kind-mask) (logand b &memory-kind-mask))
  201. ;; A negative field indicates "the whole object".
  202. ;; Non-negative fields indicate only part of the object.
  203. (or (< a 0) (< b 0) (= a b))))))
  204. (and (logtest a &write)
  205. (logtest b (logior &read &write))
  206. (locations-same?)))
  207. (define (compute-known-allocations conts effects)
  208. "Return a map of ACCESS-LABEL to ALLOC-LABEL, indicating stores to and
  209. loads from objects created at known allocation sites."
  210. ;; VAR -> ALLOC map of defining allocations, where ALLOC is a label or
  211. ;; #f. Possibly sparse.
  212. (define allocations
  213. (intmap-fold
  214. (lambda (label fx out)
  215. (match (intmap-ref conts label)
  216. (($ $kargs _ _ ($ $continue k))
  217. (match (intmap-ref conts k)
  218. (($ $kargs (_) (var))
  219. (intmap-add out var
  220. (and (not (causes-all-effects? fx))
  221. (logtest fx &allocation)
  222. label)
  223. (lambda (old new) #f)))
  224. (_ out)))
  225. (_ out)))
  226. effects empty-intmap))
  227. (persistent-intmap
  228. (intmap-fold
  229. (lambda (label fx out)
  230. (cond
  231. ((causes-all-effects? fx) out)
  232. ((logtest fx &allocation) out)
  233. ((logtest fx (logior &read &write))
  234. (match (intmap-ref conts label)
  235. ;; Assume that instructions which cause a known set of effects
  236. ;; and which
  237. (($ $kargs names vars
  238. ($ $continue k src
  239. ($ $primcall name param (obj . args))))
  240. (match (intmap-ref allocations obj (lambda (_) #f))
  241. (#f out)
  242. (allocation-label
  243. (intmap-add! out label allocation-label))))
  244. (_ out)))
  245. (else out)))
  246. effects empty-intmap)))
  247. (define (compute-clobber-map conts effects)
  248. "For the map LABEL->EFFECTS, compute a map LABEL->LABELS indicating
  249. the LABELS that are clobbered by the effects of LABEL."
  250. (define known-allocations (compute-known-allocations conts effects))
  251. (define (filter-may-alias write-label clobbered-labels)
  252. ;; We may be able to remove some entries from CLOBBERED-LABELS, if
  253. ;; we can prove they are not aliased by WRITE-LABEL.
  254. (match (intmap-ref known-allocations write-label (lambda (_) #f))
  255. (#f
  256. ;; We don't know what object WRITE-LABEL refers to; can't refine.
  257. clobbered-labels)
  258. (clobber-alloc
  259. (intset-fold
  260. (lambda (clobbered-label clobbered-labels)
  261. (match (intmap-ref known-allocations clobbered-label (lambda (_) #f))
  262. (#f
  263. ;; We don't know what object CLOBBERED-LABEL refers to;
  264. ;; can't refine.
  265. clobbered-labels)
  266. (clobbered-alloc
  267. ;; We know that WRITE-LABEL and CLOBBERED-LABEL refer to
  268. ;; known allocations. The write will only clobber the read
  269. ;; if the two allocations are the same.
  270. (if (eqv? clobber-alloc clobbered-alloc)
  271. clobbered-labels
  272. (intset-remove clobbered-labels clobbered-label)))))
  273. clobbered-labels clobbered-labels))))
  274. (define (make-clobber-vector) (make-vector &memory-kind-mask empty-intset))
  275. (define clobbered-by-write-to-unknown empty-intset)
  276. (define clobbered-by-write-to-any-field (make-clobber-vector))
  277. (define clobbered-by-write-to-all-fields (make-clobber-vector))
  278. (define clobbered-by-write-to-specific-field (make-hash-table))
  279. (define (adjoin-to-clobber-vector! v k id)
  280. (vector-set! v k (intset-union (vector-ref v k) (intset id))))
  281. (define (add-clobbered-by-write-to-any-field! kind label)
  282. (adjoin-to-clobber-vector! clobbered-by-write-to-any-field kind label))
  283. (define (add-clobbered-by-write-to-all-fields! kind label)
  284. (adjoin-to-clobber-vector! clobbered-by-write-to-all-fields kind label))
  285. (define (adjoin-to-clobber-hash! h k id)
  286. (hashv-set! h k (intset-union (hashv-ref h k empty-intset) (intset id))))
  287. (define (add-clobbered-by-write-to-specific-field! kind+field label)
  288. (adjoin-to-clobber-hash! clobbered-by-write-to-specific-field
  289. kind+field label))
  290. (intmap-fold
  291. (lambda (label fx)
  292. ;; Unless an expression causes a read, it isn't clobbered by
  293. ;; anything.
  294. (when (causes-effect? fx &read)
  295. (define kind+field (ash fx (- &effect-kind-bits)))
  296. (define kind (logand &memory-kind-mask kind+field))
  297. (define field (ash kind+field (- &memory-kind-bits)))
  298. (cond
  299. ((eqv? field -1)
  300. ;; A read of the whole object is clobbered by a write to any
  301. ;; field.
  302. (add-clobbered-by-write-to-all-fields! kind label)
  303. (add-clobbered-by-write-to-any-field! kind label))
  304. ((negative? field) (error "unexpected field"))
  305. (else
  306. ;; A read of a specific field is clobbered by a write to that
  307. ;; specific field, or a write to all fields.
  308. (add-clobbered-by-write-to-all-fields! kind label)
  309. (add-clobbered-by-write-to-specific-field! kind+field label)))
  310. ;; Also clobbered by write to any field of unknown memory kinds.
  311. (add-clobbered-by-write-to-any-field! &unknown-memory-kinds label))
  312. (values))
  313. effects)
  314. (define (lookup-clobbers fx)
  315. (define kind+field (ash fx (- &effect-kind-bits)))
  316. (define kind (logand &memory-kind-mask kind+field))
  317. (define field (ash kind+field (- &memory-kind-bits)))
  318. (cond
  319. ((eqv? field -1)
  320. ;; A write to the whole object.
  321. (intset-union
  322. (vector-ref clobbered-by-write-to-any-field kind)
  323. (vector-ref clobbered-by-write-to-all-fields kind)))
  324. ((negative? field) (error "unexpected field"))
  325. (else
  326. ;; A write to a specific field. In addition to clobbering reads
  327. ;; of this specific field, we clobber reads of the whole object,
  328. ;; for example the ones that correspond to the synthesized "car"
  329. ;; and "cdr" definitions that are associated with a "cons" expr.
  330. (intset-union
  331. (vector-ref clobbered-by-write-to-any-field kind)
  332. (hashv-ref clobbered-by-write-to-specific-field kind+field)))))
  333. (intmap-map (lambda (label fx)
  334. (if (causes-effect? fx &write)
  335. (filter-may-alias label (lookup-clobbers fx))
  336. empty-intset))
  337. effects))
  338. (define *primitive-effects* (make-hash-table))
  339. (define-syntax-rule (define-primitive-effects* param
  340. ((name . args) effects ...)
  341. ...)
  342. (begin
  343. (hashq-set! *primitive-effects* 'name
  344. (case-lambda*
  345. ((param . args) (logior effects ...))
  346. (_ &all-effects)))
  347. ...))
  348. (define-syntax-rule (define-primitive-effects ((name . args) effects ...) ...)
  349. (define-primitive-effects* param ((name . args) effects ...) ...))
  350. ;; Miscellaneous.
  351. (define-primitive-effects
  352. ((load-const/unlikely))
  353. ((values . _)))
  354. ;; Generic effect-free predicates.
  355. (define-primitive-effects
  356. ((eq? x y))
  357. ((equal? x y))
  358. ((bignum? arg))
  359. ((bitvector? arg))
  360. ((bytevector? arg))
  361. ((char? arg))
  362. ((compnum? arg))
  363. ((eq-constant? arg))
  364. ((false? arg))
  365. ((fixnum? arg))
  366. ((flonum? arg))
  367. ((fluid? arg))
  368. ((fracnum? arg))
  369. ((heap-number? arg))
  370. ((heap-object? arg))
  371. ((immutable-vector? arg))
  372. ((keyword? arg))
  373. ((nil? arg))
  374. ((null? arg))
  375. ((mutable-vector? arg))
  376. ((pair? arg))
  377. ((pointer? arg))
  378. ((procedure? arg))
  379. ((program? arg))
  380. ((string? arg))
  381. ((struct? arg))
  382. ((symbol? arg))
  383. ((syntax? arg))
  384. ((thunk? arg))
  385. ((undefined? arg))
  386. ((variable? arg))
  387. ((vector? arg)))
  388. ;; Fluids.
  389. (define-primitive-effects
  390. ((fluid-ref f) (&read-object &fluid) &type-check)
  391. ((fluid-set! f v) (&write-object &fluid) &type-check)
  392. ((push-fluid f v) (&write-object &fluid) &type-check)
  393. ((pop-fluid) (&write-object &fluid))
  394. ((push-dynamic-state state) (&write-object &fluid) &type-check)
  395. ((pop-dynamic-state) (&write-object &fluid)))
  396. (define-primitive-effects
  397. ((symbol->string x)) ;; CPS lowering includes symbol? type check.
  398. ((symbol->keyword)) ;; Same.
  399. ((keyword->symbol)) ;; Same, for keyword?.
  400. ((string->symbol) (&read-object &string) &type-check)
  401. ((string->utf8) (&read-object &string))
  402. ((utf8->string) (&read-object &bytevector) &type-check)
  403. ((string-utf8-length) (&read-object &string)))
  404. ;; Threads. Calls cause &all-effects, which reflects the fact that any
  405. ;; call can capture a partial continuation and reinstate it on another
  406. ;; thread.
  407. (define-primitive-effects
  408. ((current-thread) (&read-object &thread)))
  409. ;; Prompts.
  410. (define-primitive-effects
  411. ((make-prompt-tag #:optional arg) (&allocate &unknown-memory-kinds)))
  412. ;; Generic objects.
  413. (define (annotation->memory-kind* annotation idx)
  414. ;; Lowering from Tree-IL to CPS reifies type-specific constructors and
  415. ;; accessors. For these we can treat e.g. vector-length as completely
  416. ;; constant as it can commute with any other instruction: the header
  417. ;; initialization write of a vector is not visible.
  418. ;;
  419. ;; However when these instructions are later lowered to allocate-words
  420. ;; with explicit initializers, we need to model the header reads and
  421. ;; writes as non-commutative.
  422. (match (cons annotation idx)
  423. (('vector . 0) &header)
  424. (('string . (or 0 1 2 3)) &header)
  425. (('stringbuf . (or 0 1)) &header)
  426. (('bytevector . (or 0 1 2 3)) &header)
  427. (('symbol . (or 0 1 2)) &header)
  428. (('box . 0) &header)
  429. (('closure . (or 0 1)) &header)
  430. (('struct . 0) &header)
  431. (('atomic-box . 0) &header)
  432. (_ (annotation->memory-kind annotation))))
  433. (define (annotation->memory-kind annotation)
  434. (match annotation
  435. ('pair &pair)
  436. ('vector &vector)
  437. ('string &string)
  438. ('stringbuf &string)
  439. ('symbol &unknown-memory-kinds)
  440. ('bytevector &bytevector)
  441. ('bitmask &bitmask)
  442. ('box &box)
  443. ('closure &closure)
  444. ('struct &struct)
  445. ('atomic-box &unknown-memory-kinds)
  446. ('keyword &unknown-memory-kinds)))
  447. (define-primitive-effects* param
  448. ((allocate-vector size) (&allocate &vector))
  449. ((allocate-vector/immediate) (&allocate &vector))
  450. ((vector-length v))
  451. ((vector-ref/immediate v) (&read-field &vector param))
  452. ((vector-ref v idx) (&read-object &vector))
  453. ((vector-set!/immediate v val) (&write-field &vector param))
  454. ((vector-set! v idx val) (&write-object &vector))
  455. ((cons x y) (&allocate &pair))
  456. ((car pair) (&read-field &pair 0))
  457. ((cdr pair) (&read-field &pair 1))
  458. ((set-car! pair val) (&write-field &pair 0))
  459. ((set-cdr! pair val) (&write-field &pair 1))
  460. ((box val) (&allocate &box))
  461. ((box-ref b) (&read-object &box))
  462. ((box-set! b val) (&write-object &box))
  463. ((allocate-struct vtable) (&allocate &struct))
  464. ((vtable-size x))
  465. ((vtable-has-unboxed-fields? x))
  466. ((vtable-field-boxed? x))
  467. ((struct-vtable x))
  468. ((struct-ref x) (&read-field &struct param))
  469. ((struct-set! x y) (&write-field &struct param))
  470. ((bv-contents bv))
  471. ((bv-length bv))
  472. ((string-length str))
  473. ((string-ref str idx) (&read-object &string))
  474. ((string-set! str idx cp) (&write-object &string))
  475. ((symbol-hash))
  476. ((make-closure code) (&allocate &closure))
  477. ((closure-ref code) (match param
  478. ((idx . nfree)
  479. (&read-field &closure idx))))
  480. ((closure-set! code) (match param
  481. ((idx . nfree)
  482. (&write-field &closure idx)))))
  483. (define-primitive-effects* param
  484. ((allocate-words size) (&allocate (annotation->memory-kind param)))
  485. ((allocate-words/immediate) (match param
  486. ((ann . size)
  487. (&allocate
  488. (annotation->memory-kind ann)))))
  489. ((allocate-pointerless-words size)
  490. (&allocate (annotation->memory-kind param)))
  491. ((allocate-pointerless-words/immediate)
  492. (match param
  493. ((ann . size)
  494. (&allocate
  495. (annotation->memory-kind ann)))))
  496. ((scm-ref obj idx) (&read-object
  497. (annotation->memory-kind param)))
  498. ((scm-ref/tag obj) (&read-field
  499. (annotation->memory-kind* param 0) 0))
  500. ((scm-ref/immediate obj) (match param
  501. ((ann . idx)
  502. (&read-field
  503. (annotation->memory-kind* ann idx) idx))))
  504. ((scm-set! obj idx val) (&write-object
  505. (annotation->memory-kind param)))
  506. ((scm-set/tag! obj val) (&write-field
  507. (annotation->memory-kind* param 0) 0))
  508. ((scm-set!/immediate obj val) (match param
  509. ((ann . idx)
  510. (&write-field
  511. (annotation->memory-kind* ann idx) idx))))
  512. ((word-ref obj idx) (&read-object
  513. (annotation->memory-kind param)))
  514. ((word-ref/immediate obj) (match param
  515. ((ann . idx)
  516. (&read-field
  517. (annotation->memory-kind* ann idx) idx))))
  518. ((word-set! obj idx val) (&read-object
  519. (annotation->memory-kind param)))
  520. ((word-set!/immediate obj val) (match param
  521. ((ann . idx)
  522. (&write-field
  523. (annotation->memory-kind* ann idx) idx))))
  524. ((pointer-ref/immediate obj) (match param
  525. ((ann . idx)
  526. (&read-field
  527. (annotation->memory-kind* ann idx) idx))))
  528. ((pointer-set!/immediate obj val)
  529. (match param
  530. ((ann . idx)
  531. (&write-field
  532. (annotation->memory-kind* ann idx) idx))))
  533. ((tail-pointer-ref/immediate obj)))
  534. ;; Strings.
  535. (define-primitive-effects
  536. ((string-set! s n c) (&write-object &string) &type-check)
  537. ((number->string _) (&allocate &string) &type-check)
  538. ((string->number _) (&read-object &string) &type-check))
  539. ;; Unboxed floats and integers.
  540. (define-primitive-effects
  541. ((scm->f64 _) &type-check)
  542. ((load-f64))
  543. ((f64->scm _))
  544. ((scm->u64 _) &type-check)
  545. ((scm->u64/truncate _) &type-check)
  546. ((load-u64))
  547. ((u64->scm _))
  548. ((u64->scm/unlikely _))
  549. ((scm->s64 _) &type-check)
  550. ((load-s64))
  551. ((s64->scm _))
  552. ((s64->scm/unlikely _))
  553. ((u64->s64 _))
  554. ((s64->u64 _))
  555. ((assume-u64 _))
  556. ((assume-s64 _))
  557. ((untag-fixnum _))
  558. ((tag-fixnum _))
  559. ((tag-fixnum/unlikely _)))
  560. ;; Pointers.
  561. (define-primitive-effects* param
  562. ((u8-ref obj bv n) (&read-object (annotation->memory-kind param)))
  563. ((s8-ref obj bv n) (&read-object (annotation->memory-kind param)))
  564. ((u16-ref obj bv n) (&read-object (annotation->memory-kind param)))
  565. ((s16-ref obj bv n) (&read-object (annotation->memory-kind param)))
  566. ((u32-ref obj bv n) (&read-object (annotation->memory-kind param)))
  567. ((s32-ref obj bv n) (&read-object (annotation->memory-kind param)))
  568. ((u64-ref obj bv n) (&read-object (annotation->memory-kind param)))
  569. ((s64-ref obj bv n) (&read-object (annotation->memory-kind param)))
  570. ((f32-ref obj bv n) (&read-object (annotation->memory-kind param)))
  571. ((f64-ref obj bv n) (&read-object (annotation->memory-kind param)))
  572. ((u8-set! obj bv n x) (&write-object (annotation->memory-kind param)))
  573. ((s8-set! obj bv n x) (&write-object (annotation->memory-kind param)))
  574. ((u16-set! obj bv n x) (&write-object (annotation->memory-kind param)))
  575. ((s16-set! obj bv n x) (&write-object (annotation->memory-kind param)))
  576. ((u32-set! obj bv n x) (&write-object (annotation->memory-kind param)))
  577. ((s32-set! obj bv n x) (&write-object (annotation->memory-kind param)))
  578. ((u64-set! obj bv n x) (&write-object (annotation->memory-kind param)))
  579. ((s64-set! obj bv n x) (&write-object (annotation->memory-kind param)))
  580. ((f32-set! obj bv n x) (&write-object (annotation->memory-kind param)))
  581. ((f64-set! obj bv n x) (&write-object (annotation->memory-kind param))))
  582. ;; Modules.
  583. (define-primitive-effects
  584. ((current-module) (&read-object &module))
  585. ((cache-current-module! m) (&write-object &cache))
  586. ((resolve name) (&read-object &module) &type-check)
  587. ((resolve-module mod) (&read-object &module) &type-check)
  588. ((module-variable mod name) (&read-object &module) &type-check)
  589. ((lookup mod name) (&read-object &module) &type-check)
  590. ((lookup-bound mod name) (&read-object &module) &type-check)
  591. ((lookup-bound-public) &type-check)
  592. ((lookup-bound-private) &type-check)
  593. ((cached-toplevel-box) &type-check)
  594. ((cached-module-box) &type-check)
  595. ((define! mod name) (&read-object &module)))
  596. ;; Cache cells.
  597. (define-primitive-effects
  598. ((cache-ref) (&read-object &cache))
  599. ((cache-set! x) (&write-object &cache)))
  600. ;; Numbers.
  601. (define-primitive-effects
  602. ((heap-numbers-equal? . _))
  603. ((= . _) &type-check)
  604. ((<= . _) &type-check)
  605. ((< . _) &type-check)
  606. ((u64-= . _))
  607. ((u64-imm-= . _))
  608. ((u64-< . _))
  609. ((u64-imm-< . _))
  610. ((imm-u64-< . _))
  611. ((s64-= . _))
  612. ((s64-imm-= . _))
  613. ((s64-< . _))
  614. ((s64-imm-< . _))
  615. ((imm-s64-< . _))
  616. ((f64-= . _))
  617. ((f64-< . _))
  618. ((f64-<= . _))
  619. ((zero? . _) &type-check)
  620. ((add . _) &type-check)
  621. ((add/immediate . _) &type-check)
  622. ((mul . _) &type-check)
  623. ((sub . _) &type-check)
  624. ((sub/immediate . _) &type-check)
  625. ((div . _) &type-check)
  626. ((fadd . _))
  627. ((fsub . _))
  628. ((fmul . _))
  629. ((fdiv . _))
  630. ((uadd . _))
  631. ((usub . _))
  632. ((umul . _))
  633. ((uadd/immediate . _))
  634. ((usub/immediate . _))
  635. ((umul/immediate . _))
  636. ((sadd . _))
  637. ((ssub . _))
  638. ((smul . _))
  639. ((sadd/immediate . _))
  640. ((ssub/immediate . _))
  641. ((smul/immediate . _))
  642. ((quo . _) &type-check)
  643. ((rem . _) &type-check)
  644. ((mod . _) &type-check)
  645. ((inexact _) &type-check)
  646. ((s64->f64 _))
  647. ((number? _))
  648. ((complex? _))
  649. ((real? _))
  650. ((rational? _))
  651. ((integer? _))
  652. ((exact? _))
  653. ((inexact? _))
  654. ((inf? _) &type-check)
  655. ((nan? _) &type-check)
  656. ((even? _) &type-check)
  657. ((odd? _) &type-check)
  658. ((rsh n m) &type-check)
  659. ((lsh n m) &type-check)
  660. ((rsh/immediate n) &type-check)
  661. ((lsh/immediate n) &type-check)
  662. ((logand . _) &type-check)
  663. ((logand/immediate . _) &type-check)
  664. ((logior . _) &type-check)
  665. ((logxor . _) &type-check)
  666. ((logsub . _) &type-check)
  667. ((lognot . _) &type-check)
  668. ((ulogand . _))
  669. ((ulogand/immediate . _))
  670. ((ulogior . _))
  671. ((ulogxor . _))
  672. ((ulogsub . _))
  673. ((ursh . _))
  674. ((srsh . _))
  675. ((ulsh . _))
  676. ((slsh . _))
  677. ((ursh/immediate . _))
  678. ((srsh/immediate . _))
  679. ((ulsh/immediate . _))
  680. ((slsh/immediate . _))
  681. ((logtest a b) &type-check)
  682. ((logbit? a b) &type-check)
  683. ((sqrt _) &type-check)
  684. ((abs _) &type-check)
  685. ((floor _) &type-check)
  686. ((ceiling _) &type-check)
  687. ((sin _) &type-check)
  688. ((cos _) &type-check)
  689. ((tan _) &type-check)
  690. ((asin _) &type-check)
  691. ((acos _) &type-check)
  692. ((atan _) &type-check)
  693. ((atan2 x y) &type-check)
  694. ((fsqrt _))
  695. ((fabs _))
  696. ((ffloor _))
  697. ((fceiling _))
  698. ((fsin _))
  699. ((fcos _))
  700. ((ftan _))
  701. ((fasin _))
  702. ((facos _))
  703. ((fatan _))
  704. ((fatan2 x y)))
  705. ;; Characters.
  706. (define-primitive-effects
  707. ((untag-char _))
  708. ((tag-char _)))
  709. ;; Atomics are a memory and a compiler barrier; they cause all effects
  710. ;; so no need to have a case for them here. (Though, see
  711. ;; https://jfbastien.github.io/no-sane-compiler/.)
  712. (define (primitive-effects param name args)
  713. (let ((proc (hashq-ref *primitive-effects* name)))
  714. (if proc
  715. (apply proc param args)
  716. &all-effects)))
  717. (define (expression-effects exp)
  718. (match exp
  719. ((or ($ $const) ($ $prim) ($ $values) ($ $code) ($ $const-fun))
  720. &no-effects)
  721. ((or ($ $fun) ($ $rec))
  722. (&allocate &unknown-memory-kinds))
  723. ((or ($ $call) ($ $callk) ($ $calli))
  724. &all-effects)
  725. (($ $primcall name param args)
  726. (primitive-effects param name args))))
  727. (define (compute-effects conts)
  728. (intmap-map
  729. (lambda (label cont)
  730. (match cont
  731. (($ $kargs names syms ($ $continue k src exp))
  732. (expression-effects exp))
  733. (($ $kargs names syms ($ $branch kf kt src op param args))
  734. (primitive-effects param op args))
  735. (($ $kargs names syms ($ $switch)) &no-effects)
  736. (($ $kargs names syms ($ $prompt))
  737. ;; Although the "main" path just writes &prompt, we don't know
  738. ;; what nonlocal predecessors of the handler do, so we
  739. ;; conservatively assume &all-effects.
  740. &all-effects)
  741. (($ $kargs names syms ($ $throw))
  742. ;; A reachable "throw" term can never be elided.
  743. &all-effects)
  744. (($ $kreceive arity kargs)
  745. (match arity
  746. (($ $arity _ () #f () #f) &type-check)
  747. (($ $arity () () _ () #f) (&allocate &pair))
  748. (($ $arity _ () _ () #f) (logior (&allocate &pair) &type-check))))
  749. (($ $kfun) &type-check)
  750. (($ $kclause) &type-check)
  751. (($ $ktail) &no-effects)))
  752. conts))
  753. ;; There is a way to abuse effects analysis in CSE to also do scalar
  754. ;; replacement, effectively adding `car' and `cdr' expressions to `cons'
  755. ;; expressions, and likewise with other constructors and setters. This
  756. ;; routine adds appropriate effects to `cons' and `set-car!' and the
  757. ;; like.
  758. ;;
  759. ;; This doesn't affect CSE's ability to eliminate expressions, given
  760. ;; that allocations aren't eliminated anyway, and the new effects will
  761. ;; just cause the allocations not to commute with e.g. set-car! which
  762. ;; is what we want anyway.
  763. (define (synthesize-definition-effects effects)
  764. (intmap-map (lambda (label fx)
  765. (if (logtest (logior &write &allocation) fx)
  766. (logior fx &read)
  767. fx))
  768. effects))