expander: improve extractor to recognize once-set variables
When `set!` is used to tie a recursove knot in a flattened linklet, the expander can recognize that pattern and not complain that a mutable variable might be shared across places. Improving that inference means fewer `++global-ok` flags in Makefiles. This commit also avoids single-quote as an escaping form in a makefile, which doesn't work with nmake on Windows.
This commit is contained in:
parent
3fb226ce2a
commit
8c1dbae88b
|
@ -6,14 +6,15 @@
|
||||||
(define (check-global linklet global-ok)
|
(define (check-global linklet global-ok)
|
||||||
(define es (cdddr linklet))
|
(define es (cdddr linklet))
|
||||||
|
|
||||||
|
;; Variables that are not under `lambda`:
|
||||||
(define vars (make-hasheq))
|
(define vars (make-hasheq))
|
||||||
|
|
||||||
;; Get all variables that are not under `lambda`. That's not
|
;; Get all variables that are declared not under `lambda`. That's
|
||||||
;; necessarily all variables that act like globals, since a
|
;; not necessarily all variables that act like globals, since a
|
||||||
;; top-level expression could call a function that allocates a
|
;; top-level expression could call a function that allocates a
|
||||||
;; mutable variable, but it's close enough to be useful.
|
;; mutable variable, but it's close enough to be useful.
|
||||||
(for ([e (in-list es)])
|
(for ([e (in-list es)])
|
||||||
(let loop ([e e])
|
(define (loop e)
|
||||||
(match e
|
(match e
|
||||||
[`(define-values (,ids ...) ,rhs)
|
[`(define-values (,ids ...) ,rhs)
|
||||||
(for ([id (in-list ids)])
|
(for ([id (in-list ids)])
|
||||||
|
@ -21,18 +22,77 @@
|
||||||
(loop rhs)]
|
(loop rhs)]
|
||||||
[`(lambda . ,_) (void)]
|
[`(lambda . ,_) (void)]
|
||||||
[`(case-lambda . ,_) (void)]
|
[`(case-lambda . ,_) (void)]
|
||||||
[`(let-values ([,idss ,rhss] ...) ,bodys ...)
|
[`(let-values . ,_)
|
||||||
|
(not-under-lambda-let e)]
|
||||||
|
[`(letrec-values . ,_)
|
||||||
|
(not-under-lambda-let e)]
|
||||||
|
[`(,es ...)
|
||||||
|
(for ([e (in-list es)])
|
||||||
|
(loop e))]
|
||||||
|
[_ #f]))
|
||||||
|
(define (not-under-lambda-let e)
|
||||||
|
(match e
|
||||||
|
[`(,_ ([,idss ,rhss] ...) ,bodys ...)
|
||||||
(for* ([ids (in-list idss)]
|
(for* ([ids (in-list idss)]
|
||||||
[id (in-list ids)])
|
[id (in-list ids)])
|
||||||
(hash-set! vars id #t))
|
(hash-set! vars id #t))
|
||||||
(for ([rhs (in-list rhss)])
|
(for ([rhs (in-list rhss)])
|
||||||
(loop rhs))
|
(loop rhs))
|
||||||
(for ([body (in-list bodys)])
|
(for ([body (in-list bodys)])
|
||||||
(loop body))]
|
(loop body))]))
|
||||||
|
(loop e))
|
||||||
|
|
||||||
|
;; Variables that are potentially used after the
|
||||||
|
;; linklet body completes
|
||||||
|
(define used-later-vars (make-hasheq))
|
||||||
|
|
||||||
|
;; Exported variable are used later
|
||||||
|
(for ([ex (in-list (caddr linklet))])
|
||||||
|
(define sym (if (pair? ex) (car ex) ex))
|
||||||
|
(hash-set! used-later-vars sym #t))
|
||||||
|
|
||||||
|
;; Fill `used-later-vars`, because any function not in that set is
|
||||||
|
;; something that we don't need to worry about being called later,
|
||||||
|
;; so we can ignore any side effects it may have. For example,
|
||||||
|
;; `set!`s that just set up recursive bindings are ok, because they
|
||||||
|
;; happen before the linklet body completes, and those are usually
|
||||||
|
;; initialed by functions that are called only on startup.
|
||||||
|
(for ([e (in-list es)])
|
||||||
|
(define (now e)
|
||||||
|
(match e
|
||||||
|
[`(define-values (,ids ...) ,rhs)
|
||||||
|
(now rhs)]
|
||||||
|
[`(lambda ,_ ,bodys ...)
|
||||||
|
(for ([body (in-list bodys)])
|
||||||
|
(later body))]
|
||||||
|
[`(case-lambda [,_ ,bodyss ...] ...)
|
||||||
|
(for* ([bodys (in-list bodyss)]
|
||||||
|
[body (in-list bodys)])
|
||||||
|
(later body))]
|
||||||
|
[`(quote ,_) (void)]
|
||||||
|
[`(,es ...)
|
||||||
|
(unless (null? es)
|
||||||
|
(case (car es)
|
||||||
|
[(begin begin0 set! if) (void)]
|
||||||
|
[else
|
||||||
|
;; The value of any identifier in an argument position
|
||||||
|
;; might be used later
|
||||||
|
(for ([e (in-list (cdr es))])
|
||||||
|
(when (symbol? e)
|
||||||
|
(later e)))]))
|
||||||
|
(for ([e (in-list es)])
|
||||||
|
(now e))]
|
||||||
|
[_ (void)]))
|
||||||
|
(define (later e)
|
||||||
|
(match e
|
||||||
|
[`(quote ,_) (void)]
|
||||||
[`(,es ...)
|
[`(,es ...)
|
||||||
(for ([e (in-list es)])
|
(for ([e (in-list es)])
|
||||||
(loop e))]
|
(later e))]
|
||||||
[_ #f])))
|
[_
|
||||||
|
(when (symbol? e)
|
||||||
|
(hash-set! used-later-vars e #t))]))
|
||||||
|
(now e))
|
||||||
|
|
||||||
(define complained (make-hasheq))
|
(define complained (make-hasheq))
|
||||||
|
|
||||||
|
@ -51,6 +111,9 @@
|
||||||
(for ([e (in-list es)])
|
(for ([e (in-list es)])
|
||||||
(let loop ([e e])
|
(let loop ([e e])
|
||||||
(match e
|
(match e
|
||||||
|
[`(define-values (,id) (lambda ,_ ,bodys ...))
|
||||||
|
(when (hash-ref used-later-vars id #f)
|
||||||
|
(loop bodys))]
|
||||||
[`(set! ,id ,rhs)
|
[`(set! ,id ,rhs)
|
||||||
(found-state! id e)
|
(found-state! id e)
|
||||||
(loop rhs)]
|
(loop rhs)]
|
||||||
|
|
|
@ -20,25 +20,14 @@ DISALLOW = ++disallow error
|
||||||
# global state to be ok:
|
# global state to be ok:
|
||||||
GLOBALS = --no-global \
|
GLOBALS = --no-global \
|
||||||
++global-ok the-sandman \
|
++global-ok the-sandman \
|
||||||
++global-ok sync-on-channel \
|
|
||||||
++global-ok post-shutdown-action \
|
++global-ok post-shutdown-action \
|
||||||
++global-ok get-subprocesses-time \
|
++global-ok get-subprocesses-time \
|
||||||
++global-ok force-atomic-timeout-callback \
|
|
||||||
++global-ok pre-poll-callbacks \
|
++global-ok pre-poll-callbacks \
|
||||||
++global-ok queued-shutdowns \
|
++global-ok queued-shutdowns \
|
||||||
++global-ok place-ensure-wakeup! \
|
|
||||||
++global-ok place-wakeup-initial \
|
|
||||||
++global-ok place-wakeup \
|
|
||||||
++global-ok compute-memory-sizes \
|
++global-ok compute-memory-sizes \
|
||||||
++global-ok check-place-activity \
|
|
||||||
++global-ok make-place-ports+fds \
|
++global-ok make-place-ports+fds \
|
||||||
++global-ok future-block-for-atomic \
|
|
||||||
++global-ok pthread-count \
|
++global-ok pthread-count \
|
||||||
++global-ok wakeup-this-place \
|
++global-ok "logging-future-events?" \
|
||||||
++global-ok ensure-place-wakeup-handle \
|
|
||||||
++global-ok futures-sync-for-custodian-shutdown \
|
|
||||||
++global-ok 'future-scheduler-add-thread-custodian-mapping!' \
|
|
||||||
++global-ok 'logging-future-events?' \
|
|
||||||
++global-ok log-future-event
|
++global-ok log-future-event
|
||||||
|
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue
Block a user