wingo pushed a commit to branch main
in repository guile.
commit e529db04a4c344ad3903c36fc771721bbda19ac4
Author: Andy Wingo <wi...@pobox.com>
AuthorDate: Wed Nov 15 14:59:02 2023 +0100
Add extensibility to Tree-IL effects analysis
* 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.
---
module/language/tree-il/effects.scm | 22 +++++++++++++++++++---
1 file changed, 19 insertions(+), 3 deletions(-)
diff --git a/module/language/tree-il/effects.scm
b/module/language/tree-il/effects.scm
index a37a6d522..be3826239 100644
--- a/module/language/tree-il/effects.scm
+++ b/module/language/tree-il/effects.scm
@@ -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)))
