mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

Add extensibility to Tree-IL effects analysis

Browse source 
* module/language/tree-il/effects.scm (add-primcall-effect-analyzer!):
New facility.
* module/language/tree-il/effects.scm (make-effects-analyzer): If a
primcall's args cause no effects, call out to a user-provided
effect-free? primitive for a primcall.  If true, the primcall will be
marked as depending on all effects but causing none; this will allow it
to be elided by letrectify or peval.
This commit is contained in:
Andy Wingo 2023-11-15 14:59:02 +01:00
parent d08cc4f6e2
commit e529db04a4
1 changed files with 19 additions and 3 deletions
Download patch file Download diff file Expand all files Collapse all files

22
module/language/tree-il/effects.scm
View file

@ -35,7 +35,8 @@
effect-free?
constant?
depends-on-effects?
causes-effects?))
causes-effects?
add-primcall-effect-analyzer!))
;;;
;;; Hey, it's some effects analysis! If you invoke
@ -231,6 +232,12 @@
(and (not (causes-effects? a (&depends-on b)))
(not (causes-effects? b (&depends-on a)))))
(define *primcall-effect-analyzers* (make-hash-table))
(define (add-primcall-effect-analyzer! name compute-effect-free?)
(hashq-set! *primcall-effect-analyzers* name compute-effect-free?))
(define (primcall-effect-analyzer name)
(hashq-ref *primcall-effect-analyzers* name))
(define (make-effects-analyzer assigned-lexical?)
"Returns a procedure of type EXP -> EFFECTS that analyzes the effects
of an expression."
@ -576,8 +583,17 @@ of an expression."
;; A call to an unknown procedure can do anything.
(($ <primcall> _ name args)
(logior &all-effects-but-bailout
(cause &all-effects-but-bailout)))
(match (primcall-effect-analyzer name)
(#f (logior &all-effects-but-bailout
(cause &all-effects-but-bailout)))
(compute-effect-free?
(if (and (effect-free?
(exclude-effects (accumulate-effects args) &allocation))
(compute-effect-free? args))
&all-effects-but-bailout
(logior &all-effects-but-bailout
(cause &all-effects-but-bailout))))))
(($ <call> _ proc args)
(logior &all-effects-but-bailout
(cause &all-effects-but-bailout)))