mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-20 19:50:24 +02:00
Disable eta-expansion in letrectification
* module/language/tree-il/letrectify.scm: Disable eta-expansion, as we now do that after peval.
This commit is contained in:
parent
2993c2d873
commit
bea8660c44
1 changed files with 5 additions and 70 deletions
|
@ -1,6 +1,6 @@
|
||||||
;;; transformation of top-level bindings into letrec*
|
;;; transformation of top-level bindings into letrec*
|
||||||
|
|
||||||
;; Copyright (C) 2019 Free Software Foundation, Inc.
|
;; Copyright (C) 2019-2020 Free Software Foundation, Inc.
|
||||||
|
|
||||||
;;;; This library is free software; you can redistribute it and/or
|
;;;; This library is free software; you can redistribute it and/or
|
||||||
;;;; modify it under the terms of the GNU Lesser General Public
|
;;;; modify it under the terms of the GNU Lesser General Public
|
||||||
|
@ -40,16 +40,11 @@
|
||||||
;; (_ (begin (variable-set! a-var a)))
|
;; (_ (begin (variable-set! a-var a)))
|
||||||
;; (b-var (module-make-local-var! (current-module) 'b))
|
;; (b-var (module-make-local-var! (current-module) 'b))
|
||||||
;; (b (lambda () a))
|
;; (b (lambda () a))
|
||||||
;; ;; Note, declarative lambda definitions are eta-expanded when
|
;; (_ (begin (variable-set! b-var b)))
|
||||||
;; ;; referenced by value to make the callee well-known in the
|
|
||||||
;; ;; compilation unit.
|
|
||||||
;; (_ (begin (variable-set! b-var (lambda () (b)))))
|
|
||||||
;; (_ (begin (foo a) #t))
|
;; (_ (begin (foo a) #t))
|
||||||
;; (c-var (module-make-local-var! (current-module) 'c)))
|
;; (c-var (module-make-local-var! (current-module) 'c)))
|
||||||
;; (c (lambda () (variable-set! c-var b) ((variable-ref c-var))))
|
;; (c (lambda () (variable-set! c-var b) ((variable-ref c-var))))
|
||||||
;; ;; Here `c' is not eta-expanded, as it's not a declarative
|
;; (_ (begin (variable-set! c-var c))))
|
||||||
;; ;; binding.
|
|
||||||
;; (_ (begin (variable-set! c-var (lambda () (c))))))
|
|
||||||
;; (void))
|
;; (void))
|
||||||
;;
|
;;
|
||||||
;; Inside the compilation unit, references to "declarative" top-level
|
;; Inside the compilation unit, references to "declarative" top-level
|
||||||
|
@ -160,41 +155,12 @@
|
||||||
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)
|
||||||
|
@ -234,36 +200,6 @@
|
||||||
(add-binding '_ (gensym "_") (make-seq src stmt (make-void src))
|
(add-binding '_ (gensym "_") (make-seq src stmt (make-void src))
|
||||||
tail)))
|
tail)))
|
||||||
|
|
||||||
(define (residualize src mod name var expr)
|
|
||||||
(let ((lexical (make-lexical-ref src name var)))
|
|
||||||
(match expr
|
|
||||||
;; Eta-expand references to declarative procedure definitions so
|
|
||||||
;; that adding these bindings to the module doesn't cause
|
|
||||||
;; otherwise "well-known" (in the sense of closure conversion)
|
|
||||||
;; procedures to become not well-known.
|
|
||||||
;;
|
|
||||||
;; Note, this means that eq? will always return #f when
|
|
||||||
;; comparing a value to a <lexical-ref> of a declarative
|
|
||||||
;; procedure definition, because the residualized reference is a
|
|
||||||
;; fresh value (the <lambda> literal we return here). This is
|
|
||||||
;; permitted by R6RS as procedure equality is explicitly
|
|
||||||
;; unspecified, but if it's an irritation in practice, we could
|
|
||||||
;; disable this transformation.
|
|
||||||
((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)
|
|
||||||
syms))
|
|
||||||
(body (if rest
|
|
||||||
(make-primcall src 'apply (cons lexical args))
|
|
||||||
(make-call src lexical args))))
|
|
||||||
(make-lambda src1 meta
|
|
||||||
(make-lambda-case src2 req #f rest #f '() syms
|
|
||||||
body #f))))
|
|
||||||
(_ lexical))))
|
|
||||||
|
|
||||||
(define (visit-expr expr)
|
(define (visit-expr expr)
|
||||||
(post-order
|
(post-order
|
||||||
(lambda (expr)
|
(lambda (expr)
|
||||||
|
@ -272,8 +208,7 @@
|
||||||
(match (declarative-box+value mod name)
|
(match (declarative-box+value mod name)
|
||||||
(#f expr)
|
(#f expr)
|
||||||
((box . value)
|
((box . value)
|
||||||
(residualize src mod name value
|
(make-lexical-ref src name value))))
|
||||||
(hash-ref declarative (cons mod name))))))
|
|
||||||
(_ expr)))
|
(_ expr)))
|
||||||
expr))
|
expr))
|
||||||
|
|
||||||
|
@ -304,7 +239,7 @@
|
||||||
(list (make-lexical-ref src 'mod mod-var)
|
(list (make-lexical-ref src 'mod mod-var)
|
||||||
(make-const src name))))
|
(make-const src name))))
|
||||||
(exp (visit-expr exp))
|
(exp (visit-expr exp))
|
||||||
(ref (residualize src mod name value exp))
|
(ref (make-lexical-ref src name value))
|
||||||
(init
|
(init
|
||||||
(make-primcall src '%variable-set!
|
(make-primcall src '%variable-set!
|
||||||
(list (make-lexical-ref src name box)
|
(list (make-lexical-ref src name box)
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue