mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 19:50:24 +02:00
Code Activity

Declarative variables optimization limits eta-expansion

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2020-01-14 09:39:28 +01:00
parent b47bf2434c
commit b6dfc84fd4
1 changed files with 32 additions and 2 deletions
Download patch file Download diff file Expand all files Collapse all files

34
module/language/tree-il/letrectify.scm
View file

@ -160,12 +160,41 @@
declarative) declarative)
private)) 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* (letrectify expr #:key (seal-private-bindings? #f))
(define declarative (compute-declarative-toplevels expr)) (define declarative (compute-declarative-toplevels expr))
(define private (define private
(if seal-private-bindings? (if seal-private-bindings?
(compute-private-toplevels declarative) (compute-private-toplevels declarative)
(make-hash-table))) (make-hash-table)))
(define no-identity (compute-procedures-without-identity expr declarative))
(define declarative-box+value (define declarative-box+value
(let ((tab (make-hash-table))) (let ((tab (make-hash-table)))
(hash-for-each (lambda (key val) (hash-for-each (lambda (key val)
@ -220,8 +249,9 @@
;; permitted by R6RS as procedure equality is explicitly ;; permitted by R6RS as procedure equality is explicitly
;; unspecified, but if it's an irritation in practice, we could ;; unspecified, but if it's an irritation in practice, we could
;; disable this transformation. ;; disable this transformation.
(($ <lambda> src1 meta ((and (? (lambda _ (hash-ref no-identity (cons mod name))))
($ <lambda-case> src2 req #f rest #f () syms body #f)) ($ <lambda> src1 meta
($ <lambda-case> src2 req #f rest #f () syms body #f)))
(let* ((syms (map gensym (map symbol->string syms))) (let* ((syms (map gensym (map symbol->string syms)))
(args (map (lambda (req sym) (make-lexical-ref src2 req sym)) (args (map (lambda (req sym) (make-lexical-ref src2 req sym))
(if rest (append req (list rest)) req) (if rest (append req (list rest)) req)