commit 4b8f07322986b7c96c73ebf2170bc8ded67b0611
parent 597bf1ffcbeaf9890bde63fc6e1bedd94fba54e5
Author: Ryan Culpepper <ryanc@racket-lang.org>
Date: Sat, 24 Sep 2011 21:10:25 -0600
improved check-requires
Added option to list the names used by each KEEP or BYPASS module
and indicate how used (as reference, in syntax template, etc).
Improved BYPASS; it now gives a list of suggested replacements
(and, optionally, what dependencies each replacement satisfies).
Incompatibly changed exports of macro-debugger/analysis/check-requires;
the new analysis result type is too complicated (and volatile, still)
to document for 0 other clients; focus on the script/output instead.
Removed check-requires-script.rkt.
Updated module whitelist.
Fixed syntax-local-value when identifier later used in def ctx
(destroyed binding information). This manifested as missed references
to modules that does define-local-member-name.
Fixed identifiers without syntax-source-module such as intro'd by
unit-from-context. This manifested as missed references to modules
that provided bindings used by unit-from-context forms.
original commit: 755cedc5efe9179e501f08123bdf08e2dae19e78
Diffstat:
11 files changed, 917 insertions(+), 444 deletions(-)
diff --git a/collects/macro-debugger/analysis/check-requires.rkt b/collects/macro-debugger/analysis/check-requires.rkt
@@ -1,60 +1,31 @@
#lang racket/base
-(require racket/contract
+(require racket/contract/base
+ racket/cmdline
racket/match
+ syntax/modcollapse
unstable/struct
- macro-debugger/model/deriv
- "private/reftable.rkt"
+ "private/get-references.rkt"
"private/nom-use-alg.rkt"
"private/util.rkt")
(provide/contract
- [check-requires (-> module-path? list?)]
- [show-requires (-> module-path? list?)]
- [add-disappeared-uses? (parameter/c boolean?)]
+ [check-requires
+ (->* (module-path?)
+ (#:show-keep? any/c
+ #:show-bypass? any/c
+ #:show-drop? any/c
+ #:show-uses? any/c)
+ void?)]
+ [show-requires (-> module-path? list?)]
[mpi->key (-> module-path-index? any/c)])
#|
+==========
-The purpose of this script is to estimate a module's useless requires.
-
-Usage:
-
- (check-requires <module-name>)
-
-Examples:
-
- (check-requires 'typed-scheme)
- (check-requires 'unstable/markparam)
- (check-requires 'macro-debugger/syntax-browser/widget)
-
-The procedure prints one line per (non-label) require in the following
-format:
-
- KEEP <module> at <phase> <optional-comment>
- - The require must be kept because bindings defined within it are used.
- - The optional comment indicates if the require must be kept
- - only because its bindings are re-exported
- - only because the whitelist DB says so
-
- BYPASS <module> at <phase>
- - The require is used, but only for bindings that could be more directly
- obtained via another module. For example, 'racket' can be bypassed in favor
- of some subset of 'racket/base', 'racket/contract', etc.
-
- DROP <module> at <phase>
- - The require appears to be unused. Unless it must be kept for side
- effects or for bindings of a very unusual macro, it can be dropped
- entirely.
-
-Notes:
-
- BYPASS recommendations should often be disregarded, because the
- required module is expressly intended as an aggregation module and the
- only way to bypass it would be to require private modules
- directly. See TODO for plans to improve BYPASS recommendations.
+Notes
Ignore recommendations to DROP or BYPASS modules with side
- effects. Read the section below (How it works) and also see the docs
- for 'module-db' for whitelisting side-effectful modules.
+ effects. Read the section below (How it works) and also see
+ util/moduledb.rkt for whitelisting side-effectful modules.
The script is not intelligent about the language, which causes
certain spurious recommendations to appear frequently. For example,
@@ -66,7 +37,7 @@ Notes:
remove it except by rewriting the module in scheme/base or
racket/base.
-========
+==========
How it works
@@ -87,277 +58,201 @@ The limitations:
- misses identifiers recognized via 'free-identifier=?'
(But those should be recorded as 'disappeared-use anyway.)
+==========
+
+TODO
+
+Indicate when renaming is necessary.
+
+Handle for-label.
+
+Let user provide database of modules that should never be dropped, eg
+because they have side effects.
+ - wouldn't it be awesome if this db could be a datalog program?
+ - start simpler, though
+
+Ambitious mode could analyze module and recommend ways to split module
+into independent submodules.
|#
-;; ========
-
-(define add-disappeared-uses? (make-parameter #t))
-
-;; ========
-
-;; phase : (parameterof nat)
-(define phase (make-parameter 0))
-
-;; ========
-
-;; analyze : *Deriv* RefTable -> void
-;; *Deriv* = Deriv | LDeriv | BRule | ModRule | ... (anything from deriv.rkt)
-(define (analyze deriv refs)
- (define (recur . args)
- (let check ([arg args])
- (cond [(syntax? arg) (error 'whoops "arg = ~s" arg)]
- [(list? arg) (for-each check arg)]
- [else (void)]))
- (for ([arg (in-list args)])
- (if (list? arg)
- (apply recur arg)
- (analyze arg refs))))
- (define (recur/phase-up . args)
- (parameterize ((phase (add1 (phase))))
- (apply recur args)))
- (define (add! ids)
- (reftable-add-all! refs (phase) ids))
-
- ;; (printf "analyze ~.s\n" deriv)
-
- ;; Handle common base (ie, resolves) part of derivs, if applicable
- (match deriv
- [(base z1 z2 resolves ?1)
- (add! resolves)
- (when (and (syntax? z2) (add-disappeared-uses?))
- (let ([uses (syntax-property z2 'disappeared-use)])
- (add! (let loop ([x uses] [onto null])
- (cond [(identifier? x) (cons x onto)]
- [(pair? x) (loop (car x) (loop (cdr x) onto))]
- [else onto])))))]
- [_
- (void)])
- ;; Handle individual variants
- (match deriv
- [(lift-deriv z1 z2 first lift-stx second)
- (recur first second)]
- [(tagrule z1 z2 tagged-stx next)
- (recur next)]
- [(lift/let-deriv z1 z2 first lift-stx second)
- (recur first second)]
-
- [(mrule z1 z2 rs ?1 me1 locals me2 ?2 etx next)
- (recur locals next)]
- [(local-exn exn)
- (void)]
- [(local-expansion z1 z2 for-stx? me1 inner lifted me2 opaque)
- ((if for-stx? recur/phase-up recur) inner)]
- [(local-lift expr ids)
- (void)]
- [(local-lift-end decl)
- (void)]
- [(local-lift-require req expr mexpr)
- (void)]
- [(local-lift-provide prov)
- (void)]
- [(local-bind names ?1 renames bindrhs)
- (recur bindrhs)]
- [(local-value name ?1 resolves bound?)
- (when (and bound? resolves)
- (add! (cons name resolves)))]
- [(track-origin before after)
- (void)]
- [(local-remark contents)
- (void)]
-
- [(p:variable z1 z2 rs ?1)
- (void)]
- [(p:module z1 z2 rs ?1 locals tag rename check tag2 ?3 body shift)
- (recur locals check body)]
- [(p:#%module-begin z1 z2 rs ?1 me body ?2)
- (recur body)]
- [(p:define-syntaxes z1 z2 rs ?1 prep rhs locals)
- (recur prep locals)
- (recur/phase-up rhs)]
- [(p:define-values z1 z2 rs ?1 rhs)
- (recur rhs)]
- [(p:begin-for-syntax z1 z2 rs ?1 prep body)
- (recur prep)
- (recur/phase-up body)]
-
- [(p:#%expression z1 z2 rs ?1 inner untag)
- (recur inner)]
- [(p:if z1 z2 rs ?1 test then else)
- (recur test then else)]
- [(p:wcm z1 z2 rs ?1 key mark body)
- (recur key mark body)]
- [(p:set! _ _ _ _ id-resolves ?2 rhs)
- (add! id-resolves)
- (recur rhs)]
- [(p:set!-macro _ _ _ _ deriv)
- (recur deriv)]
- [(p:#%app _ _ _ _ lderiv)
- (recur lderiv)]
- [(p:begin _ _ _ _ lderiv)
- (recur lderiv)]
- [(p:begin0 _ _ _ _ first lderiv)
- (recur first lderiv)]
-
- [(p:lambda _ _ _ _ renames body)
- (recur body)]
- [(p:case-lambda _ _ _ _ renames+bodies)
- (recur renames+bodies)]
- [(p:let-values _ _ _ _ renames rhss body)
- (recur rhss body)]
- [(p:letrec-values _ _ _ _ renames rhss body)
- (recur rhss body)]
- [(p:letrec-syntaxes+values _ _ _ _ srenames prep sbindrhss vrenames vrhss body tag)
- (recur prep sbindrhss vrhss body)]
-
- [(p:provide _ _ _ _ inners ?2)
- (recur inners)]
-
- [(p:require _ _ _ _ locals)
- (recur locals)]
-
- [(p:#%stratified-body _ _ _ _ bderiv)
- (recur bderiv)]
-
- [(p:stop _ _ _ _) (void)]
- [(p:unknown _ _ _ _) (void)]
- [(p:#%top _ _ _ _)
- (void)]
- [(p:#%datum _ _ _ _) (void)]
- [(p:quote _ _ _ _) (void)]
- [(p:quote-syntax z1 z2 _ _)
- (when z2 (analyze/quote-syntax z2 refs))]
- [(p:#%variable-reference _ _ _ _)
- (void)]
-
- [(lderiv _ _ ?1 derivs)
- (recur derivs)]
-
- [(bderiv _ _ pass1 trans pass2)
- (recur pass1 pass2)]
-
- [(b:error ?1)
- (void)]
- [(b:expr _ head)
- (recur head)]
- [(b:splice _ head ?1 tail ?2)
- (recur head)]
- [(b:defvals _ head ?1 rename ?2)
- (recur head)]
- [(b:defstx _ head ?1 rename ?2 prep bindrhs)
- (recur head prep bindrhs)]
-
- [(bind-syntaxes rhs locals)
- (recur/phase-up rhs)
- (recur locals)]
-
- [(clc ?1 renames body)
- (recur body)]
-
- [(module-begin/phase pass1 pass2 pass3)
- (recur pass1 pass2 pass3)]
-
- [(mod:prim head rename prim)
- (recur head prim)]
- [(mod:splice head rename ?1 tail)
- (recur head)]
- [(mod:lift head renames tail)
- (recur head)]
- [(mod:lift-end tail)
- (void)]
- [(mod:cons head)
- (recur head)]
- [(mod:skip)
- (void)]
-
- ;; Shouldn't occur in module expansion.
- ;; (Unless code calls 'expand' at compile-time; weird, but possible.)
- [(ecte _ _ locals first second locals2)
- (recur locals first second locals2)]
- [(bfs:lift lderiv lifts)
- (recur lderiv)]
-
- [#f
- (void)]))
-
-;; analyze/quote-syntax : stx RefTable -> void
-;; Current approach: estimate that an identifier in a syntax template
-;; may be used at (sub1 (phase)) or (phase).
-;; FIXME: Allow for more conservative choices, too.
-;; FIXME: #%top, #%app, #%datum, etc?
-;; FIXME: Track tentative (in quote-syntax) references separately?
-(define (analyze/quote-syntax qs-stx refs)
- (let ([phases (list (phase) (sub1 (phase)))]
- [stx (syntax-case qs-stx ()
- [(_quote-syntax x) #'x])])
- (define (add! id)
- (for ([phase (in-list phases)])
- (reftable-add! refs phase id)))
- (let loop ([stx stx])
- (let ([d (if (syntax? stx) (syntax-e stx) stx)])
- (cond [(identifier? stx) (add! stx)]
- [(pair? d)
- (loop (car d))
- (loop (cdr d))]
- [(vector? d)
- (map loop (vector->list d))]
- [(prefab-struct-key d)
- (map loop (struct->list d))]
- [(box? d)
- (loop (unbox d))]
- [else
- (void)])))))
-
-;; ========
+;; ========================================
#|
A recommendation is one of
- (list 'keep module-path-index phase string/#f)
- (list 'bypass module-path-index phase)
+ (list 'keep module-path-index phase list)
+ (list 'bypass module-path-index phase list)
(list 'drop module-path-index phase)
|#
-;; check-requires : module-path -> (listof recommendation)
-(define (check-requires mod-path)
+;; analyze-requires : module-path -> (listof recommendation)
+(define (analyze-requires mod-path)
(let-values ([(compiled deriv) (get-module-code/trace mod-path)])
- (let ([refs (new-reftable)])
- (analyze deriv refs)
- (nom-use-alg refs compiled))))
+ (nom-use-alg (deriv->refs deriv) compiled)))
+
+;; ========================================
#|
A displayed-recommendation is one of
- (list 'keep string phase string/#f)
- (list 'bypass string phase)
- (list 'drop string phase)
-A displayed-recommendation is similar to a recommendation, but prints
-out the module-path-index for easier user consumption.
+ (list 'keep module-path phase)
+ (list 'bypass module-path phase (listof (list module-path phase)))
+ (list 'drop module-path phase)
+
+A displayed-recommendation is similar to a recommendation, but
+converts the module-path-indexes to module paths, omits the use-lists,
+and simplifies the replacements lists.
|#
;; show-requires: module-path -> (listof displayed-recommendation)
(define (show-requires mod-path)
- (map (match-lambda [(list-rest key mpi rest)
- (list* key (mpi->key mpi) rest)])
- (check-requires mod-path)))
+ (for/list ([entry (in-list (analyze-requires mod-path))])
+ (match entry
+ [(list 'keep mpi phase uses)
+ (list 'keep (mpi->key mpi) phase)]
+ [(list 'bypass mpi phase replacements)
+ (list 'bypass (mpi->key mpi) phase
+ (for/list ([r (in-list replacements)])
+ (match r
+ [(list rmpis rphase uses)
+ (list (mpi-list->module-path rmpis) rphase)])))]
+ [(list 'drop mpi phase)
+ (list 'drop (mpi->key mpi) phase)])))
+
+;; ========================================
+
+(define (check-requires mod
+ #:show-keep? [show-keep? #t]
+ #:show-bypass? [show-bypass? #t]
+ #:show-drop? [show-drop? #t]
+ #:show-uses? [show-uses? #f])
+
+ (define (show-bypass mpi replacements)
+ (for ([replacement (in-list replacements)])
+ (match replacement
+ [(list repl-mod-list phase uses)
+ (printf " TO ~s at ~a\n"
+ (mpi-list->module-path (append repl-mod-list (list mpi)))
+ phase)
+ (show-uses uses 4)])))
+
+ (define (show-uses uses indent)
+ (when show-uses?
+ (for ([use (in-list uses)])
+ (match use
+ [(list sym phase modes)
+ (printf "~a~a ~a ~a\n" (make-string indent #\space) sym phase modes)]))))
+
+ (let ([recs (analyze-requires mod)])
+ (for ([rec (in-list recs)])
+ (match rec
+ [(list 'keep mpi phase uses)
+ (when show-keep?
+ (printf "KEEP ~s at ~a\n"
+ (mpi->key mpi) phase)
+ (show-uses uses 2))]
+ [(list 'bypass mpi phase replacements)
+ (when show-bypass?
+ (printf "BYPASS ~s at ~a\n" (mpi->key mpi) phase)
+ (show-bypass mpi replacements))]
+ [(list 'drop mpi phase)
+ (when show-drop?
+ (printf "DROP ~s at ~a\n" (mpi->key mpi) phase))]))))
+
+(define (mpi-list->module-path mpi-list)
+ (let* ([mpi*
+ (let loop ([mpi #f] [mpi-list mpi-list])
+ (cond [mpi
+ (let-values ([(mod base) (module-path-index-split mpi)])
+ (cond [mod (module-path-index-join mod (loop base mpi-list))]
+ [else (loop #f mpi-list)]))]
+ [(pair? mpi-list)
+ (loop (car mpi-list) (cdr mpi-list))]
+ [else #f]))]
+ [collapsed
+ (let loop ([mpi mpi*])
+ (cond [mpi
+ (let-values ([(mod base) (module-path-index-split mpi)])
+ (cond [mod
+ (collapse-module-path mod (lambda () (loop base)))]
+ [else (build-path 'same)]))]
+ [else (build-path 'same)]))])
+ (match collapsed
+ [(list 'lib str)
+ (cond [(regexp-match? #rx"\\.rkt$" str)
+ (let* ([no-suffix (path->string (path-replace-suffix str ""))]
+ [no-main
+ (cond [(regexp-match #rx"^([^/]+)/main$" no-suffix)
+ => cadr]
+ [else no-suffix])])
+ (string->symbol no-main))]
+ [else collapsed])]
+ [(? path?)
+ (path->string (simplify-path collapsed #f))] ;; to get rid of "./" at beginning
+ [_ collapsed])))
+
+;; ========================================
+
+(require racket/cmdline)
+(provide main)
#|
-TODO
-====
-
-Elaborate on BYPASS recommendations by finding the necessary modules
-further up the require chain to require directly.
- - don't recommend private modules, though... heuristic
-
-Let user provide database of modules that should never be dropped, eg
-because they have side effects.
- - wouldn't it be awesome if this db could be a datalog program?
- - start simpler, though
+Example (from racket root directory):
-Verbose mode should show identifiers used by a module (for KEEP).
-For example, if only one used, good candidate to split out, if possible.
+ racket -lm macro-debugger/analysis/check-requires \
+ collects/syntax/*.rkt
-Ambitious mode could analyze module and recommend ways to split module
-into independent submodules.
-
-More options for quote-syntax handling & explain current heuristic better.
+ racket -lm macro-debugger/analysis/check-requires -- -bu \
+ collects/syntax/*.rkt
-Handle for-label.
|#
+
+(define (main . args)
+
+ ;; show-keep? : boolean
+ ;; Show KEEP messages in output.
+ (define show-keep? #f)
+
+ ;; show-bypass? : boolean
+ ;; Show BYPASS messages in output.
+ (define show-bypass? #f)
+
+ ;; show-uses? : boolean
+ (define show-uses? #f)
+
+ ;; ========
+
+ (define (go mod)
+ (printf "~s:\n" mod)
+ (with-handlers ([exn:fail?
+ (lambda (exn)
+ (printf "ERROR in ~s\n" mod)
+ ((error-display-handler) (exn-message exn) exn))])
+ (check-requires mod
+ #:show-keep? show-keep?
+ #:show-bypass? show-bypass?
+ #:show-uses? show-uses?))
+ (newline))
+
+ ;; Command-line args are interpreted as files if the file exists,
+ ;; module names otherwise.
+ (command-line
+ #:argv args
+ #:once-each
+ [("-k" "--show-keep")
+ "Show KEEP recommendations"
+ (set! show-keep? #t)]
+ [("-b" "--show-bypass")
+ "Show BYPASS recommendations"
+ (set! show-bypass? #t)]
+ [("-u" "--show-uses")
+ "Show uses for each module"
+ (set! show-uses? #t)]
+ #:args args
+ (for ([arg (in-list args)])
+ (cond [(file-exists? arg)
+ (go `(file ,arg))]
+ [else
+ (let* ([inport (open-input-string arg)]
+ [mod (read inport)])
+ (unless (eof-object? (peek-char inport))
+ (error "bad module name:" arg))
+ (go mod))]))))
diff --git a/collects/macro-debugger/analysis/private/get-references.rkt b/collects/macro-debugger/analysis/private/get-references.rkt
@@ -0,0 +1,222 @@
+#lang racket/base
+(require racket/match
+ macro-debugger/model/deriv
+ unstable/struct
+ "util.rkt")
+(provide deriv->refs)
+
+;; ========
+
+;; phase : (parameterof nat)
+(define phase (make-parameter 0))
+(define (add-disappeared-uses?) #t)
+
+;; ========
+
+;; deriv->refs : *Deriv* -> Refs
+;; *Deriv* = Deriv | LDeriv | BRule | ModRule | ... (anything from deriv.rkt)
+(define (deriv->refs deriv0)
+
+ ;; refs : (listof Refs), mutable
+ (define refs null)
+
+ (define (recur . args)
+ (let check ([arg args])
+ (cond [(syntax? arg) (error 'deriv->refs "internal error on ~s" arg)]
+ [(list? arg) (for-each check arg)]
+ [else (void)]))
+ (for ([arg (in-list args)])
+ (if (list? arg)
+ (apply recur arg)
+ (analyze-deriv arg))))
+ (define (recur/phase-up . args)
+ (parameterize ((phase (add1 (phase))))
+ (apply recur args)))
+ (define (add-refs! rs)
+ (set! refs (append rs refs)))
+ (define (add! ids [mode 'reference])
+ (let ([p (phase)])
+ (add-refs! (for/list ([id (in-list ids)])
+ (ref p id mode (identifier-binding id p))))))
+ (define (add/binding! id binding mode)
+ (add-refs! (list (ref (phase) id mode binding))))
+
+ ;; analyze/quote-syntax : stx -> void
+ ;; Current approach: estimate that an identifier in a syntax template
+ ;; may be used at (sub1 (phase)) or (phase).
+ ;; FIXME: Allow for more conservative choices, too.
+ ;; FIXME: #%top, #%app, #%datum, etc?
+ ;; FIXME: Track tentative (in quote-syntax) references separately?
+ (define (analyze/quote-syntax qs-stx)
+ (let ([phases (for/list ([offset '(0 1 -1 2 -2)]) (+ (phase) offset))]
+ [stx (syntax-case qs-stx ()
+ [(_quote-syntax x) #'x])])
+ (define (add*! id)
+ (add-refs! (for/list ([p (in-list phases)])
+ (ref p id 'quote-syntax (identifier-binding id p)))))
+ (let loop ([stx stx])
+ (let ([d (if (syntax? stx) (syntax-e stx) stx)])
+ (cond [(identifier? stx) (add*! stx)]
+ [(pair? d)
+ (loop (car d))
+ (loop (cdr d))]
+ [(vector? d)
+ (map loop (vector->list d))]
+ [(prefab-struct-key d)
+ (map loop (struct->list d))]
+ [(box? d)
+ (loop (unbox d))]
+ [else
+ (void)])))))
+
+ (define (analyze-deriv deriv)
+ ;; Handle common base (ie, resolves) part of derivs, if applicable
+ (match deriv
+ [(base z1 z2 resolves ?1)
+ (add! resolves)
+ (when (and (syntax? z2) (add-disappeared-uses?))
+ (let ([uses (syntax-property z2 'disappeared-use)])
+ (add! (let loop ([x uses] [onto null])
+ (cond [(identifier? x) (cons x onto)]
+ [(pair? x) (loop (car x) (loop (cdr x) onto))]
+ [else onto]))
+ 'disappeared-use)))]
+ [_
+ (void)])
+ ;; Handle individual variants
+ (match deriv
+ [(lift-deriv z1 z2 first lift-stx second)
+ (recur first second)]
+ [(tagrule z1 z2 tagged-stx next)
+ (recur next)]
+ [(lift/let-deriv z1 z2 first lift-stx second)
+ (recur first second)]
+ [(mrule z1 z2 rs ?1 me1 locals me2 ?2 etx next)
+ (recur locals next)]
+ [(local-exn exn)
+ (void)]
+ [(local-expansion z1 z2 for-stx? me1 inner lifted me2 opaque)
+ ((if for-stx? recur/phase-up recur) inner)]
+ [(local-lift expr ids)
+ (void)]
+ [(local-lift-end decl)
+ (void)]
+ [(local-lift-require req expr mexpr)
+ (void)]
+ [(local-lift-provide prov)
+ (void)]
+ [(local-bind names ?1 renames bindrhs)
+ (recur bindrhs)]
+ [(local-value name ?1 resolves bound? binding)
+ #|
+ Beware: in one common case, local-member-name, the binding of name is
+ mutated (because used as binder in class body), so original binding is lost!
+ Use binding instead.
+ |#
+ (when (and bound? (pair? binding))
+ (add/binding! name binding 'syntax-local-value))]
+ [(track-origin before after)
+ (void)]
+ [(local-remark contents)
+ (void)]
+ [(p:variable z1 z2 rs ?1)
+ (void)]
+ [(p:module z1 z2 rs ?1 locals tag rename check tag2 ?3 body shift)
+ (recur locals check body)]
+ [(p:#%module-begin z1 z2 rs ?1 me body ?2)
+ (recur body)]
+ [(p:define-syntaxes z1 z2 rs ?1 prep rhs locals)
+ (recur prep locals)
+ (recur/phase-up rhs)]
+ [(p:define-values z1 z2 rs ?1 rhs)
+ (recur rhs)]
+ [(p:begin-for-syntax z1 z2 rs ?1 prep body)
+ (recur prep)
+ (recur/phase-up body)]
+ [(p:#%expression z1 z2 rs ?1 inner untag)
+ (recur inner)]
+ [(p:if z1 z2 rs ?1 test then else)
+ (recur test then else)]
+ [(p:wcm z1 z2 rs ?1 key mark body)
+ (recur key mark body)]
+ [(p:set! _ _ _ _ id-resolves ?2 rhs)
+ (add! id-resolves)
+ (recur rhs)]
+ [(p:set!-macro _ _ _ _ deriv)
+ (recur deriv)]
+ [(p:#%app _ _ _ _ lderiv)
+ (recur lderiv)]
+ [(p:begin _ _ _ _ lderiv)
+ (recur lderiv)]
+ [(p:begin0 _ _ _ _ first lderiv)
+ (recur first lderiv)]
+ [(p:lambda _ _ _ _ renames body)
+ (recur body)]
+ [(p:case-lambda _ _ _ _ renames+bodies)
+ (recur renames+bodies)]
+ [(p:let-values _ _ _ _ renames rhss body)
+ (recur rhss body)]
+ [(p:letrec-values _ _ _ _ renames rhss body)
+ (recur rhss body)]
+ [(p:letrec-syntaxes+values _ _ _ _ srenames prep sbindrhss vrenames vrhss body tag)
+ (recur prep sbindrhss vrhss body)]
+ [(p:provide _ _ _ _ inners ?2)
+ (recur inners)]
+ [(p:require _ _ _ _ locals)
+ (recur locals)]
+ [(p:#%stratified-body _ _ _ _ bderiv)
+ (recur bderiv)]
+ [(p:stop _ _ _ _) (void)]
+ [(p:unknown _ _ _ _) (void)]
+ [(p:#%top _ _ _ _)
+ (void)]
+ [(p:#%datum _ _ _ _) (void)]
+ [(p:quote _ _ _ _) (void)]
+ [(p:quote-syntax z1 z2 _ _)
+ (when z2 (analyze/quote-syntax z2))]
+ [(p:#%variable-reference _ _ _ _)
+ (void)]
+ [(lderiv _ _ ?1 derivs)
+ (recur derivs)]
+ [(bderiv _ _ pass1 trans pass2)
+ (recur pass1 pass2)]
+ [(b:error ?1)
+ (void)]
+ [(b:expr _ head)
+ (recur head)]
+ [(b:splice _ head ?1 tail ?2)
+ (recur head)]
+ [(b:defvals _ head ?1 rename ?2)
+ (recur head)]
+ [(b:defstx _ head ?1 rename ?2 prep bindrhs)
+ (recur head prep bindrhs)]
+ [(bind-syntaxes rhs locals)
+ (recur/phase-up rhs)
+ (recur locals)]
+ [(clc ?1 renames body)
+ (recur body)]
+ [(module-begin/phase pass1 pass2 pass3)
+ (recur pass1 pass2 pass3)]
+ [(mod:prim head rename prim)
+ (recur head prim)]
+ [(mod:splice head rename ?1 tail)
+ (recur head)]
+ [(mod:lift head renames tail)
+ (recur head)]
+ [(mod:lift-end tail)
+ (void)]
+ [(mod:cons head)
+ (recur head)]
+ [(mod:skip)
+ (void)]
+ ;; Shouldn't occur in module expansion.
+ ;; (Unless code calls 'expand' at compile-time; weird, but possible.)
+ [(ecte _ _ locals first second locals2)
+ (recur locals first second locals2)]
+ [(bfs:lift lderiv lifts)
+ (recur lderiv)]
+ [#f
+ (void)]))
+
+ (analyze-deriv deriv0)
+ refs)
diff --git a/collects/macro-debugger/analysis/private/moduledb.rkt b/collects/macro-debugger/analysis/private/moduledb.rkt
@@ -1,6 +1,17 @@
#lang racket/base
-(require syntax/modresolve)
-(provide module-db)
+(require syntax/modresolve
+ setup/path-to-relative
+ "util.rkt"
+ racket/match)
+(provide allow-bypass?
+ allow-drop?
+ bypass-ok-mpi?)
+
+(define (allow-bypass? mod)
+ (not (memq (lookup mod) '(no-bypass no-drop))))
+
+(define (allow-drop? mod)
+ (not (memq (lookup mod) '(no-drop))))
;; A ModuleDB = hash[path/symbol => (U 'no-drop 'no-bypass)]
;; 'no-drop = must not be dropped or bypassed because of, eg, side effects
@@ -8,20 +19,74 @@
;; but if the module is unused, can drop it
;; (FIXME: replace with component module calculation and checking)
-(define (make-module-db mod+config-list)
- (for/hash ([mod+config (in-list mod+config-list)])
- (values (resolve-module-path (car mod+config) #f) (cadr mod+config))))
+(define (make-module-db no-drop-list no-bypass-list)
+ (let ([mod+config-list
+ (append (for/list ([no-drop (in-list no-drop-list)])
+ (list no-drop 'no-drop))
+ (for/list ([no-bypass (in-list no-bypass-list)])
+ (list no-bypass 'no-bypass)))])
+ (for/hash ([mod+config (in-list mod+config-list)])
+ (values (resolve-module-path (car mod+config) #f) (cadr mod+config)))))
+
+(define (lookup mod)
+ (let ([name (resolved-module-path-name (module-path-index-resolve mod))])
+ (cond [(symbol? name) 'no-bypass]
+ [(hash-ref module-db name #f)
+ => values]
+ [else
+ (let ([str (path->relative-string/library name)])
+ (for/or ([rx (in-list no-bypass-rxs)])
+ (and (regexp-match? rx str) 'no-bypass)))])))
;; module-db : ModuleDB
(define module-db
(make-module-db
- '([racket/base no-bypass]
- [racket/contract/base no-bypass]
- [racket/gui no-bypass]
- [racket/match no-bypass]
- ['#%builtin no-drop]
-
- [typed-racket/private/base-env no-drop]
- [typed-racket/private/base-special-env no-drop]
- [typed-racket/private/base-env-numeric no-drop]
- [typed-racket/private/base-env-indexing no-drop])))
+ ;; no-drop
+ '('#%builtin
+ errortrace
+ scheme/mzscheme ;; introduced by mzscheme's #%module-begin; can't drop
+ racket/contract/private/basic-opters
+ racket/contract/private/opters
+ typed-racket/private/base-env
+ typed-racket/private/base-special-env
+ typed-racket/private/base-env-numeric
+ typed-racket/private/base-env-indexing)
+ ;; no-bypass
+ '(mred
+ mzscheme
+ openssl
+ racket/gui/base
+ racket/match
+ scheme/gui/base
+ slideshow/base
+ string-constants
+ wxme)))
+
+(define no-bypass-rxs
+ '(#rx"^<collects>/srfi/[0-9]+\\.rkt$"))
+
+;; ========================================
+
+;; bypass-ok-mpi? : mpi -> boolean
+;; Okay to recommend mod as a replacement in bypass? (heuristic)
+(define (bypass-ok-mpi? mpi)
+ (define (no-private? s) (not (regexp-match? #rx"private" s)))
+ (define legacy-rxs (list #rx"^mzlib" #rx"^texpict"))
+ (define (ok? s)
+ (and (no-private? s)
+ (for/and ([rx (in-list legacy-rxs)])
+ (not (regexp-match? rx s)))))
+ (let-values ([(modpath relto) (module-path-index-split mpi)])
+ (match modpath
+ [(list 'quote name)
+ (not (regexp-match? #rx"^#%" (symbol->string name)))]
+ [(? string?)
+ (ok? modpath)]
+ [(list 'lib parts ...)
+ (andmap ok? parts)]
+ [(? symbol?)
+ (ok? (symbol->string modpath))]
+ [(list 'file part)
+ (ok? part)]
+ [(list 'planet part ...)
+ #t])))
diff --git a/collects/macro-debugger/analysis/private/nom-use-alg.rkt b/collects/macro-debugger/analysis/private/nom-use-alg.rkt
@@ -1,52 +1,62 @@
#lang racket/base
-(require racket/dict
- racket/match
- "reftable.rkt"
+(require racket/match
"moduledb.rkt"
"util.rkt")
(provide nom-use-alg)
+;; nom-use-alg : Refs compiled -> (listof recommendation)
+(define (nom-use-alg refs0 compiled)
+ (let ([refs (append (provides->refs compiled) refs0)])
+ (let-values ([(NOM-USES DEF-USES) (calculate-used-approximations refs)])
+ (report NOM-USES DEF-USES (get-requires compiled)))))
+
+;; ========
+
;; sMPI = S-expr form of mpi (see mpi->key)
;; Using MPIs doesn't work. I conjecture that the final module shift means that
;; all during-expansion MPIs are different from all compiled-expr MPIs.
-;; A UsedTable = hash[(list int sMPI) => list]
+;; A UsedTable = hash[(list int sMPI) => Refs]
-;; calculate-used-approximations : RefTable -> (values UsedTable UsedTable)
+;; calculate-used-approximations : Refs -> (values UsedTable UsedTable)
(define (calculate-used-approximations refs)
(let ([NOM-USES (make-hash)]
[DEF-USES (make-hash)])
- (for* ([(use-phase id-table) (in-hash refs)]
- [id (in-dict-keys id-table)])
- ;; Only look at identifiers written in module being examined.
- ;; (Otherwise, nom-mod & nom-phase aren't enough info (???)
- (when (here-mpi? (syntax-source-module id)) ;; REDUNDANT
- (let ([b (identifier-binding id use-phase)])
- (match b
- [(list def-mod def-sym nom-mod nom-sym
- def-phase nom-imp-phase nom-exp-phase)
+ (for ([ref (in-list refs)])
+ (when (relevant? ref)
+ (match (ref-binding ref)
+ [(list def-mod def-sym nom-mod nom-sym
+ def-phase nom-imp-phase nom-exp-phase)
+ (define use-phase (ref-phase ref))
+ (when def-mod
;; use-phase = def-phase + required-phase
;; thus required-phase = use-phase - def-phase
(let* ([required-phase (- use-phase def-phase)]
[key (list required-phase (mpi->key def-mod))])
(hash-set! DEF-USES key
- (cons id (hash-ref DEF-USES key null))))
- ;; use-phase = nom-imp-phase + nom-exp-phase ?????
- ;; We just care about nom-imp-phase, since importing into *here*
- #|
- ;; FIXME: This check goes wrong on defined-for-syntax ids
- (unless (equal? use-phase (+ nom-imp-phase nom-exp-phase))
- (error 'calculate
- "internal error: phases wrong in ~s @ ~s, binding = ~s"
- id use-phase b))
- |#
- (let ([key (list nom-imp-phase (mpi->key nom-mod))])
- (hash-set! NOM-USES key
- (cons id (hash-ref NOM-USES key null))))]
- [_
- (void)]))))
+ (cons ref (hash-ref DEF-USES key null)))))
+ ;; We just care about nom-imp-phase, since importing into *here*
+ (let* ([key (list nom-imp-phase (mpi->key nom-mod))])
+ (hash-set! NOM-USES key
+ (cons ref (hash-ref NOM-USES key null))))]
+ [_ (void)])))
(values NOM-USES DEF-USES)))
+;; relevant? : Ref -> boolean
+;; Only want identifiers actually originating from module being analyzed,
+;; not identifiers from other modules inserted by macro expansion.
+;; - Actually, want identifiers with lexical context of module, which includes
+;; some identifiers not originating from module (eg, inserted by unit-from-context).
+;; - Also, if ref represents a re-export, no identifier but still relevant.
+;; So, use syntax-source-module conservatively: only to disqualify refs.
+(define (relevant? ref)
+ (let* ([phase (ref-phase ref)]
+ [id (ref-id ref)]
+ [binding (ref-binding ref)]
+ [srcmod (and id (syntax-source-module id))])
+ (cond [(and srcmod (not (here-mpi? srcmod))) #f]
+ [else #t])))
+
;; ========
;; get-requires : compiled-module-expr -> (listof (list int MPI))
@@ -57,53 +67,173 @@
[mod (cdr phase+mods)])
(list (car phase+mods) mod))))
-;; add-provides! : compiled-module-expr UsedTable UsedTable -> void
-(define (add-provides! compiled NOM-USES DEF-USES)
- (define (add! mpi phase)
- (let ([key (list phase (mpi->key mpi))])
- (hash-set! NOM-USES key (cons 'export (hash-ref NOM-USES key null)))
- (hash-set! DEF-USES key (cons 'export (hash-ref DEF-USES key null)))))
+;; provides->refs : compiled-module-expr -> Refs
+(define (provides->refs compiled)
(let-values ([(vprov sprov) (module-compiled-exports compiled)])
- (for* ([phase+exps (in-list (append vprov sprov))]
+ (for*/list ([phase+exps (in-list (append vprov sprov))]
+ #:when (car phase+exps) ;; Skip for-label provides
+ [name+srcs (in-list (cdr phase+exps))]
+ [src (in-list (cadr name+srcs))])
+ (let ([phase (car phase+exps)]
+ [name (car name+srcs)])
+
+ (define (->ref nom-mod exp-sym phase-shift sym orig-phase)
+ ;; We don't have the DEF information, so put #f
+ (let ([b (list #f #f nom-mod sym #f phase-shift orig-phase)])
+ (ref phase #f 'provide b)))
+
+ (match src
+ [(? module-path-index?)
+ (->ref src name 0 name phase)]
+ [(list imp-mod imp-phase-shift imp-name imp-orig-phase)
+ (->ref imp-mod name imp-phase-shift imp-name imp-orig-phase)])))))
+
+;; ========
+
+;; A RefineTable is hash[(cons mpi phase) => (or RefineTable Imps)]
+;; preserve nesting because inner MPIs need to be resolved wrt outer MPIs
+
+;; try-bypass : mpi phase Refs -> RefineTable or #f
+(define (try-bypass mod reqphase refs)
+ ;; refs are all nominally from mod
+ (let* ([imps (map ref->imp refs)])
+ (refine-imps/one-require mod reqphase imps)))
+
+;; ref->imp : ref -> imp
+;; Assumes id gotten from nom-mod, etc.
+(define (ref->imp r)
+ (match (ref-binding r)
+ [(list _dm _ds nom-mod nom-sym _dp imp-shift nom-orig-phase)
+ (imp nom-mod imp-shift nom-sym nom-orig-phase r)]))
+
+;; refine-imps/one-require : mod phase Imps -> RefineTable or #f
+;; where all imps come from mod at phase
+;; the result table contains new (refined) imps
+(define (refine-imps/one-require mod reqphase imps)
+ (let ([use-table (make-hash)] ;; RefineTable
+ [bytable (mod->bypass-table mod)])
+ (and (for/and ([i (in-list imps)])
+ (match i
+ [(imp _m _rp sym exp-phase r)
+ (let* ([bykey (cons sym exp-phase)]
+ [src (hash-ref bytable bykey #f)])
+ (match src
+ [(renm srcmod phase-shift srcsym srcphase)
+ (let ([use-key (cons srcmod (+ reqphase phase-shift))]
+ [imp* (imp srcmod (+ reqphase phase-shift) srcsym srcphase r)])
+ (hash-set! use-table use-key (cons imp* (hash-ref use-table use-key null))))
+ #t]
+ [else #f]))]))
+ (refine-imps* use-table))))
+
+(define (refine-imps* partitions)
+ (for/hash ([(mod+reqphase imps) (in-hash partitions)])
+ (values mod+reqphase
+ (let ([mod (car mod+reqphase)]
+ [reqphase (cdr mod+reqphase)])
+ (or (and (allow-bypass? mod)
+ (refine-imps/one-require mod reqphase imps))
+ imps)))))
+
+;; ========
+
+;; A BypassTable is hash[(cons sym phase) => Renm
+;; Contains only approved modules (no private, etc).
+
+;; A Renm is (renm srcmod reqphase srcsym)
+(struct renm (srcmod phase-shift srcsym srcphase))
+
+;; mod->bypass-table : mpi -> BypassTable
+;; FIXME: cache tables
+(define (mod->bypass-table mod)
+ (define table (make-hash))
+ (let ([prov (get-module-all-exports mod)])
+ (for* ([phase+exps (in-list prov)]
#:when (car phase+exps) ;; Skip for-label provides
[name+srcs (in-list (cdr phase+exps))]
[src (in-list (cadr name+srcs))])
- (let ([name (car name+srcs)])
+ (let ([phase (car phase+exps)]
+ [name (car name+srcs)])
+
+ (define (add-source! src-mod phase-offset src-sym)
+ (when (bypass-ok-mpi? src-mod)
+ (let ([key (cons name phase)]
+ ;; src-phase + phase-shift = phase
+ [src-phase (- phase phase-offset)])
+ (hash-ref! table key (renm src-mod phase-offset src-sym src-phase)))))
+
(match src
[(? module-path-index?)
- (add! src 0)]
- [(list imp-mod imp-phase-shift imp-name imp-phase-???)
- (add! imp-mod imp-phase-shift)])))))
+ (add-source! src 0 name)]
+ [(list imp-mod imp-phase-shift imp-name imp-orig-phase)
+ (add-source! imp-mod imp-phase-shift imp-name)]))))
+ table)
;; ========
;; report : UseTable UseTable (listof (list int mpi)) -> (listof recommendation)
(define (report NOM-USES DEF-USES phase+mod-list)
(for/list ([phase+mod (in-list phase+mod-list)])
- (let* ([key (list (car phase+mod) (mpi->key (cadr phase+mod)))]
- [db-config
- (hash-ref module-db
- (resolved-module-path-name
- (module-path-index-resolve (cadr phase+mod)))
- #f)]
- [nom-ids (hash-ref NOM-USES key null)]
- [def-ids (hash-ref DEF-USES key null)]
- [phase (car phase+mod)]
+ (let* ([phase (car phase+mod)]
[mod (cadr phase+mod)]
- [name (format "~s at ~s" (mpi->key mod) phase)])
- (cond [(and (pair? nom-ids) (pair? def-ids))
- (list 'keep mod phase (if (ormap identifier? nom-ids) #f "for exports"))]
- [(pair? nom-ids)
- (if (memq db-config '(no-bypass no-drop))
- (list 'keep mod phase "db says no-bypass")
- (list 'bypass mod phase))]
+ [key (list phase (mpi->key mod))]
+ [nom-refs (hash-ref NOM-USES key null)]
+ [def-refs (hash-ref DEF-USES key null)])
+ (cond [(and (pair? nom-refs) (pair? def-refs))
+ ;; We use refs defined in the module (and we got them from the module)
+ (list 'keep mod phase (process-refs nom-refs))]
+ [(pair? nom-refs)
+ ;; We use refs gotten from the module (but defined elsewhere)
+ (let ([bypass
+ (and (allow-bypass? mod)
+ (try-bypass mod phase nom-refs))])
+ (if bypass
+ (list 'bypass mod phase (process-bypass bypass))
+ (list 'keep mod phase (process-refs nom-refs))))]
[else
- (if (memq db-config '(no-drop))
- (list 'keep mod phase "db says no-drop")
- (list 'drop mod phase))]))))
-
-;; nom-use-alg : RefTable compiled -> (listof recommendation)
-(define (nom-use-alg refs compiled)
- (let-values ([(NOM-USES DEF-USES) (calculate-used-approximations refs)])
- (add-provides! compiled NOM-USES DEF-USES)
- (report NOM-USES DEF-USES (get-requires compiled))))
+ ;; We don't have any refs gotten from the module
+ ;; (although we may---possibly---have refs defined in it, but gotten elsewhere)
+ (if (allow-drop? mod)
+ (list 'drop mod phase)
+ (list 'keep mod phase null))]))))
+
+;; process-refs : Refs phase -> (listof (list symbol int (listof mode)))
+(define (process-refs refs)
+ ;; table : hash[(cons phase symbol) => (listof mode)]
+ (define table (make-hash))
+ (for ([r (in-list refs)])
+ (match r
+ [(ref phase _id mode
+ (list def-mod def-sym nom-mod nom-sym def-phase imp-phase-shift nom-phase))
+ (let* ([key (cons nom-sym phase)] ;; was nom-phase
+ [modes (hash-ref table key null)])
+ (unless (memq mode modes)
+ (hash-set! table key (cons mode modes))))]))
+ (let* ([unsorted
+ (for/list ([(key modes) (in-hash table)])
+ (cons key (sort modes < #:key mode->nat)))]
+ [sorted
+ (sort unsorted
+ (lambda (A B)
+ (let ([strA (symbol->string (car A))]
+ [strB (symbol->string (car B))])
+ (or (string<? strA strB)
+ (and (string=? strA strB)
+ (< (cdr A) (cdr B))))))
+ #:key car)])
+ (for/list ([elem (in-list sorted)])
+ (list (caar elem) (cdar elem) (cdr elem)))))
+
+;; process-bypass : RefineTable
+;; -> (listof (list (listof mpi) int (listof (list symbol int (listof mode)))))
+(define (process-bypass bypass [mpi-ctx null])
+ (apply append
+ (for/list ([(mod+reqphase inner) (in-hash bypass)])
+ (let ([mod (car mod+reqphase)]
+ [reqphase (cdr mod+reqphase)])
+ (cond [(hash? inner)
+ (process-bypass inner (cons mod mpi-ctx))]
+ [else
+ (list (list (cons mod mpi-ctx)
+ reqphase
+ (process-refs (map imp-ref inner))))])))))
diff --git a/collects/macro-debugger/analysis/private/util.rkt b/collects/macro-debugger/analysis/private/util.rkt
@@ -1,8 +1,36 @@
#lang racket/base
-(require syntax/modcode
+(require racket/path
+ syntax/modcode
syntax/modresolve
macro-debugger/model/trace)
+;; --------
+
+(provide (struct-out ref)
+ mode->nat
+ (struct-out imp))
+
+;; A Ref is (ref phase id/#f identifier-binding Mode)
+;; the def-mod, def-sym, etc parts of identifier-binding may be #f (eg, provide)
+(struct ref (phase id mode binding))
+
+;; A Mode is one of '(reference syntax-local-value quote-syntax disappeared-use provide)
+(define (mode->nat mode)
+ (case mode
+ ((reference) 0)
+ ((provide) 1)
+ ((syntax-local-value) 2)
+ ((quote-syntax) 3)
+ ((disappeared-use) 4)
+ (else (error 'mode->nat "bad mode: ~s" mode))))
+
+;; An Imp is (imp mpi phase symbol phase Ref)
+(struct imp (mod reqphase sym exp-phase ref))
+;; interpretation: reference ref could be satisfied by
+;; (require (only (for-meta reqphase (just-meta exp-phase mod)) sym))
+
+;; --------
+
(provide get-module-code/trace
here-mpi?
mpi->key
@@ -44,23 +72,34 @@
(provide get-module-imports
get-module-exports
get-module-var-exports
- get-module-stx-exports)
+ get-module-stx-exports
+ get-module-all-exports)
(struct modinfo (imports var-exports stx-exports) #:prefab)
;; cache : hash[path/symbol => modinfo]
(define cache (make-hash))
+;; get-module-info/no-cache : path -> modinfo
(define (get-module-info/no-cache resolved)
(let ([compiled (get-module-code resolved)])
(let-values ([(imports) (module-compiled-imports compiled)]
[(var-exports stx-exports) (module-compiled-exports compiled)])
+ (parameterize ((current-directory (path-only resolved)))
+ (force-all-mpis (cons var-exports stx-exports)))
(modinfo imports var-exports stx-exports))))
-(define (get-module-info path)
- (let ([resolved (resolve-module-path path #f)])
+;; get-module-info : (or module-path module-path-index) -> modinfo
+(define (get-module-info mod)
+ (let ([resolved (resolve mod)])
(hash-ref! cache resolved (lambda () (get-module-info/no-cache resolved)))))
+;; resolve : (or module-path module-path-index) -> path
+(define (resolve mod)
+ (cond [(module-path-index? mod)
+ (resolved-module-path-name (module-path-index-resolve mod))]
+ [else (resolve-module-path mod #f)]))
+
(define (get-module-imports path)
(modinfo-imports (get-module-info path)))
(define (get-module-var-exports path)
@@ -70,4 +109,16 @@
(define (get-module-exports path)
(let ([info (get-module-info path)])
(values (modinfo-var-exports info) (modinfo-stx-exports info))))
+(define (get-module-all-exports path)
+ (append (get-module-var-exports path)
+ (get-module-stx-exports path)))
+(define (force-all-mpis x)
+ (let loop ([x x])
+ (cond [(pair? x)
+ (loop (car x))
+ (loop (cdr x))]
+ [(module-path-index? x)
+ ;; uses current-directory, hopefully
+ (module-path-index-resolve x)]
+ [else (void)])))
diff --git a/collects/macro-debugger/macro-debugger.scrbl b/collects/macro-debugger/macro-debugger.scrbl
@@ -1,6 +1,7 @@
#lang scribble/doc
@(require scribble/manual
scribble/struct
+ scribble/decode
scribble/eval
(for-label scheme/base
macro-debugger/expand
@@ -8,14 +9,22 @@
macro-debugger/stepper
macro-debugger/stepper-text
macro-debugger/syntax-browser
+ macro-debugger/analysis/check-requires
(rename-in scheme (free-identifier=? module-identifier=?))))
@(define the-eval
(let ([the-eval (make-base-eval)])
(the-eval '(require macro-debugger/expand
- macro-debugger/stepper-text))
+ macro-debugger/stepper-text
+ macro-debugger/analysis/check-requires))
the-eval))
+@(define (defoutput proto . text)
+ (nested #:style "leftindent"
+ (tabular #:style 'boxed (list (list proto)))
+ "\n" "\n"
+ (splice text)))
+
@title{Macro Debugger: Inspecting Macro Expansion}
@author["Ryan Culpepper"]
@@ -315,65 +324,152 @@ structure of a program is only determined after macro expansion is
complete.
-@section{Checking requires}
+@section{Finding Useless @racket[require]s}
@section-index["useless-requires"]
@defmodule[macro-debugger/analysis/check-requires]
-@defproc[(check-requires [module-name module-path?])
- (listof (list/c 'keep module-path-index? number? (or/c string? #f))
- (list/c 'bypass module-path-index? number?)
- (list/c 'drop module-path-index? number?))]{
+The @racketmodname[macro-debugger/analysis/check-requires] can be run
+as a command-line script. For example (from racket root directory):
-Estimate a module's useless requires.
-The procedure returns one element per (non-label) require in the
-following format:
-@itemlist[
-@item{
- @racket['keep] @racket[module] at @racket[phase] @racket[(optional-comment)]
- @itemlist[
- @item{The require must be kept because bindings defined within it are used.}
- @item{The optional comment indicates if the require must be kept
- @itemlist[
- @item{only because its bindings are re-exported}
- @item{only because the whitelist DB says so}
- ]}]}
-@item{
- @racket['bypass] @racket[module] at @racket[phase]
- @itemlist[
- @item{The require is used, but only for bindings that could be more
- directly obtained via another module. For example, @racket[racket]
- can be bypassed in favor of some subset of @racket[racket/base],
- @racket[racket/contract], etc.}]}
-@item{
- @racket['drop] @racket[module] at @racket[phase]
+@verbatim{
+racket -lm macro-debugger/analysis/check-requires \
+ collects/syntax/*.rkt
+
+racket -lm macro-debugger/analysis/check-requires -- -kbu \
+ collects/syntax/*.rkt
+}
+
+See @racket[check-requires] for a description of the output format,
+known limitations in the script's recommendations, etc.
+
+@defproc[(check-requires [module-to-analyze module-path?]
+ [#:show-keep? show-keep? boolean? #f]
+ [#:show-bypass? show-bypass? boolean? #f]
+ [#:show-drop? show-drop? boolean? #t]
+ [#:show-uses? show-uses? boolean? #f])
+ void?]{
+
+Analyzes @racket[module-to-analyze], detecting useless requires. Each
+module imported by @racket[module-to-analyze] is classified as one of
+KEEP, BYPASS, or DROP. For each required module, one or more lines is
+printed with the module's classification and supporting
+information. Output may be suppressed based on classification via
+@racket[show-keep?], @racket[show-bypass?], and @racket[show-drop?];
+by default, only DROP recommendations are printed.
+
+Modules required @racket[for-label] are not analyzed.
+
+@defoutput[@tt{KEEP @racket[_req-module] at @racket[_req-phase]}]{
+
+ The require of module @racket[_req-module] at phase
+ @racket[_req-phase] must be kept because bindings defined within it
+ are used.
+
+ If @racket[show-uses?] is true, the dependencies of
+ @racket[module-to-analyze] on @racket[_req-module] are enumerated,
+ one per line, in the following format:
+
+ @defoutput[@tt{@racket[_exp-name] @racket[_use-phase] (@racket[_mode ...])}]{
+
+ Indicates an export named @racket[_exp-name] is used at phase
+ @racket[_use-phase] (not necessarily the phase it was provided at,
+ if @racket[_req-phase] is non-zero).
+
+ The @racket[_modes] indicate what kind(s) of dependencies were
+ observed: used as a @tt{reference}, appeared in a syntax template
+ (@tt{quote-syntax}), etc.
+ }
+}
+
+@defoutput[@tt{BYPASS @racket[_req-module] at @racket[_req-phase]}]{
+
+ The require is used, but only for bindings that could be more
+ directly obtained via one or more other modules. For example, a use
+ of @racketmodname[racket] might be bypassed in favor of
+ @racketmodname[racket/base], @racketmodname[racket/match], and
+ @racketmodname[racket/contract], etc.
+
+ A list of replacement requires is given, one per line, in the
+ following format:
+
+ @defoutput[@tt{TO @racket[_repl-module] at @racket[_repl-phase]}]{
+
+ Add a require of @racket[_repl-module] at phase
+ @racket[_repl-phase]. If @racket[show-uses?] is true, then
+ following each @tt{TO} line is an enumeration of the dependencies
+ that would be satisfied by @racket[_repl-module] in the same
+ format as described under @tt{KEEP} below.
+
+ Note: @racket[_repl-module] may provide an export under a
+ different name than @racket[_req-module]; you must use
+ @racket[rename-in] or adjust the references for the replacement to
+ work.
+ }
+
+ Bypass recommendations are restricted by the following rules:
@itemlist[
- @item{The require appears to be unused. Unless it must be kept for side
- effects or for bindings of a very unusual macro, it can be dropped
- entirely.}]}]
-Examples:
-@racketblock[
- (check-requires 'typed-scheme)
- (check-requires 'unstable/markparam)
- (check-requires 'macro-debugger/syntax-browser/widget)
-]
+ @item{@racket[_repl-module] must not involve crossing a new
+ @tt{private} directory from @racket[_req-module]}
+
+ @item{@racket[_repl-module] is never a built-in (``@litchar{#%}'')
+ module}
+
+ @item{@racket[_req-module] must not be in the ``no-bypass''
+ whitelist}
+ ]
+}
+
+@defoutput[@tt{DROP @racket[_req-module] at @racket[_req-phase]}]{
+
+ The require appears to be unused, and it can probably be dropped
+ entirely.
}
-A scripting interface to @racket[macro-debugger/analysis/check-requires]
-usable from the command-line is available at
-@racket[macro-debugger/analysis/check-requires-script.rkt].
+Due to limitations in its implementation strategy,
+@racket[check-requires] occasionally suggests dropping or bypassing a
+module that should not be dropped or bypassed. The following are
+typical reasons for such bad suggestions:
-Example (from racket root directory):
+@itemlist[
-@commandline{racket -l macro-debugger/analysis/check-requires-script \
- collects/syntax/*.rkt}
+@item{The module's invocation has side-effects. For example, the
+ module body may update a shared table or perform I/O, or it might
+ transitively require a module that does. (Consider adding the module
+ to the whitelist.)}
+
+@item{Bindings from the module are used in identifier comparisons by a
+ macro, such as appearing in the macro's ``literals list.'' In such
+ cases, a macro should annotate its expansion with the
+ @racket['disappeared-use] property containing the identifier(s)
+ compared with its literals; however, most casually-written macros do
+ not do so. On the other hand, macros and their literal identifiers
+ are typically provided by the same module, so this problem is
+ somewhat uncommon.}
+]
+@examples[#:eval the-eval
+(check-requires 'framework)
+(check-requires 'syntax/stx #:show-uses? #t)
+]
+}
@defproc[(show-requires [module-name module-path?])
- (listof (list/c 'keep module-path? number? (or/c string? #f))
+ (listof (list/c 'keep module-path? number?)
(list/c 'bypass module-path? number?)
(list/c 'drop module-path? number?))]{
-Similar to @racket[check-requires], but outputs module paths instead of
-module path indexes, for more readability.
+
+Like @racket[check-requires], but returns the analysis as a list
+instead of printing it. The procedure
+returns one element per (non-label) require in the following format:
+@itemlist[
+@item{@racket[(list 'keep _req-module _req-phase)]}
+@item{@racket[(list 'bypass _req-module _req-phase _replacements)]}
+@item{@racket[(list 'drop _req-module _req-phase)]}
+]
+
+@examples[#:eval the-eval
+(show-requires 'framework)
+]
}
diff --git a/collects/macro-debugger/model/deriv-c.rkt b/collects/macro-debugger/model/deriv-c.rkt
@@ -41,7 +41,9 @@
(define-struct local-lift-require (req expr mexpr) #:transparent)
(define-struct local-lift-provide (prov) #:transparent)
(define-struct local-bind (names ?1 renames bindrhs) #:transparent)
-(define-struct local-value (name ?1 resolves bound?) #:transparent)
+(define-struct local-value (name ?1 resolves bound? binding) #:transparent)
+ ;; binding is saved (identifier-binding name) at time of lookup, since it may change
+ ;; if name is rebound in definition context
(define-struct track-origin (before after) #:transparent)
(define-struct local-remark (contents) #:transparent)
;; contents : (listof (U string syntax))
diff --git a/collects/macro-debugger/model/deriv-parser.rkt b/collects/macro-debugger/model/deriv-parser.rkt
@@ -43,7 +43,7 @@
enter-check exit-check
local-post exit-local exit-local/expr
local-bind enter-bind exit-bind
- local-value-result
+ local-value-result local-value-binding
phase-up module-body
renames-lambda
renames-case-lambda
@@ -209,8 +209,8 @@
(make local-bind $1 #f $2 $3)]
[(track-origin)
(make track-origin (car $1) (cdr $1))]
- [(local-value ! Resolves local-value-result)
- (make local-value $1 $2 $3 $4)]
+ [(local-value ! Resolves local-value-result local-value-binding)
+ (make local-value $1 $2 $3 $4 $5)]
[(local-remark)
(make local-remark $1)]
[(local-artificial-step)
diff --git a/collects/macro-debugger/model/deriv-tokens.rkt b/collects/macro-debugger/model/deriv-tokens.rkt
@@ -3,6 +3,9 @@
"deriv.rkt")
(provide (all-defined-out))
+;; NOTE: trace.rkt also depends on some token numbers
+;; eg for enter-macro, local-value, etc
+
(define-tokens basic-empty-tokens
(start ; .
next ; .
@@ -69,6 +72,7 @@
track-origin ; (cons stx stx)
local-value ; identifier
local-value-result ; boolean
+ local-value-binding ; result of identifier-binding; added by trace.rkt, not expander
))
(define-tokens renames-tokens
@@ -107,6 +111,7 @@
(#f top-non-begin ,token-top-non-begin)
(#f local-remark ,token-local-remark)
(#f local-artificial-step ,token-local-artificial-step)
+ (#f local-value-binding ,token-local-value-binding)
;; Standard signals
(0 visit ,token-visit)
diff --git a/collects/macro-debugger/model/reductions.rkt b/collects/macro-debugger/model/reductions.rkt
@@ -488,8 +488,9 @@
[#:pattern ?form]
[#:rename ?form after 'track-origin]]
|#]
- [(struct local-value (name ?1 resolves bound?))
+ [(struct local-value (name ?1 resolves bound? binding))
[R [! ?1]
+ ;; FIXME: notify if binding != current (identifier-binding name)???
;; [#:learn (list name)]
;; Add remark step?
]]
diff --git a/collects/macro-debugger/model/trace.rkt b/collects/macro-debugger/model/trace.rkt
@@ -70,26 +70,32 @@
(set! pos (add1 pos))
t))))
-(define trace-macro-limit (make-parameter #f))
+(define trace-macro-limit (make-parameter +inf.0))
(define trace-limit-handler (make-parameter #f))
;; expand/events : stx (stx -> stx) -> stx/exn (list-of event)
(define (expand/events sexpr expander)
(define events null)
- (define counter 0)
(define (add! x y)
(set! events (cons (cons (signal->symbol x) y) events)))
(define add!/check
(let ([limit (trace-macro-limit)]
- [handler (trace-limit-handler)])
- (if (and limit handler (exact-positive-integer? limit))
- (lambda (x y)
- (add! x y)
- (when (eqv? x 8) ;; enter-macro
- (set! counter (add1 counter))
- (when (= counter limit)
- (set! limit (handler counter)))))
- add!)))
+ [handler (trace-limit-handler)]
+ [counter 0]
+ [last-local-value-id #f])
+ (lambda (x y)
+ (add! x y)
+ (case x
+ ((8) ;; enter-macro
+ (set! counter (add1 counter))
+ (when (>= counter limit)
+ (set! limit (handler counter))))
+ ((153) ;; local-value
+ (set! last-local-value-id y))
+ ((154) ;; local-value-result
+ (add! 'local-value-binding
+ (and y (identifier-binding last-local-value-id)))
+ (set! last-local-value-id #f))))))
(parameterize ((current-expand-observe add!/check))
(let ([result
(with-handlers ([(lambda (exn) #t)
