Improve flattener.

This commit is contained in:
Sam Tobin-Hochstadt 2018-06-12 13:40:50 -04:00 committed by Matthew Flatt
parent daa7ddeef8
commit 62ef3ed1ee
4 changed files with 38 additions and 17 deletions

View File

@ -25,7 +25,7 @@ DIRECT = ++direct linklet ++direct kernel
# The linklet compiler's simple inference cannot tell that this # The linklet compiler's simple inference cannot tell that this
# module's keyword-function declarations will have no side effect, but # module's keyword-function declarations will have no side effect, but
# we promise that it's pure: # we promise that it's pure:
PURE = ++pure $(TREE)/collects/racket/private/collect.rkt PURE =
# Set `BUILDDIR` as a prefix on "compiled" output (defaults to empty). # Set `BUILDDIR` as a prefix on "compiled" output (defaults to empty).
# Set `DEPENDSDIR` as the same sort of prefix in the generated # Set `DEPENDSDIR` as the same sort of prefix in the generated

View File

@ -40,6 +40,7 @@
;; Check whether any needed linklet needs an instance of a ;; Check whether any needed linklet needs an instance of a
;; pre-defined instance that is not part of the runtime system: ;; pre-defined instance that is not part of the runtime system:
(define complained? #f) (define complained? #f)
(define needed-vars null)
(for ([lnk (in-list (unbox linklets-in-order))]) (for ([lnk (in-list (unbox linklets-in-order))])
(define needed-reason (hash-ref needed lnk #f)) (define needed-reason (hash-ref needed lnk #f))
(when needed-reason (when needed-reason
@ -54,16 +55,19 @@
(not (hash-ref instance-knot-ties p #f)) (not (hash-ref instance-knot-ties p #f))
(hash-ref needed in-lnk #t)) (hash-ref needed in-lnk #t))
(unless complained? (unless complained?
(log-status "~a\n~a" (log-status "~a\n ~a"
"Unfortunately, some linklets depend on pre-defined host instances" "Unfortunately, some linklets depend on pre-defined host instances"
"that are not part of the runtime system:") "that are not part of the runtime system:")
(set! complained? #t)) (set! complained? #t))
(unless complained-this? (unless complained-this?
(log-status " - ~a at ~s" (link-name lnk) (link-phase lnk)) (log-status " - ~a at ~s" (link-name lnk) (link-phase lnk))
(set! complained-this? #t)) (set! complained-this? #t))
(log-status "~a" (lines (format " needs ~s:" p) in-vars)))) (log-status "~a" (lines (format " needs ~s:" p) in-vars))
(set! needed-vars (append in-vars needed-vars))))
(when complained-this? (when complained-this?
(log-status " needed by ~s" needed-reason)))) (log-status " needed by ~s" needed-reason))))
(when complained? (when complained?
(exit 1))) (log-status "~a\n ~a"
"If these dependencies are not removed by subsequent flattening"
"and simplification, extraction cannot succeed."))
(and complained? needed-vars))

View File

@ -17,23 +17,25 @@
#:needed needed #:needed needed
#:exports exports #:exports exports
#:instance-knot-ties instance-knot-ties #:instance-knot-ties instance-knot-ties
#:primitive-table-directs primitive-table-directs) #:primitive-table-directs primitive-table-directs
#:check-later-names check-later-names)
(log-status "Flattening to a single linklet...") (log-status "Flattening to a single linklet...")
(define needed-linklets-in-order (define needed-linklets-in-order
(for/list ([lnk (in-list (unbox linklets-in-order))] (for/list ([lnk (in-list (unbox linklets-in-order))]
#:when (hash-ref needed lnk #f)) #:when (hash-ref needed lnk #f))
lnk)) lnk))
(define variable-names (pick-variable-names (define variable-names (pick-variable-names
#:linklets linklets #:linklets linklets
#:needed-linklets-in-order needed-linklets-in-order #:needed-linklets-in-order needed-linklets-in-order
#:instance-knot-ties instance-knot-ties)) #:instance-knot-ties instance-knot-ties))
(for ([var (in-hash-keys variable-names)] (for ([var (in-hash-keys variable-names)]
#:when (symbol? (link-name (variable-link var)))) #:when (symbol? (link-name (variable-link var)))
(error 'flatten "found a dependency on a non-primitive: ~s from ~s" #:unless (memq (variable-name var) check-later-names))
(variable-name var) (error 'flatten "found a dependency on a non-primitive: ~s from ~s"
(link-name (variable-link var)))) (variable-name var)
(link-name (variable-link var))))
`(linklet `(linklet
;; imports ;; imports

View File

@ -13,6 +13,9 @@
"decompile.rkt" "decompile.rkt"
"save-and-report.rkt" "save-and-report.rkt"
"underscore.rkt" "underscore.rkt"
"symbol.rkt"
"../run/status.rkt"
"../common/set.rkt"
racket/pretty) racket/pretty)
(provide extract) (provide extract)
@ -97,11 +100,12 @@
#:needed needed))) #:needed needed)))
;; Check for bootstrap obstacles, and report what we've found ;; Check for bootstrap obstacles, and report what we've found
(check-and-report! #:compiled-modules compiled-modules (define needed-vars
#:linklets linklets (check-and-report! #:compiled-modules compiled-modules
#:linklets-in-order linklets-in-order #:linklets linklets
#:needed needed #:linklets-in-order linklets-in-order
#:instance-knot-ties instance-knot-ties) #:needed needed
#:instance-knot-ties instance-knot-ties))
;; If we're in source mode, we can generate a single linklet ;; If we're in source mode, we can generate a single linklet
;; that combines all the ones we found ;; that combines all the ones we found
@ -121,7 +125,8 @@
#:needed needed #:needed needed
#:exports exports #:exports exports
#:instance-knot-ties instance-knot-ties #:instance-knot-ties instance-knot-ties
#:primitive-table-directs primitive-table-directs)) #:primitive-table-directs primitive-table-directs
#:check-later-names needed-vars))
(define simplified-expr (define simplified-expr
(simplify-definitions flattened-linklet-expr)) (simplify-definitions flattened-linklet-expr))
@ -130,6 +135,16 @@
(define gced-linklet-expr (define gced-linklet-expr
(garbage-collect-definitions simplified-expr)) (garbage-collect-definitions simplified-expr))
(log-status "Checking that references to the runtime were removed by simplification ...")
(define used-names (all-used-symbols gced-linklet-expr))
(define still-needed (filter (lambda (v) (set-member? used-names v)) needed-vars))
(unless (null? still-needed)
(log-status "Simplification failed to remove references to: ~a"
(lines still-needed))
(exit 1))
;; Avoid gratuitous differences due to names generated during ;; Avoid gratuitous differences due to names generated during
;; expansion ;; expansion
(define re-renamed-linklet-expr (define re-renamed-linklet-expr