diff options
author | Andy Wingo <wingo@pobox.com> | 2023-11-15 19:30:09 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2023-11-15 19:31:24 +0100 |
commit | c2a9380a42ed2b2fdcfe641dc912b389f65f8db5 (patch) | |
tree | 57b6f78c2d42e96f8cd8700bb6d3795f5debb54d /module/language | |
parent | 28a428135f6568cd7dac3d8ecba2edeb7ddbd95e (diff) | |
download | guile-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.scm | 28 | ||||
-rw-r--r-- | 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 |