suzanne.soy/macro-debugger
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

improved check-requires

Browse Source 
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
This commit is contained in:
Ryan Culpepper 2011-09-24 21:10:25 -06:00
parent 597bf1ffcb
commit 4b8f073229
11 changed files with 928 additions and 455 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

511
collects/macro-debugger/analysis/check-requires.rkt
View File

@ -1,60 +1,31 @@
#lang racket/base #lang racket/base
(require racket/contract (require racket/contract/base
racket/cmdline
racket/match racket/match
syntax/modcollapse
unstable/struct unstable/struct
macro-debugger/model/deriv "private/get-references.rkt"
"private/reftable.rkt"
"private/nom-use-alg.rkt" "private/nom-use-alg.rkt"
"private/util.rkt") "private/util.rkt")
(provide/contract (provide/contract
[check-requires (-> module-path? list?)] [check-requires
[show-requires (-> module-path? list?)] (->* (module-path?)
[add-disappeared-uses? (parameter/c boolean?)] (#: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)]) [mpi->key (-> module-path-index? any/c)])
#| #|
==========
The purpose of this script is to estimate a module's useless requires. Notes
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.
Ignore recommendations to DROP or BYPASS modules with side Ignore recommendations to DROP or BYPASS modules with side
effects. Read the section below (How it works) and also see the docs effects. Read the section below (How it works) and also see
for 'module-db' for whitelisting side-effectful modules. util/moduledb.rkt for whitelisting side-effectful modules.
The script is not intelligent about the language, which causes The script is not intelligent about the language, which causes
certain spurious recommendations to appear frequently. For example, certain spurious recommendations to appear frequently. For example,
@ -66,7 +37,7 @@ Notes:
remove it except by rewriting the module in scheme/base or remove it except by rewriting the module in scheme/base or
racket/base. racket/base.
======== ==========
How it works How it works
@ -87,277 +58,201 @@ The limitations:
- misses identifiers recognized via 'free-identifier=?' - misses identifiers recognized via 'free-identifier=?'
(But those should be recorded as 'disappeared-use anyway.) (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 TODO
====
Elaborate on BYPASS recommendations by finding the necessary modules Indicate when renaming is necessary.
further up the require chain to require directly.
- don't recommend private modules, though... heuristic Handle for-label.
Let user provide database of modules that should never be dropped, eg Let user provide database of modules that should never be dropped, eg
because they have side effects. because they have side effects.
- wouldn't it be awesome if this db could be a datalog program? - wouldn't it be awesome if this db could be a datalog program?
- start simpler, though - 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 Ambitious mode could analyze module and recommend ways to split module
into independent submodules. 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))]))))

222
collects/macro-debugger/analysis/private/get-references.rkt Normal file
View File

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

93
collects/macro-debugger/analysis/private/moduledb.rkt
View File

@ -1,6 +1,17 @@
#lang racket/base #lang racket/base
(require syntax/modresolve) (require syntax/modresolve
(provide module-db) 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)] ;; A ModuleDB = hash[path/symbol => (U 'no-drop 'no-bypass)]
;; 'no-drop = must not be dropped or bypassed because of, eg, side effects ;; '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 ;; but if the module is unused, can drop it
;; (FIXME: replace with component module calculation and checking) ;; (FIXME: replace with component module calculation and checking)
(define (make-module-db mod+config-list) (define (make-module-db no-drop-list no-bypass-list)
(for/hash ([mod+config (in-list mod+config-list)]) (let ([mod+config-list
(values (resolve-module-path (car mod+config) #f) (cadr mod+config)))) (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 ;; module-db : ModuleDB
(define module-db (define module-db
(make-module-db (make-module-db
'([racket/base no-bypass] ;; no-drop
[racket/contract/base no-bypass] '('#%builtin
[racket/gui no-bypass] errortrace
[racket/match no-bypass] scheme/mzscheme ;; introduced by mzscheme's #%module-begin; can't drop
['#%builtin no-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] (define no-bypass-rxs
[typed-racket/private/base-special-env no-drop] '(#rx"^<collects>/srfi/[0-9]+\\.rkt$"))
[typed-racket/private/base-env-numeric no-drop]
[typed-racket/private/base-env-indexing no-drop]))) ;; ========================================
;; 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])))

258
collects/macro-debugger/analysis/private/nom-use-alg.rkt
View File

@ -1,52 +1,62 @@
#lang racket/base #lang racket/base
(require racket/dict (require racket/match
racket/match
"reftable.rkt"
"moduledb.rkt" "moduledb.rkt"
"util.rkt") "util.rkt")
(provide nom-use-alg) (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) ;; sMPI = S-expr form of mpi (see mpi->key)
;; Using MPIs doesn't work. I conjecture that the final module shift means that ;; 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. ;; 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) (define (calculate-used-approximations refs)
(let ([NOM-USES (make-hash)] (let ([NOM-USES (make-hash)]
[DEF-USES (make-hash)]) [DEF-USES (make-hash)])
(for* ([(use-phase id-table) (in-hash refs)] (for ([ref (in-list refs)])
[id (in-dict-keys id-table)]) (when (relevant? ref)
;; Only look at identifiers written in module being examined. (match (ref-binding ref)
;; (Otherwise, nom-mod & nom-phase aren't enough info (???) [(list def-mod def-sym nom-mod nom-sym
(when (here-mpi? (syntax-source-module id)) ;; REDUNDANT def-phase nom-imp-phase nom-exp-phase)
(let ([b (identifier-binding id use-phase)]) (define use-phase (ref-phase ref))
(match b (when def-mod
[(list def-mod def-sym nom-mod nom-sym
def-phase nom-imp-phase nom-exp-phase)
;; use-phase = def-phase + required-phase ;; use-phase = def-phase + required-phase
;; thus required-phase = use-phase - def-phase ;; thus required-phase = use-phase - def-phase
(let* ([required-phase (- use-phase def-phase)] (let* ([required-phase (- use-phase def-phase)]
[key (list required-phase (mpi->key def-mod))]) [key (list required-phase (mpi->key def-mod))])
(hash-set! DEF-USES key (hash-set! DEF-USES key
(cons id (hash-ref DEF-USES key null)))) (cons ref (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*
;; 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
;; FIXME: This check goes wrong on defined-for-syntax ids (cons ref (hash-ref NOM-USES key null))))]
(unless (equal? use-phase (+ nom-imp-phase nom-exp-phase)) [_ (void)])))
(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)]))))
(values NOM-USES DEF-USES))) (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)) ;; get-requires : compiled-module-expr -> (listof (list int MPI))
@ -57,53 +67,173 @@
[mod (cdr phase+mods)]) [mod (cdr phase+mods)])
(list (car phase+mods) mod)))) (list (car phase+mods) mod))))
;; add-provides! : compiled-module-expr UsedTable UsedTable -> void ;; provides->refs : compiled-module-expr -> Refs
(define (add-provides! compiled NOM-USES DEF-USES) (define (provides->refs compiled)
(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)))))
(let-values ([(vprov sprov) (module-compiled-exports 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 #:when (car phase+exps) ;; Skip for-label provides
[name+srcs (in-list (cdr phase+exps))] [name+srcs (in-list (cdr phase+exps))]
[src (in-list (cadr name+srcs))]) [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 (match src
[(? module-path-index?) [(? module-path-index?)
(add! src 0)] (add-source! src 0 name)]
[(list imp-mod imp-phase-shift imp-name imp-phase-???) [(list imp-mod imp-phase-shift imp-name imp-orig-phase)
(add! imp-mod imp-phase-shift)]))))) (add-source! imp-mod imp-phase-shift imp-name)]))))
table)
;; ======== ;; ========
;; report : UseTable UseTable (listof (list int mpi)) -> (listof recommendation) ;; report : UseTable UseTable (listof (list int mpi)) -> (listof recommendation)
(define (report NOM-USES DEF-USES phase+mod-list) (define (report NOM-USES DEF-USES phase+mod-list)
(for/list ([phase+mod (in-list phase+mod-list)]) (for/list ([phase+mod (in-list phase+mod-list)])
(let* ([key (list (car phase+mod) (mpi->key (cadr phase+mod)))] (let* ([phase (car 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)]
[mod (cadr phase+mod)] [mod (cadr phase+mod)]
[name (format "~s at ~s" (mpi->key mod) phase)]) [key (list phase (mpi->key mod))]
(cond [(and (pair? nom-ids) (pair? def-ids)) [nom-refs (hash-ref NOM-USES key null)]
(list 'keep mod phase (if (ormap identifier? nom-ids) #f "for exports"))] [def-refs (hash-ref DEF-USES key null)])
[(pair? nom-ids) (cond [(and (pair? nom-refs) (pair? def-refs))
(if (memq db-config '(no-bypass no-drop)) ;; We use refs defined in the module (and we got them from the module)
(list 'keep mod phase "db says no-bypass") (list 'keep mod phase (process-refs nom-refs))]
(list 'bypass mod phase))] [(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 [else
(if (memq db-config '(no-drop)) ;; We don't have any refs gotten from the module
(list 'keep mod phase "db says no-drop") ;; (although we may---possibly---have refs defined in it, but gotten elsewhere)
(list 'drop mod phase))])))) (if (allow-drop? mod)
(list 'drop mod phase)
(list 'keep mod phase null))]))))
;; nom-use-alg : RefTable compiled -> (listof recommendation) ;; process-refs : Refs phase -> (listof (list symbol int (listof mode)))
(define (nom-use-alg refs compiled) (define (process-refs refs)
(let-values ([(NOM-USES DEF-USES) (calculate-used-approximations refs)]) ;; table : hash[(cons phase symbol) => (listof mode)]
(add-provides! compiled NOM-USES DEF-USES) (define table (make-hash))
(report NOM-USES DEF-USES (get-requires compiled)))) (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))))])))))

59
collects/macro-debugger/analysis/private/util.rkt
View File

@ -1,8 +1,36 @@
#lang racket/base #lang racket/base
(require syntax/modcode (require racket/path
syntax/modcode
syntax/modresolve syntax/modresolve
macro-debugger/model/trace) 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 (provide get-module-code/trace
here-mpi? here-mpi?
mpi->key mpi->key
@ -44,23 +72,34 @@
(provide get-module-imports (provide get-module-imports
get-module-exports get-module-exports
get-module-var-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) (struct modinfo (imports var-exports stx-exports) #:prefab)
;; cache : hash[path/symbol => modinfo] ;; cache : hash[path/symbol => modinfo]
(define cache (make-hash)) (define cache (make-hash))
;; get-module-info/no-cache : path -> modinfo
(define (get-module-info/no-cache resolved) (define (get-module-info/no-cache resolved)
(let ([compiled (get-module-code resolved)]) (let ([compiled (get-module-code resolved)])
(let-values ([(imports) (module-compiled-imports compiled)] (let-values ([(imports) (module-compiled-imports compiled)]
[(var-exports stx-exports) (module-compiled-exports 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)))) (modinfo imports var-exports stx-exports))))
(define (get-module-info path) ;; get-module-info : (or module-path module-path-index) -> modinfo
(let ([resolved (resolve-module-path path #f)]) (define (get-module-info mod)
(let ([resolved (resolve mod)])
(hash-ref! cache resolved (lambda () (get-module-info/no-cache resolved))))) (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) (define (get-module-imports path)
(modinfo-imports (get-module-info path))) (modinfo-imports (get-module-info path)))
(define (get-module-var-exports path) (define (get-module-var-exports path)
@ -70,4 +109,16 @@
(define (get-module-exports path) (define (get-module-exports path)
(let ([info (get-module-info path)]) (let ([info (get-module-info path)])
(values (modinfo-var-exports info) (modinfo-stx-exports info)))) (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)])))

194
collects/macro-debugger/macro-debugger.scrbl
View File

@ -1,6 +1,7 @@
#lang scribble/doc #lang scribble/doc
@(require scribble/manual @(require scribble/manual
scribble/struct scribble/struct
scribble/decode
scribble/eval scribble/eval
(for-label scheme/base (for-label scheme/base
macro-debugger/expand macro-debugger/expand
@ -8,14 +9,22 @@
macro-debugger/stepper macro-debugger/stepper
macro-debugger/stepper-text macro-debugger/stepper-text
macro-debugger/syntax-browser macro-debugger/syntax-browser
macro-debugger/analysis/check-requires
(rename-in scheme (free-identifier=? module-identifier=?)))) (rename-in scheme (free-identifier=? module-identifier=?))))
@(define the-eval @(define the-eval
(let ([the-eval (make-base-eval)]) (let ([the-eval (make-base-eval)])
(the-eval '(require macro-debugger/expand (the-eval '(require macro-debugger/expand
macro-debugger/stepper-text)) macro-debugger/stepper-text
macro-debugger/analysis/check-requires))
the-eval)) 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} @title{Macro Debugger: Inspecting Macro Expansion}
@author["Ryan Culpepper"] @author["Ryan Culpepper"]
@ -315,65 +324,152 @@ structure of a program is only determined after macro expansion is
complete. complete.
@section{Checking requires} @section{Finding Useless @racket[require]s}
@section-index["useless-requires"] @section-index["useless-requires"]
@defmodule[macro-debugger/analysis/check-requires] @defmodule[macro-debugger/analysis/check-requires]
@defproc[(check-requires [module-name module-path?]) The @racketmodname[macro-debugger/analysis/check-requires] can be run
(listof (list/c 'keep module-path-index? number? (or/c string? #f)) as a command-line script. For example (from racket root directory):
(list/c 'bypass module-path-index? number?)
(list/c 'drop module-path-index? number?))]{ @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[ @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: @item{The module's invocation has side-effects. For example, the
@racketblock[ module body may update a shared table or perform I/O, or it might
(check-requires 'typed-scheme) transitively require a module that does. (Consider adding the module
(check-requires 'unstable/markparam) to the whitelist.)}
(check-requires 'macro-debugger/syntax-browser/widget)
@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?]) @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 'bypass module-path? number?)
(list/c 'drop 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)
]
} }

4
collects/macro-debugger/model/deriv-c.rkt
View File

@ -41,7 +41,9 @@
(define-struct local-lift-require (req expr mexpr) #:transparent) (define-struct local-lift-require (req expr mexpr) #:transparent)
(define-struct local-lift-provide (prov) #:transparent) (define-struct local-lift-provide (prov) #:transparent)
(define-struct local-bind (names ?1 renames bindrhs) #: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 track-origin (before after) #:transparent)
(define-struct local-remark (contents) #:transparent) (define-struct local-remark (contents) #:transparent)
;; contents : (listof (U string syntax)) ;; contents : (listof (U string syntax))

6
collects/macro-debugger/model/deriv-parser.rkt
View File

@ -43,7 +43,7 @@
enter-check exit-check enter-check exit-check
local-post exit-local exit-local/expr local-post exit-local exit-local/expr
local-bind enter-bind exit-bind local-bind enter-bind exit-bind
local-value-result local-value-result local-value-binding
phase-up module-body phase-up module-body
renames-lambda renames-lambda
renames-case-lambda renames-case-lambda
@ -209,8 +209,8 @@
(make local-bind $1 #f $2 $3)] (make local-bind $1 #f $2 $3)]
[(track-origin) [(track-origin)
(make track-origin (car $1) (cdr $1))] (make track-origin (car $1) (cdr $1))]
[(local-value ! Resolves local-value-result) [(local-value ! Resolves local-value-result local-value-binding)
(make local-value $1 $2 $3 $4)] (make local-value $1 $2 $3 $4 $5)]
[(local-remark) [(local-remark)
(make local-remark $1)] (make local-remark $1)]
[(local-artificial-step) [(local-artificial-step)

5
collects/macro-debugger/model/deriv-tokens.rkt
View File

@ -3,6 +3,9 @@
"deriv.rkt") "deriv.rkt")
(provide (all-defined-out)) (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 (define-tokens basic-empty-tokens
(start ; . (start ; .
next ; . next ; .
@ -69,6 +72,7 @@
track-origin ; (cons stx stx) track-origin ; (cons stx stx)
local-value ; identifier local-value ; identifier
local-value-result ; boolean local-value-result ; boolean
local-value-binding ; result of identifier-binding; added by trace.rkt, not expander
)) ))
(define-tokens renames-tokens (define-tokens renames-tokens
@ -107,6 +111,7 @@
(#f top-non-begin ,token-top-non-begin) (#f top-non-begin ,token-top-non-begin)
(#f local-remark ,token-local-remark) (#f local-remark ,token-local-remark)
(#f local-artificial-step ,token-local-artificial-step) (#f local-artificial-step ,token-local-artificial-step)
(#f local-value-binding ,token-local-value-binding)
;; Standard signals ;; Standard signals
(0 visit ,token-visit) (0 visit ,token-visit)

3
collects/macro-debugger/model/reductions.rkt
View File

@ -488,8 +488,9 @@
[#:pattern ?form] [#:pattern ?form]
[#:rename ?form after 'track-origin]] [#:rename ?form after 'track-origin]]
|#] |#]
[(struct local-value (name ?1 resolves bound?)) [(struct local-value (name ?1 resolves bound? binding))
[R [! ?1] [R [! ?1]
;; FIXME: notify if binding != current (identifier-binding name)???
;; [#:learn (list name)] ;; [#:learn (list name)]
;; Add remark step? ;; Add remark step?
]] ]]

28
collects/macro-debugger/model/trace.rkt
View File

@ -70,26 +70,32 @@
(set! pos (add1 pos)) (set! pos (add1 pos))
t)))) t))))
(define trace-macro-limit (make-parameter #f)) (define trace-macro-limit (make-parameter +inf.0))
(define trace-limit-handler (make-parameter #f)) (define trace-limit-handler (make-parameter #f))
;; expand/events : stx (stx -> stx) -> stx/exn (list-of event) ;; expand/events : stx (stx -> stx) -> stx/exn (list-of event)
(define (expand/events sexpr expander) (define (expand/events sexpr expander)
(define events null) (define events null)
(define counter 0)
(define (add! x y) (define (add! x y)
(set! events (cons (cons (signal->symbol x) y) events))) (set! events (cons (cons (signal->symbol x) y) events)))
(define add!/check (define add!/check
(let ([limit (trace-macro-limit)] (let ([limit (trace-macro-limit)]
[handler (trace-limit-handler)]) [handler (trace-limit-handler)]
(if (and limit handler (exact-positive-integer? limit)) [counter 0]
(lambda (x y) [last-local-value-id #f])
(add! x y) (lambda (x y)
(when (eqv? x 8) ;; enter-macro (add! x y)
(set! counter (add1 counter)) (case x
(when (= counter limit) ((8) ;; enter-macro
(set! limit (handler counter))))) (set! counter (add1 counter))
add!))) (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)) (parameterize ((current-expand-observe add!/check))
(let ([result (let ([result
(with-handlers ([(lambda (exn) #t) (with-handlers ([(lambda (exn) #t)