summaryrefslogtreecommitdiff
path: root/module
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2023-11-15 14:59:02 +0100
committerAndy Wingo <wingo@pobox.com>2023-11-15 14:59:02 +0100
commite529db04a4c344ad3903c36fc771721bbda19ac4 (patch)
tree3379422bccb6759335bcad3ba63ab8e37bf550cc /module
parentd08cc4f6e23f427b6d13fb63c27a5c8076533e85 (diff)
downloadguile-e529db04a4c344ad3903c36fc771721bbda19ac4.tar.gz
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.
Diffstat (limited to 'module')
-rw-r--r--module/language/tree-il/effects.scm22
1 files 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)))