summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2020-01-14 09:39:28 +0100
committerAndy Wingo <wingo@pobox.com>2020-01-14 09:39:28 +0100
commitb6dfc84fd4b2be4db9199b86cf6607a10b2ecf99 (patch)
treeecdc52ac3c655ab70516c4faf4d9c7f4b4ad4605
parentb47bf2434c656eb7fb6be0894dac3bea8b53ac05 (diff)
downloadguile-b6dfc84fd4b2be4db9199b86cf6607a10b2ecf99.tar.gz
Declarative variables optimization limits eta-expansion
* module/language/tree-il/letrectify.scm (compute-procedures-without-identity): (letrectify): Only eta-expand lambda references that appear outside the operator position more than once. This should restore peoples' expectations that (eqv? f f) without penalizing optimization.
-rw-r--r--module/language/tree-il/letrectify.scm34
1 files changed, 32 insertions, 2 deletions
diff --git a/module/language/tree-il/letrectify.scm b/module/language/tree-il/letrectify.scm
index aecfa3128..09b1cde17 100644
--- a/module/language/tree-il/letrectify.scm
+++ b/module/language/tree-il/letrectify.scm
@@ -160,12 +160,41 @@
declarative)
private))
+;; A declarative procedure has a distinct identity if it appears outside
+;; the operator position in a call in more than one place. Otherwise we
+;; will eta-expand its uses, if any.
+(define (compute-procedures-without-identity expr declarative)
+ (define counts (make-hash-table))
+ (hash-for-each (lambda (k v) (hash-set! counts k 0)) declarative)
+ (tree-il-for-each
+ (lambda (x)
+ (match x
+ (($ <toplevel-ref> src mod name)
+ (let ((k (cons mod name)))
+ (match (hash-ref counts k)
+ (#f #f)
+ (count (hash-set! counts k (1+ count))))))
+ (($ <call> _ ($ <toplevel-ref> src mod name))
+ (let ((k (cons mod name)))
+ (match (hash-ref counts k)
+ (#f #f)
+ (count (hash-set! counts k (1- count))))))
+ (_ #f)))
+ expr)
+ (define no-identity (make-hash-table))
+ (hash-for-each (lambda (k count)
+ (when (<= count 1)
+ (hash-set! no-identity k #t)))
+ counts)
+ no-identity)
+
(define* (letrectify expr #:key (seal-private-bindings? #f))
(define declarative (compute-declarative-toplevels expr))
(define private
(if seal-private-bindings?
(compute-private-toplevels declarative)
(make-hash-table)))
+ (define no-identity (compute-procedures-without-identity expr declarative))
(define declarative-box+value
(let ((tab (make-hash-table)))
(hash-for-each (lambda (key val)
@@ -220,8 +249,9 @@
;; permitted by R6RS as procedure equality is explicitly
;; unspecified, but if it's an irritation in practice, we could
;; disable this transformation.
- (($ <lambda> src1 meta
- ($ <lambda-case> src2 req #f rest #f () syms body #f))
+ ((and (? (lambda _ (hash-ref no-identity (cons mod name))))
+ ($ <lambda> src1 meta
+ ($ <lambda-case> src2 req #f rest #f () syms body #f)))
(let* ((syms (map gensym (map symbol->string syms)))
(args (map (lambda (req sym) (make-lexical-ref src2 req sym))
(if rest (append req (list rest)) req)