This is an automated email from the git hooks/post-receive script.
wingo pushed a commit to branch main
in repository guile.
The following commit(s) were added to refs/heads/main by this push:
new c2a9380a4 peval: better primcall folding in effect contexts
c2a9380a4 is described below
commit c2a9380a42ed2b2fdcfe641dc912b389f65f8db5
Author: Andy Wingo <wi...@pobox.com>
AuthorDate: Wed Nov 15 19:30:09 2023 +0100
peval: better primcall folding in effect contexts
* module/language/tree-il/peval.scm (peval): If a primcall is
effect-free, don't require that its args are too: just revisit args as a
sequence in effect context.
* module/language/tree-il/effects.scm (effect-free-primcall?): New
exported function.
---
module/language/tree-il/effects.scm | 28 +++++++++++++++++++++++++++-
module/language/tree-il/peval.scm | 14 +++++---------
2 files changed, 32 insertions(+), 10 deletions(-)
diff --git a/module/language/tree-il/effects.scm
b/module/language/tree-il/effects.scm
index be3826239..fa05ac02c 100644
--- a/module/language/tree-il/effects.scm
+++ b/module/language/tree-il/effects.scm
@@ -36,7 +36,8 @@
constant?
depends-on-effects?
causes-effects?
- add-primcall-effect-analyzer!))
+ add-primcall-effect-analyzer!
+ effect-free-primcall?))
;;;
;;; Hey, it's some effects analysis! If you invoke
@@ -238,6 +239,31 @@
(define (primcall-effect-analyzer name)
(hashq-ref *primcall-effect-analyzers* name))
+(define (effect-free-primcall? name args)
+ "Return #f unless a primcall of @var{name} with @var{args} can be
+replaced with @code{(begin . @var{args})} in an effect context."
+ (match (cons name args)
+ ((or ('values . _)
+ ('list . _)
+ ('vector . _)
+ ('eq? _ _)
+ ('eqv? _ _)
+ ('cons* _ . _)
+ ('acons _ _ _)
+ ((or 'not
+ 'pair? 'null? 'nil? 'list?
+ 'symbol? 'variable? 'vector? 'struct? 'string?
+ 'number? 'char? 'eof-object? 'exact-integer?
+ 'bytevector? 'keyword? 'bitvector?
+ 'procedure? 'thunk? 'atomic-box?
+ 'vector 'make-variable)
+ _))
+ #t)
+ (_
+ (match (primcall-effect-analyzer name)
+ (#f #f)
+ (effect-free? (effect-free? args))))))
+
(define (make-effects-analyzer assigned-lexical?)
"Returns a procedure of type EXP -> EFFECTS that analyzes the effects
of an expression."
diff --git a/module/language/tree-il/peval.scm
b/module/language/tree-il/peval.scm
index 9a5047ce1..1abb0f08d 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -683,11 +683,6 @@ top-level bindings from ENV and return the resulting
expression."
;; mutable data (like `car' or toplevel references).
(constant? (compute-effects x)))
- (define (can-elide-statement? stmt)
- (let ((effects (compute-effects stmt)))
- (effect-free?
- (exclude-effects effects (logior &allocation &zero-values)))))
-
(define (prune-bindings ops in-order? body counter ctx build-result)
;; This helper handles both `let' and `letrec'/`fix'. In the latter
;; cases we need to make sure that if referenced binding A needs
@@ -1525,10 +1520,11 @@ top-level bindings from ENV and return the resulting
expression."
(fold-constants src name args ctx))
((name . args)
- (let ((exp (make-primcall src name args)))
- (if (and (eq? ctx 'effect) (can-elide-statement? exp))
- (make-void src)
- exp)))))
+ (if (and (eq? ctx 'effect) (effect-free-primcall? name args))
+ (if (null? args)
+ (make-void src)
+ (for-tail (list->seq src args)))
+ (make-primcall src name args)))))
(($ <call> src orig-proc orig-args)
;; todo: augment the global env with specialized functions
