reductions-config.rkt (15320B)
1 #lang racket/base 2 (require (for-syntax racket/base) 3 racket/contract/base 4 racket/match 5 "../util/eomap.rkt" 6 "deriv-util.rkt" 7 "stx-util.rkt" 8 "context.rkt" 9 "steps.rkt") 10 11 (define-syntax-rule (STRICT-CHECKS form ...) 12 (when #f 13 form ... (void))) 14 15 (define state/c (or/c state? false/c)) 16 (define context/c any/c) 17 (define big-context/c any/c) 18 19 (define (parameterlike/c c) 20 (case-> [-> c] [c . -> . any/c])) 21 22 (define (list-parameter/c c) 23 (parameter/c (listof (box/c c)))) 24 25 (define subterms-table/c hash?) 26 27 (define-syntax-rule (provide/contract* [name c] ...) 28 #;(provide/contract [name c] ...) 29 (provide name ...)) 30 31 (provide/contract* 32 [state/c contract?] 33 [context (parameter/c context/c)] 34 [big-context (parameter/c big-context/c)] 35 [marking-table (parameter/c (or/c hash? false/c))] 36 [current-binders (parameter/c (listof identifier?))] 37 [current-definites (parameter/c eomap?)] ;; eomap[identifier => phase-level] 38 [current-binders (parameter/c hash?)] ;; hash[identifier => phase-level] 39 [current-frontier (parameter/c (listof syntax?))] 40 [sequence-number (parameter/c (or/c false/c exact-nonnegative-integer?))] 41 [phase (parameter/c exact-nonnegative-integer?)] 42 [visibility (parameter/c boolean?)] 43 [macro-policy (parameter/c (identifier? . -> . any))] 44 [subterms-table (parameter/c (or/c subterms-table/c false/c))] 45 [hides-flags (list-parameter/c boolean?)] 46 47 [learn-binders ((listof identifier?) . -> . any)] 48 [learn-definites ((listof identifier?) . -> . any)] 49 50 [add-frontier ((listof syntax?) . -> . any)] 51 [blaze-frontier (syntax? . -> . any)] 52 53 [current-state-with (syntaxish? syntaxish? . -> . state?)] 54 [walk ([syntaxish? syntaxish? symbol?] 55 [#:foci1 syntaxish? #:foci2 syntaxish?] 56 . ->* . step?)] 57 [stumble ([syntaxish? exn?] [#:focus syntaxish?] . ->* . misstep?)] 58 [walk/talk 59 (-> (or/c symbol? string?) (listof (or/c syntax? string? 'arrow)) 60 remarkstep?)] 61 62 [current-pass-hides? (parameterlike/c boolean?)] 63 64 [available-lift-stxs (parameter/c (listof syntaxish?))] 65 [visible-lift-stxs (parameter/c (listof syntaxish?))]) 66 67 (provide with-context 68 with-new-local-context) 69 70 ;; FIXME: Steps are pairs of Configurations 71 ;; Configurations contain contexts, definites, etc. 72 73 ;; Classical Parameters 74 75 ;; context: parameter of Context 76 (define context (make-parameter null)) 77 78 ;; big-context: parameter of BigContext 79 (define big-context (make-parameter null)) 80 81 ;; marking-table 82 (define marking-table (make-parameter #f)) 83 84 ;; current-binders : parameter of hash[identifier => phase-level] 85 (define current-binders (make-parameter #f)) 86 87 ;; current-definites : parameter of eomap[identifier => phase-level] 88 (define current-definites (make-parameter #f)) 89 90 ;; current-frontier : parameter of (list-of syntax) 91 (define current-frontier (make-parameter null)) 92 93 ;; sequence-number : parameter of nat 94 (define sequence-number (make-parameter #f)) 95 96 ;; New Hiding Parameters 97 98 ;; visibility : (parameterof boolean) 99 (define visibility (make-parameter #t)) 100 101 ;; macro-policy : (parameterof (identifier -> boolean)) 102 (define macro-policy (make-parameter (lambda (id) #t))) 103 104 ;; phase : (parameterof nat) 105 (define phase (make-parameter 0)) 106 107 ;; subterms-table : parameter of hash[syntax => (list-of Path)] 108 (define subterms-table (make-parameter #f)) 109 110 ;; hides-flags : (parameterof (listof (boxof boolean))) 111 (define hides-flags (make-parameter null)) 112 113 ;; lift params 114 (define available-lift-stxs (make-parameter null)) 115 (define visible-lift-stxs (make-parameter null)) 116 117 ;; Hiding Structures 118 119 (provide (struct-out hiding-failure) 120 (struct-out nonlinearity) 121 (struct-out localactions) 122 (struct-out hidden-lift-site)) 123 124 ;; Machinery for reporting things that macro hiding can't handle 125 (define-struct hiding-failure ()) 126 (define-struct (nonlinearity hiding-failure) (term paths)) 127 (define-struct (localactions hiding-failure) ()) 128 (define-struct (hidden-lift-site hiding-failure) ()) 129 130 ;; Operations 131 132 (define-syntax with-context 133 (syntax-rules () 134 [(with-context f . body) 135 (let ([c (context)]) 136 (parameterize ([context 137 (if (visibility) 138 (cons f c) 139 c)]) 140 (let () . body)))])) 141 142 (define-syntax with-new-local-context 143 (syntax-rules () 144 [(with-new-local-context e . body) 145 (parameterize ([big-context 146 (cons (make bigframe (context) (list e) e) 147 (big-context))] 148 [context null]) 149 . body)])) 150 151 (define (learn-definites ids) 152 (current-definites 153 (eomap-set* (current-definites) ids (phase)))) 154 155 (define (learn-binders ids) 156 (current-binders 157 (for/fold ([binders (current-binders)]) ([id (in-list ids)]) 158 (hash-set binders id (phase))))) 159 160 (define (get-frontier) (or (current-frontier) null)) 161 162 (define (add-frontier stxs) 163 (current-frontier 164 (let ([frontier0 (current-frontier)]) 165 (and frontier0 (append stxs frontier0))))) 166 167 (define (blaze-frontier stx) 168 (current-frontier 169 (let ([frontier0 (current-frontier)]) 170 (and frontier0 171 (remq stx frontier0))))) 172 173 ;; Renames mapping 174 175 (define renames-mapping/c 176 ([syntax?] [#:allow-nonstx? boolean? #:default any/c] . ->* . any)) 177 178 (provide/contract* 179 [renames-mapping/c contract?] 180 [make-renames-mapping 181 (syntaxish? syntaxish? . -> . renames-mapping/c)] 182 [compose-renames-mappings 183 (renames-mapping/c renames-mapping/c . -> . renames-mapping/c)] 184 [apply-renames-mapping (renames-mapping/c syntaxish? . -> . syntaxish?)] 185 186 [table->renames-mapping 187 (hash? . -> . renames-mapping/c)] 188 [make-renames-table 189 (syntaxish? syntaxish? . -> . hash?)] 190 [add-to-renames-table 191 (hash? syntaxish? syntaxish? . -> . any)] 192 193 [rename-frontier/mapping 194 (renames-mapping/c . -> . any)]) 195 196 (define (rename-frontier/mapping mapping) 197 (current-frontier 198 (with-handlers ([exn:fail? (lambda _ #f)]) 199 (for/list ([fstx (current-frontier)]) 200 (let ([renamed-fstx (mapping fstx #:allow-nonstx? #t #:default null)]) 201 (flatten-syntaxes renamed-fstx)))))) 202 203 ;; apply-renames-mapping : (stx -> stx) stx -> stx 204 (define (apply-renames-mapping mapping stx) 205 (cond [(and (syntax? stx) 206 (mapping stx #:allow-nonstx? #t #:default #f)) 207 => (lambda (rstx) 208 (datum->syntax stx rstx stx stx))] 209 [(syntax? stx) 210 (let* ([inner (syntax-e stx)] 211 [rinner (apply-renames-mapping mapping inner)]) 212 (if (eq? rinner inner) 213 stx 214 (datum->syntax stx rinner stx stx)))] 215 [(pair? stx) 216 (let ([ra (apply-renames-mapping mapping (car stx))] 217 [rb (apply-renames-mapping mapping (cdr stx))]) 218 (if (and (eq? ra (car stx)) (eq? rb (cdr stx))) 219 stx 220 (cons ra rb)))] 221 [(vector? stx) 222 (let* ([elems (vector->list stx)] 223 [relems (apply-renames-mapping mapping elems)]) 224 (if (eq? relems elems) 225 stx 226 (list->vector relems)))] 227 [(box? stx) 228 (let* ([inner (unbox stx)] 229 [rinner (apply-renames-mapping mapping inner)]) 230 (if (eq? rinner inner) 231 stx 232 (box inner)))] 233 [(prefab-struct-key stx) 234 (let* ([inner (struct->vector stx)] 235 [rinner (apply-renames-mapping mapping inner)]) 236 (if (eq? rinner inner) 237 stx 238 (apply make-prefab-struct 239 (prefab-struct-key stx) 240 (cdr (vector->list rinner)))))] 241 [else stx])) 242 243 ;; make-renames-mapping : stx stx -> stx kw-args -> stx 244 (define (make-renames-mapping from0 to0) 245 (define table (make-renames-table from0 to0)) 246 (table->renames-mapping table)) 247 248 (define (table->renames-mapping table) 249 (lambda (stx #:allow-nonstx? [allow-nonstx? #f] #:default [default #f]) 250 (let ([replacement (hash-ref table stx #f)]) 251 (if replacement 252 (begin #;(printf " replacing ~s with ~s\n" stx replacement) 253 replacement) 254 (begin #;(printf " not replacing ~s\n" stx) 255 default))))) 256 257 (define (make-renames-table from0 to0) 258 (define table (make-hasheq)) 259 (add-to-renames-table table from0 to0) 260 table) 261 262 (define (add-to-renames-table table from0 to0) 263 (let loop ([from from0] [to to0]) 264 (cond [(and (syntax? from) (syntax? to)) 265 (hash-set! table from to) 266 (loop (syntax-e from) (syntax-e to))] 267 [(syntax? from) 268 (hash-set! table from to) 269 (loop (syntax-e from) to)] 270 [(syntax? to) 271 (loop from (syntax-e to))] 272 [(and (pair? from) (pair? to)) 273 (loop (car from) (car to)) 274 (loop (cdr from) (cdr to))] 275 [(and (vector? from) (vector? to)) 276 (loop (vector->list from) (vector->list to))] 277 [(and (box? from) (box? to)) 278 (loop (unbox from) (unbox to))] 279 [(and (struct? from) (struct? to)) 280 (loop (struct->vector from) (struct->vector to))] 281 [(eqv? from to) 282 (void)] 283 [else 284 ;; FIXME: bad rename indicates something out of sync 285 ;; But for now, just drop it to avoid macro stepper error. 286 ;; Only bad effect should be missed subterms (usually at phase1). 287 (STRICT-CHECKS 288 (eprintf "from:\n~.s\n\nto:\n~.s\n\n" 289 (stx->datum from) 290 (stx->datum to)) 291 (eprintf "original from:\n~.s\n\noriginal to:\n~.s\n\n" 292 (stx->datum from0) 293 (stx->datum to0)) 294 (error 'add-to-renames-table)) 295 (void)]))) 296 297 (define (compose-renames-mappings first second) 298 (lambda (stx #:allow-nonstx? [allow-nonstx? #f] #:default [default #f]) 299 (let ([r (first stx #:allow-nonstx? allow-nonstx? #:default #f)]) 300 (if r 301 (second r #:allow-nonstx? allow-nonstx? #:default default) 302 default)))) 303 304 (define (flatten-syntaxes x) 305 (cond [(syntax? x) 306 (list x)] 307 [(pair? x) 308 (append (flatten-syntaxes (car x)) 309 (flatten-syntaxes (cdr x)))] 310 [(vector? x) 311 (flatten-syntaxes (vector->list x))] 312 [(box? x) 313 (flatten-syntaxes (unbox x))] 314 [else null])) 315 316 ;; ----------------------------------- 317 318 (define (current-state-with e fs) 319 (make state e (foci fs) (context) (big-context) 320 (current-binders) (current-definites) 321 (current-frontier) (sequence-number))) 322 323 (define (walk e1 e2 type 324 #:foci1 [foci1 e1] 325 #:foci2 [foci2 e2]) 326 (make step type 327 (current-state-with e1 foci1) 328 (current-state-with e2 foci2))) 329 330 (define (stumble stx exn 331 #:focus [focus stx]) 332 (make misstep 'error 333 (current-state-with stx focus) 334 exn)) 335 336 (define (walk/talk type contents) 337 (make remarkstep type 338 (current-state-with #f null) 339 contents)) 340 341 (define (foci x) 342 (cond [(syntax? x) 343 (list x)] 344 [(null? x) 345 null] 346 [(pair? x) 347 (append (foci (car x)) 348 (foci (cdr x)))])) 349 350 351 ;; RS: the reductions monad 352 353 ;; Datastructure RS 354 ;; Better for debugging 355 356 ;; RS = (rsok ReductionSequence stx stx state) 357 ;; | (rsfailed ReductionSequence exn) 358 359 (define-struct rsok (rs real vis s)) 360 (define-struct rsfailed (rs exn)) 361 362 (define RS/c 363 (lambda (x) 364 (or (rsok? x) (rsfailed? x)))) 365 366 (define (RSunit steps x y s) (make rsok steps x y s)) 367 368 (define (RSfail steps exn) (make rsfailed steps exn)) 369 370 (define (RSbind a f) 371 (match a 372 [(struct rsok (rs a b s)) 373 (f a b s rs)] 374 [(struct rsfailed (rs exn)) 375 a])) 376 377 (define (RScase a k f) 378 (match a 379 [(struct rsok (rs a b s)) 380 (k rs a b s)] 381 [(struct rsfailed (rs exn)) 382 (f rs exn)])) 383 384 (provide RS/c) 385 (provide/contract* 386 [RSunit ((listof protostep?) any/c any/c state/c . -> . RS/c)] 387 [RSfail ((listof protostep?) exn? . -> . RS/c)] 388 [RSbind (RS/c (any/c any/c state/c (listof protostep?) . -> . RS/c) . -> . RS/c)] 389 [RScase (RS/c 390 ((listof protostep?) any/c any/c state/c . -> . any) 391 ((listof protostep?) exn? . -> . any) 392 . -> . any)]) 393 394 #| 395 ;; Alternate RS = (values ?exn steps ?stx ?stx state) 396 ;; Avoids allocation 397 ;; Doesn't seem to actually matter 398 399 (define (RSunit ws x y s) 400 (values #f ws x y s)) 401 402 (define (RSfail ws e) 403 (values e ws #f #f #f)) 404 405 (define-syntax-rule (RSbind a f) 406 (let-values ([(e ws x y s) a]) 407 (if (not e) 408 (f x y s ws) 409 (values e ws x y s)))) 410 411 (define-syntax-rule (RScase a k f) 412 (let-values ([(e ws x y s) a]) 413 (if (not e) 414 (k ws x y s) 415 (f ws e)))) 416 417 (define-syntax RS/c (make-rename-transformer #'any/c)) 418 419 (provide RS/c 420 RSunit 421 RSfail 422 RSbind 423 RScase) 424 |# 425 426 427 ;; Table 428 429 (provide/contract* 430 [gather-proper-subterms (syntaxish? . -> . subterms-table/c)] 431 [table-get (subterms-table/c syntax? . -> . list?)] 432 [table-apply-renames-mapping 433 ((or/c subterms-table/c false/c) renames-mapping/c boolean? 434 . -> . (or/c subterms-table/c false/c))]) 435 436 ;; gather-proper-subterms : Syntax -> SubtermTable 437 ;; FIXME: Eventually, need to descend into vectors, boxes, etc. 438 (define (gather-proper-subterms stx0) 439 (define (table-add! table stx v) 440 (hash-set! table stx (cons v (table-get table stx)))) 441 (define (table-get table stx) 442 (hash-ref table stx null)) 443 (let ([table (make-hasheq)]) 444 ;; loop : Syntax Path -> void 445 (define (loop stx rpath) 446 (unless (eq? stx0 stx) 447 (table-add! table stx (reverse rpath))) 448 (let ([p (if (syntax? stx) (syntax-e stx) stx)]) 449 (when (pair? p) 450 (loop-cons p rpath 0)))) 451 ;; loop-cons : (cons Syntax ?) Path number -> void 452 (define (loop-cons p rpath pos) 453 (loop (car p) (cons (make ref pos) rpath)) 454 (let ([t (cdr p)]) 455 (cond [(syntax? t) 456 (let ([te (syntax-e t)]) 457 (if (pair? te) 458 (begin 459 (table-add! table t (reverse (cons (make tail pos) rpath))) 460 (loop-cons te rpath (add1 pos))) 461 (loop t (cons (make tail pos) rpath))))] 462 [(pair? t) 463 (loop-cons t rpath (add1 pos))] 464 [(null? t) 465 (void)]))) 466 (loop stx0 null) 467 table)) 468 469 ;; table-get : Table stx -> (listof Path) 470 (define (table-get t x) 471 (hash-ref t x null)) 472 473 ;; table-apply-renames-mapping boolean : Table (stx -> stx) -> Table 474 (define (table-apply-renames-mapping old mapping whole-form-rename?) 475 (and old 476 (let ([t (make-hasheq)]) 477 (hash-for-each 478 old 479 (if whole-form-rename? 480 (lambda (stx paths) 481 (let ([rstx (mapping stx #:default #f)]) 482 (when rstx 483 (hash-set! t rstx paths)))) 484 (lambda (stx paths) 485 (let ([rstx (mapping stx #:default stx)]) 486 (hash-set! t rstx paths))))) 487 t))) 488 489 ;; list-parameter->parameterlike : (list-parameter/c X) -> (parameterlike X) 490 (define (list-parameter->parameterlike p) 491 (case-lambda 492 [() (unbox (car (p)))] 493 [(v) (set-box! (car (p)) v)])) 494 495 ;; current-pass-hides? 496 (define current-pass-hides? (list-parameter->parameterlike hides-flags))