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 arg-accum
(cons (cons (car l) (car ids)) (cons (cons (car l) (car ids))
kw-pairs))] 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) [else (loop (cdr l)
(cdr ids) (cdr ids)
(cons (list (car ids) (car l)) bind-accum) (cons (list (car ids) (car l)) bind-accum)

View File

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

View File

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