revert a keyword-argument expansion that confuses TR

A change in keyword-argument expansion was intended to avoid
copy-propagation wrok in later passes. That saving does not appear to
be worthwhile, so revert it.

Reverting the change exposed weakness in the expander flattener and an
unsoundness in its simplification pass. That unsoundness has to do
with the assumption that variables are defined before use. The unsound
assumption is likely to be fine for code that is flattened --- all the
more considering that flattened code is routinely run in unsafe mode
--- but it's a departure from the intended safety of the simplifier.
Improving the analysis to so that it's sound and good enough will
require sometimes inferring when a structure-type property guard (for
`prop:evt`, at least) will succeed.
This commit is contained in:
Matthew Flatt 2018-02-28 18:49:58 -07:00
parent b4f0499256
commit 6fc9368d5c
4 changed files with 22060 additions and 21635 deletions

View File

@ -1054,19 +1054,6 @@
arg-accum
(cons (cons (car l) (car ids))
kw-pairs))]
[(and (identifier? (car l))
(null? bind-accum))
;; Don't generate an alias for an identifier if we haven't
;; needed to bind anything earlier, since we'll keep the
;; arguments in order in that case. This optimization is especially
;; useful for the rator position of a direct keyword call,
;; since we avoid generating an alias (that might take a while
;; to optimize away] to the generic implementation.
(loop (cdr l)
(cdr ids)
null
(cons (car l) arg-accum)
kw-pairs)]
[else (loop (cdr l)
(cdr ids)
(cons (list (car ids) (car l)) bind-accum)

View File

@ -279,7 +279,7 @@
[(eq? get-encoded-root-expand-ctx 'empty)
;; A `#:empty-namespace` declaration requested a namespace with no initial bindings
(namespace-set-root-expand-ctx! ns (delay (shift-to-inside-root-context
(make-root-expand-context self))))]
(make-root-expand-context #:self-mpi self))))]
[(procedure? get-encoded-root-expand-ctx)
;; Root expand context has been preserved; deserialize it on demand
(namespace-set-root-expand-ctx! ns (delay (shift-to-inside-root-context

View File

@ -28,7 +28,9 @@
(define cl* (map (lambda (c) (mutated-vars (cadr c))) cl))
(define binds (apply seteq (apply append (map car cl))))
(set-union (apply union-all (map mutated-vars cl*)) (set-remove (mutated-vars e) binds))]
[`(letrec-values ,cl ,e)
[`(letrec-values ,cl ,e)
;; UNSOUND --- assume that variables are defined before use
;; (i.e., no visible implicit assignment)
(define cl* (map (lambda (c) (mutated-vars (cadr c))) cl))
(define binds (apply seteq (apply append (map car cl))))
(set-remove (set-union (mutated-vars e) (apply union-all (map mutated-vars cl*))) binds)]
@ -87,11 +89,15 @@
(lambda (c)
(define vars (car c))
(define rhs (simp (cadr c)))
(cond [(and (for/and ([v (in-list vars)]) (not (set-member? body-frees v)))
(not (any-side-effects? rhs (length vars) #:known-defns seen-defns
#:ready-variable? safe-ref?)))
#f]
[else (list vars rhs)]))
(cond
[(and (for/and ([v (in-list vars)]) (not (set-member? body-frees v)))
(or
(not (any-side-effects? rhs (length vars) #:known-defns seen-defns
#:ready-variable? safe-ref?))
;; UNSOUND --- assume that variables are defined before use
(symbol? rhs)))
#f]
[else (list vars rhs)]))
cl))
`(let-values ,cl* ,simp-body)]
[`(letrec-values ,cl ,e)
@ -105,6 +111,7 @@
(list (car c)
(simp (cadr c)))))]
[`(variable-reference-constant? (#%variable-reference ,x))
;; UNSOUND --- assume that variables are defined before use
(not (hash-ref vars x #f))]
[`(,sym ,e ...)
#:when (memq sym '(begin begin0 with-continuation-mark set!))
@ -128,9 +135,10 @@
(define seen-defns (make-hasheq))
(register-known-primitives! seen-defns)
(define (safe-defn? e)
(and (defn? e)
(not (any-side-effects? (defn-rhs e) (length (defn-syms e)) #:known-defns seen-defns))))
(define (safe-defn-or-expr? e)
(if (defn? e)
(not (any-side-effects? (defn-rhs e) (length (defn-syms e)) #:known-defns seen-defns))
(not (any-side-effects? e #f #:known-defns seen-defns))))
(define (safe-ref? s) (hash-ref seen-defns s #f))
@ -139,9 +147,11 @@
(cond [(null? body) null]
[(defn? (car body))
(for* ([d (in-list body)]
#:break (not (safe-defn? d))
[s (in-list (defn-syms d))])
(hash-set! seen-defns s (known-defined)))
#:break (and (defn? d)
(hash-ref seen-defns (car (defn-syms d)) #f))
#:break (not (safe-defn-or-expr? d))
#:when (defn? d))
(add-defn-known! seen-defns (defn-syms d) (defn-rhs d)))
(define e (car body))
(define new-defn
(list 'define-values (defn-syms e) (simplify-expr (defn-rhs e) all-mutated-vars safe-ref? seen-defns)))

File diff suppressed because it is too large Load Diff