diff options
author | Andy Wingo <wingo@pobox.com> | 2023-11-15 14:59:02 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2023-11-15 14:59:02 +0100 |
commit | e529db04a4c344ad3903c36fc771721bbda19ac4 (patch) | |
tree | 3379422bccb6759335bcad3ba63ab8e37bf550cc /module | |
parent | d08cc4f6e23f427b6d13fb63c27a5c8076533e85 (diff) | |
download | guile-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.scm | 22 |
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))) |