get-references.rkt (7529B)
1 #lang racket/base 2 (require racket/match 3 macro-debugger/model/deriv 4 racket/struct 5 "util.rkt") 6 (provide deriv->refs) 7 8 ;; ======== 9 10 ;; phase : (parameterof nat) 11 (define phase (make-parameter 0)) 12 (define (add-disappeared-uses?) #t) 13 14 ;; ======== 15 16 ;; deriv->refs : *Deriv* -> Refs 17 ;; *Deriv* = Deriv | LDeriv | BRule | ModRule | ... (anything from deriv.rkt) 18 (define (deriv->refs deriv0) 19 20 ;; refs : (listof Refs), mutable 21 (define refs null) 22 23 (define (recur . args) 24 (let check ([arg args]) 25 (cond [(syntax? arg) (error 'deriv->refs "internal error on ~s" arg)] 26 [(list? arg) (for-each check arg)] 27 [else (void)])) 28 (for ([arg (in-list args)]) 29 (if (list? arg) 30 (apply recur arg) 31 (analyze-deriv arg)))) 32 (define (recur/phase-up . args) 33 (parameterize ((phase (add1 (phase)))) 34 (apply recur args))) 35 (define (add-refs! rs) 36 (set! refs (append rs refs))) 37 (define (add! ids [mode 'reference]) 38 (let ([p (phase)]) 39 (add-refs! (for/list ([id (in-list ids)]) 40 (ref p id mode (identifier-binding id p)))))) 41 (define (add/binding! id binding mode) 42 (add-refs! (list (ref (phase) id mode binding)))) 43 44 ;; analyze/quote-syntax : stx -> void 45 ;; Current approach: estimate that an identifier in a syntax template 46 ;; may be used at (sub1 (phase)) or (phase). 47 ;; FIXME: Allow for more conservative choices, too. 48 ;; FIXME: #%top, #%app, #%datum, etc? 49 ;; FIXME: Track tentative (in quote-syntax) references separately? 50 (define (analyze/quote-syntax qs-stx) 51 (let ([phases (for/list ([offset '(0 1 -1 2 -2)]) (+ (phase) offset))] 52 [stx (syntax-case qs-stx () 53 [(_quote-syntax x) #'x])]) 54 (define (add*! id) 55 (add-refs! (for/list ([p (in-list phases)]) 56 (ref p id 'quote-syntax (identifier-binding id p))))) 57 (let loop ([stx stx]) 58 (let ([d (if (syntax? stx) (syntax-e stx) stx)]) 59 (cond [(identifier? stx) (add*! stx)] 60 [(pair? d) 61 (loop (car d)) 62 (loop (cdr d))] 63 [(vector? d) 64 (map loop (vector->list d))] 65 [(prefab-struct-key d) 66 (map loop (struct->list d))] 67 [(box? d) 68 (loop (unbox d))] 69 [else 70 (void)]))))) 71 72 (define (analyze-deriv deriv) 73 ;; Handle common base (ie, resolves) part of derivs, if applicable 74 (match deriv 75 [(base z1 z2 resolves ?1) 76 (add! resolves) 77 (when (and (syntax? z2) (add-disappeared-uses?)) 78 (let ([uses (syntax-property z2 'disappeared-use)]) 79 (add! (let loop ([x uses] [onto null]) 80 (cond [(identifier? x) (cons x onto)] 81 [(pair? x) (loop (car x) (loop (cdr x) onto))] 82 [else onto])) 83 'disappeared-use)))] 84 [_ 85 (void)]) 86 ;; Handle individual variants 87 (match deriv 88 [(lift-deriv z1 z2 first lift-stx second) 89 (recur first second)] 90 [(tagrule z1 z2 tagged-stx next) 91 (recur next)] 92 [(lift/let-deriv z1 z2 first lift-stx second) 93 (recur first second)] 94 [(mrule z1 z2 rs ?1 me1 locals me2 ?2 etx next) 95 (recur locals next)] 96 [(local-exn exn) 97 (void)] 98 [(local-expansion z1 z2 for-stx? me1 inner lifted me2 opaque) 99 ((if for-stx? recur/phase-up recur) inner)] 100 [(local-lift expr ids) 101 (void)] 102 [(local-lift-end decl) 103 (void)] 104 [(local-lift-require req expr mexpr) 105 (void)] 106 [(local-lift-provide prov) 107 (void)] 108 [(local-bind names ?1 renames bindrhs) 109 (recur bindrhs)] 110 [(local-value name ?1 resolves bound? binding) 111 #| 112 Beware: in one common case, local-member-name, the binding of name is 113 mutated (because used as binder in class body), so original binding is lost! 114 Use binding instead. 115 |# 116 (when (and bound? (pair? binding)) 117 (add/binding! name binding 'syntax-local-value))] 118 [(track-origin before after) 119 (void)] 120 [(local-remark contents) 121 (void)] 122 [(p:variable z1 z2 rs ?1) 123 (void)] 124 [(p:module z1 z2 rs ?1 locals tag rename check tag2 ?3 body shift) 125 (recur locals check body)] 126 [(p:#%module-begin z1 z2 rs ?1 me body ?2 subs) 127 (recur body subs)] 128 [(p:define-syntaxes z1 z2 rs ?1 prep rhs locals) 129 (recur prep locals) 130 (recur/phase-up rhs)] 131 [(p:define-values z1 z2 rs ?1 rhs) 132 (recur rhs)] 133 [(p:begin-for-syntax z1 z2 rs ?1 prep body locals) 134 (recur prep locals) 135 (recur/phase-up body)] 136 [(p:#%expression z1 z2 rs ?1 inner untag) 137 (recur inner)] 138 [(p:if z1 z2 rs ?1 test then else) 139 (recur test then else)] 140 [(p:wcm z1 z2 rs ?1 key mark body) 141 (recur key mark body)] 142 [(p:set! _ _ _ _ id-resolves ?2 rhs) 143 (add! id-resolves) 144 (recur rhs)] 145 [(p:set!-macro _ _ _ _ deriv) 146 (recur deriv)] 147 [(p:#%app _ _ _ _ lderiv) 148 (recur lderiv)] 149 [(p:begin _ _ _ _ lderiv) 150 (recur lderiv)] 151 [(p:begin0 _ _ _ _ first lderiv) 152 (recur first lderiv)] 153 [(p:lambda _ _ _ _ renames body) 154 (recur body)] 155 [(p:case-lambda _ _ _ _ renames+bodies) 156 (recur renames+bodies)] 157 [(p:let-values _ _ _ _ renames rhss body) 158 (recur rhss body)] 159 [(p:letrec-values _ _ _ _ renames rhss body) 160 (recur rhss body)] 161 [(p:letrec-syntaxes+values _ _ _ _ srenames prep sbindrhss vrenames vrhss body tag) 162 (recur prep sbindrhss vrhss body)] 163 [(p:provide _ _ _ _ inners ?2) 164 (recur inners)] 165 [(p:require _ _ _ _ locals) 166 (recur locals)] 167 [(p:submodule _ _ _ _ exp) 168 (recur exp)] 169 [(p:submodule* _ _ _ _) 170 (void)] 171 [(p:#%stratified-body _ _ _ _ bderiv) 172 (recur bderiv)] 173 [(p:stop _ _ _ _) (void)] 174 [(p:unknown _ _ _ _) (void)] 175 [(p:#%top _ _ _ _) 176 (void)] 177 [(p:#%datum _ _ _ _) (void)] 178 [(p:quote _ _ _ _) (void)] 179 [(p:quote-syntax z1 z2 _ _) 180 (when z2 (analyze/quote-syntax z2))] 181 [(p:#%variable-reference _ _ _ _) 182 (void)] 183 [(lderiv _ _ ?1 derivs) 184 (recur derivs)] 185 [(bderiv _ _ pass1 trans pass2) 186 (recur pass1 pass2)] 187 [(b:error ?1) 188 (void)] 189 [(b:expr _ head) 190 (recur head)] 191 [(b:splice _ head ?1 tail ?2) 192 (recur head)] 193 [(b:defvals _ head ?1 rename ?2) 194 (recur head)] 195 [(b:defstx _ head ?1 rename ?2 prep bindrhs) 196 (recur head prep bindrhs)] 197 [(bind-syntaxes rhs locals) 198 (recur/phase-up rhs) 199 (recur locals)] 200 [(clc ?1 renames body) 201 (recur body)] 202 [(module-begin/phase pass1 pass2 pass3) 203 (recur pass1 pass2 pass3)] 204 [(mod:prim head rename prim) 205 (recur head prim)] 206 [(mod:splice head rename ?1 tail) 207 (recur head)] 208 [(mod:lift head locals renames tail) 209 (recur head locals)] 210 [(mod:lift-end tail) 211 (void)] 212 [(mod:cons head locals) 213 (recur head locals)] 214 [(mod:skip) 215 (void)] 216 ;; Shouldn't occur in module expansion. 217 ;; (Unless code calls 'expand' at compile-time; weird, but possible.) 218 [(ecte _ _ locals first second locals2) 219 (recur locals first second locals2)] 220 [(bfs:lift lderiv lifts) 221 (recur lderiv)] 222 [#f 223 (void)])) 224 225 (analyze-deriv deriv0) 226 refs)