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:
Matthew Flatt 2019-06-25 08:41:45 -06:00
parent 3fb226ce2a
commit 8c1dbae88b
2 changed files with 71 additions and 19 deletions

View File

@ -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)]

View File

@ -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