From 4b8f07322986b7c96c73ebf2170bc8ded67b0611 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Sat, 24 Sep 2011 21:10:25 -0600 Subject: [PATCH] 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 --- .../analysis/check-requires.rkt | 511 +++++++----------- .../analysis/private/get-references.rkt | 222 ++++++++ .../analysis/private/moduledb.rkt | 93 +++- .../analysis/private/nom-use-alg.rkt | 258 ++++++--- .../macro-debugger/analysis/private/util.rkt | 59 +- collects/macro-debugger/macro-debugger.scrbl | 194 +++++-- collects/macro-debugger/model/deriv-c.rkt | 4 +- .../macro-debugger/model/deriv-parser.rkt | 6 +- .../macro-debugger/model/deriv-tokens.rkt | 5 + collects/macro-debugger/model/reductions.rkt | 3 +- collects/macro-debugger/model/trace.rkt | 28 +- 11 files changed, 928 insertions(+), 455 deletions(-) create mode 100644 collects/macro-debugger/analysis/private/get-references.rkt diff --git a/collects/macro-debugger/analysis/check-requires.rkt b/collects/macro-debugger/analysis/check-requires.rkt index 054fe35..8041ab1 100644 --- 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 ) - -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 at - - 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 at - - 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 at - - 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.) -|# +========== -;; ======== - -(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 'drop module-path-index phase) -|# - -;; check-requires : module-path -> (listof recommendation) -(define (check-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)))) - -#| -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. -|# - -;; 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))) - -#| 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 +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 -Verbose mode should show identifiers used by a module (for KEEP). -For example, if only one used, good candidate to split out, if possible. - Ambitious mode could analyze module and recommend ways to split module into independent submodules. - -More options for quote-syntax handling & explain current heuristic better. - -Handle for-label. |# + +;; ======================================== + +#| +A recommendation is one of + (list 'keep module-path-index phase list) + (list 'bypass module-path-index phase list) + (list 'drop module-path-index phase) +|# + +;; analyze-requires : module-path -> (listof recommendation) +(define (analyze-requires mod-path) + (let-values ([(compiled deriv) (get-module-code/trace mod-path)]) + (nom-use-alg (deriv->refs deriv) compiled))) + +;; ======================================== + +#| +A displayed-recommendation is one of + (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) + (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) + +#| +Example (from racket root directory): + + racket -lm macro-debugger/analysis/check-requires \ + collects/syntax/*.rkt + + racket -lm macro-debugger/analysis/check-requires -- -bu \ + collects/syntax/*.rkt + +|# + +(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 new file mode 100644 index 0000000..4f95a3c --- /dev/null +++ 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 index a15d84a..0e4807e 100644 --- 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] + ;; 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))) - [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]))) +(define no-bypass-rxs + '(#rx"^/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 index f7abaed..bfd061c 100644 --- 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))])))) + ;; 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))])))) -;; 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)))) +;; 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 (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 index a452bf3..10f8c48 100644 --- 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 index 8e83452..0a3c1e3 100644 --- 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): + +@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{@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. +} + +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: -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] - @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{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) ] } -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]. - -Example (from racket root directory): - -@commandline{racket -l macro-debugger/analysis/check-requires-script \ - collects/syntax/*.rkt} - - @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 index 57b191d..4da99e5 100644 --- 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 index 5a040bb..48c37e7 100644 --- 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 index 9a67823..9591336 100644 --- 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 index f44f984..a7ae869 100644 --- 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 index db358c3..a2e98a8 100644 --- 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)