summaryrefslogtreecommitdiff
path: root/module/language
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2023-11-15 19:30:09 +0100
committerAndy Wingo <wingo@pobox.com>2023-11-15 19:31:24 +0100
commitc2a9380a42ed2b2fdcfe641dc912b389f65f8db5 (patch)
tree57b6f78c2d42e96f8cd8700bb6d3795f5debb54d /module/language
parent28a428135f6568cd7dac3d8ecba2edeb7ddbd95e (diff)
downloadguile-c2a9380a42ed2b2fdcfe641dc912b389f65f8db5.tar.gz
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.
Diffstat (limited to 'module/language')
-rw-r--r--module/language/tree-il/effects.scm28
-rw-r--r--module/language/tree-il/peval.scm14
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