commit 5624941e25e0ec5ca6890367c323885d0744ef43
parent 33418e9969d8ab13994759d0957dfc73386c1fa3
Author: Ryan Culpepper <ryanc@racket-lang.org>
Date: Fri, 10 Sep 2010 18:04:25 -0600
reorganized check-requires script
original commit: 1cfccb970474e35b99116ec515fd3f2cd510a63a
Diffstat:
5 files changed, 272 insertions(+), 182 deletions(-)
diff --git a/collects/macro-debugger/analysis/check-requires.rkt b/collects/macro-debugger/analysis/check-requires.rkt
@@ -7,7 +7,9 @@
syntax/stx
syntax/id-table
macro-debugger/model/deriv
- "util.rkt")
+ "private/reftable.rkt"
+ "private/nom-use-alg.rkt"
+ "private/util.rkt")
(provide/contract
[check-requires (-> module-path? list?)]
[add-disappeared-uses? (parameter/c boolean?)]
@@ -96,45 +98,6 @@ The limitations:
;; ========
-;; A RefTable = hash[Phase => free-id-table[bool]]
-;; Phase = nat
-
-#|
-
-For the calculations at the end, we only want to consider identifiers
-from the expanded module (ie, syntax-source-module = here.)
-
-That means that instead of a free-id-table, we really want a dict/set
-that distinguishes between identifiers imported different ways. eg,
-hash keyed on (nom-name, nom-mod). The reason is that a not-from-here
-identifier can block/clobber a from-here identifier if they happen to
-refer to the same binding. That messes up the analysis.
-
-Temporary solution: only add from-here identifiers to the reftable.
-
-|#
-
-;; new-reftable : -> RefTable
-(define (new-reftable)
- (make-hash))
-
-;; reftable-get-phase : RefTable Phase -> free-id-table[bool]
-(define (reftable-get-phase refs phase)
- (hash-ref! refs phase (lambda () (make-free-id-table #:phase phase))))
-
-;; reftable-add-all! : RefTable Phase (listof identifier) -> void
-(define (reftable-add-all! refs phase ids)
- (let ([id-table (reftable-get-phase refs phase)])
- (for ([id (in-list ids)]
- #:when (here-mpi? (syntax-source-module id)))
- (free-id-table-set! id-table id #t))))
-
-;; reftable-add! : RefTable Phase identifier -> void
-(define (reftable-add! refs phase id)
- (reftable-add-all! refs phase (list id)))
-
-;; ========
-
;; phase : (parameterof nat)
(define phase (make-parameter 0))
@@ -338,103 +301,6 @@ Temporary solution: only add from-here identifiers to the reftable.
;; ========
-;; 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]
-
-;; calculate-used-approximations : RefTable -> (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)
- ;; 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)]))))
- (values NOM-USES DEF-USES)))
-
-;; ========
-
-;; get-requires : compiled-module-expr -> (listof (list int MPI))
-(define (get-requires compiled)
- (let ([phase+mods-list (module-compiled-imports compiled)])
- (for*/list ([phase+mods (in-list phase+mods-list)]
- #:when (car phase+mods) ;; Skip for-label requires
- [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)))))
- (let-values ([(vprov sprov) (module-compiled-exports compiled)])
- (for* ([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 ([name (car name+srcs)])
- (match src
- [(? module-path-index?)
- (add! src 0)]
- [(list imp-mod imp-phase-shift imp-name imp-phase-???)
- (add! imp-mod imp-phase-shift)])))))
-
-;; ========
-
-;; A ModuleDB = hash[path/symbol => (U 'no-drop 'no-bypass)]
-;; 'no-drop = must not be dropped or bypassed because of, eg, side effects
-;; 'no-bypass = don't bypass in favor of private component modules
-;; 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))))
-
-;; module-db : ModuleDB
-(define module-db
- (make-module-db
- '([racket/base no-bypass]
- [racket/contract/base no-bypass]
- [racket/gui no-bypass]
- [racket/match no-bypass]
- ['#%builtin no-drop]
-
- [typed-scheme/private/base-env no-drop]
- [typed-scheme/private/base-special-env no-drop]
- [typed-scheme/private/base-env-numeric no-drop]
- [typed-scheme/private/base-env-indexing no-drop])))
-
-;; ========
-
#|
A recommendation is one of
(list 'keep module-path-index phase string/#f)
@@ -447,51 +313,7 @@ A recommendation is one of
(let-values ([(compiled deriv) (get-module-code/trace mod-path)])
(let ([refs (new-reftable)])
(analyze deriv refs)
- (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))))))
-
-;; 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)]
- [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))]
- [else
- (if (memq db-config '(no-drop))
- (list 'keep mod phase "db says no-drop")
- (list 'drop mod phase))]))))
-
-(define (mpi->key x)
- (let ([l (mpi->list x)])
- (if (and (pair? l) (null? (cdr l)))
- (car l)
- l)))
-
-(define (mpi->list x)
- (cond [(module-path-index? x)
- (let-values ([(rel base) (module-path-index-split x)])
- (if rel
- (cons rel (mpi->list base))
- null))]
- [(eq? x #f)
- null]
- [else
- (list x)]))
+ (nom-use-alg refs compiled))))
#|
TODO
diff --git a/collects/macro-debugger/analysis/private/moduledb.rkt b/collects/macro-debugger/analysis/private/moduledb.rkt
@@ -0,0 +1,27 @@
+#lang racket/base
+(require syntax/modresolve)
+(provide module-db)
+
+;; A ModuleDB = hash[path/symbol => (U 'no-drop 'no-bypass)]
+;; 'no-drop = must not be dropped or bypassed because of, eg, side effects
+;; 'no-bypass = don't bypass in favor of private component modules
+;; 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))))
+
+;; module-db : ModuleDB
+(define module-db
+ (make-module-db
+ '([racket/base no-bypass]
+ [racket/contract/base no-bypass]
+ [racket/gui no-bypass]
+ [racket/match no-bypass]
+ ['#%builtin no-drop]
+
+ [typed-scheme/private/base-env no-drop]
+ [typed-scheme/private/base-special-env no-drop]
+ [typed-scheme/private/base-env-numeric no-drop]
+ [typed-scheme/private/base-env-indexing no-drop])))
diff --git a/collects/macro-debugger/analysis/private/nom-use-alg.rkt b/collects/macro-debugger/analysis/private/nom-use-alg.rkt
@@ -0,0 +1,109 @@
+#lang racket/base
+(require racket/dict
+ racket/match
+ "reftable.rkt"
+ "moduledb.rkt"
+ "util.rkt")
+(provide nom-use-alg)
+
+;; 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]
+
+;; calculate-used-approximations : RefTable -> (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)
+ ;; 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)]))))
+ (values NOM-USES DEF-USES)))
+
+;; ========
+
+;; get-requires : compiled-module-expr -> (listof (list int MPI))
+(define (get-requires compiled)
+ (let ([phase+mods-list (module-compiled-imports compiled)])
+ (for*/list ([phase+mods (in-list phase+mods-list)]
+ #:when (car phase+mods) ;; Skip for-label requires
+ [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)))))
+ (let-values ([(vprov sprov) (module-compiled-exports compiled)])
+ (for* ([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 ([name (car name+srcs)])
+ (match src
+ [(? module-path-index?)
+ (add! src 0)]
+ [(list imp-mod imp-phase-shift imp-name imp-phase-???)
+ (add! imp-mod imp-phase-shift)])))))
+
+;; ========
+
+;; 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)]
+ [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))]
+ [else
+ (if (memq db-config '(no-drop))
+ (list 'keep mod phase "db says no-drop")
+ (list 'drop mod phase))]))))
+
+;; nom-use-alg : RefTable compiled -> (listof recommendation)
+(define (nom-use-alg refs compiled)
+ (let-values ([(NOM-USES DEF-USES) (calculate-used-approximations refs)])
+ (add-provides! compiled NOM-USES DEF-USES)
+ (report NOM-USES DEF-USES (get-requires compiled))))
diff --git a/collects/macro-debugger/analysis/private/refine-alg.rkt b/collects/macro-debugger/analysis/private/refine-alg.rkt
@@ -0,0 +1,59 @@
+#lang racket/base
+
+;; intern Def, Use?
+
+;; A Def is (def sym resolved-module-path int)
+(struct def (sym mod phase) #:prefab)
+
+;; A Use is (use Def int)
+;; the offset is (ref-phase - def-phase)
+(struct use (def offset) #:prefab)
+
+;; A resolved is path or symbol.
+
+;; An import is (import resolved int)
+(struct import (resolved offset))
+
+;; ========
+
+;; uses : hash[Use => #t]
+;; reqs : hash[import => mpi]
+;; keeps : hash[import => mpi]
+
+#|
+
+(define (refine uses reqs keeps)
+ (unless (= (hash-count uses) 0)
+ (direct-def-uses uses reqs keeps)
+ (recur-on-imports uses reqs keeps)))
+
+|#
+
+(define (hash-choose h)
+ (let ([i (hash-iterate-first h)])
+ (and i (hash-iterate-value h i))))
+
+#|
+Algorithm for refining bypass modules
+
+loop: set of references (id, phase), set of requires (mod, phase)
+ for every reference DEFINED* in a require R
+ mark that require R NEEDED and remove from set
+ eliminate every reference provided by R
+ (including re-provides)
+ now every reference left is re-provided by some remaining require
+ recur on imports of requires
+
+DEFINED* : really, defined in this module OR imported from a "private" module.
+|#
+
+
+;; ====================
+
+#|
+Another algorithm
+
+Put all requires in priority queue, with max-depth-to-kernel
+priority...
+
+|#
diff --git a/collects/macro-debugger/analysis/private/util.rkt b/collects/macro-debugger/analysis/private/util.rkt
@@ -0,0 +1,73 @@
+#lang racket/base
+(require syntax/modcode
+ syntax/modresolve
+ macro-debugger/model/trace)
+
+(provide get-module-code/trace
+ here-mpi?
+ mpi->key
+ mpi->list)
+
+;; get-module-derivation : module-path -> (values compiled Deriv)
+(define (get-module-code/trace path)
+ (get-module-code (resolve-module-path path #f)
+ #:choose (lambda _ 'src)
+ #:compile (lambda (stx)
+ (let-values ([(stx deriv) (trace/result stx expand)])
+ (values (compile stx) deriv)))))
+
+;; here-mpi? : any -> boolean
+(define (here-mpi? x)
+ (and (module-path-index? x)
+ (let-values ([(rel base) (module-path-index-split x)])
+ (and (eq? rel #f) (eq? base #f)))))
+
+(define (mpi->key x)
+ (let ([l (mpi->list x)])
+ (if (and (pair? l) (null? (cdr l)))
+ (car l)
+ l)))
+
+(define (mpi->list x)
+ (cond [(module-path-index? x)
+ (let-values ([(rel base) (module-path-index-split x)])
+ (if rel
+ (cons rel (mpi->list base))
+ null))]
+ [(eq? x #f)
+ null]
+ [else
+ (list x)]))
+
+;; --------
+
+(provide get-module-imports
+ get-module-exports
+ get-module-var-exports
+ get-module-stx-exports)
+
+(struct modinfo (imports var-exports stx-exports) #:prefab)
+
+;; cache : hash[path/symbol => modinfo]
+(define cache (make-hash))
+
+(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)])
+ (modinfo imports var-exports stx-exports))))
+
+(define (get-module-info path)
+ (let ([resolved (resolve-module-path path #f)])
+ (hash-ref! cache resolved (lambda () (get-module-info/no-cache resolved)))))
+
+(define (get-module-imports path)
+ (modinfo-imports (get-module-info path)))
+(define (get-module-var-exports path)
+ (modinfo-var-exports (get-module-info path)))
+(define (get-module-stx-exports path)
+ (modinfo-stx-exports (get-module-info path)))
+(define (get-module-exports path)
+ (let ([info (get-module-info path)])
+ (values (modinfo-var-exports info) (modinfo-stx-exports info))))
+
