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:
parent
b4f0499256
commit
6fc9368d5c
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -29,6 +29,8 @@
|
|||
(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)
|
||||
;; 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,9 +89,13 @@
|
|||
(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)))
|
||||
(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?)))
|
||||
#:ready-variable? safe-ref?))
|
||||
;; UNSOUND --- assume that variables are defined before use
|
||||
(symbol? rhs)))
|
||||
#f]
|
||||
[else (list vars rhs)]))
|
||||
cl))
|
||||
|
@ -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
Loading…
Reference in New Issue
Block a user