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

delay the construction of the compatible-closure grammar (the 'cross' thing)

Browse Source 
until it is actually used. (This can make a big difference for large grammars
in models that don't actually use the compatible closure stuff.)
This commit is contained in:
Robby Findler 2011-10-30 22:35:23 -05:00
parent 1dade8ee1d
commit 41f68af64a
2 changed files with 73 additions and 43 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

68
collects/redex/private/matcher.rkt
View File

@ -2,18 +2,19 @@
#|
Note: the patterns described in the doc.txt file are
Note: the patterns described in the documentation are
slightly different than the patterns processed here.
The difference is in the form of the side-condition
expressions. Here they are procedures that accept
binding structures, instead of expressions. The
reduction (And other) macros do this transformation
before the pattern compiler is invoked.
rewrite-side-conditions/check-errs macro does this
transformation before the pattern compiler is invoked.
|#
(require scheme/list
scheme/match
scheme/contract
racket/promise
"underscore-allowed.rkt")
(define-struct compiled-pattern (cp))
@ -85,9 +86,16 @@ before the pattern compiler is invoked.
;; (listof symbol)
;; (listof (listof symbol))) -- keeps track of `primary' non-terminals
(define-struct compiled-lang (lang cclang ht list-ht across-ht across-list-ht
(define-struct compiled-lang (lang delayed-cclang ht list-ht raw-across-ht raw-across-list-ht
has-hole-ht cache bind-names-cache pict-builder
literals nt-map))
(define (compiled-lang-cclang x) (force (compiled-lang-delayed-cclang x)))
(define (compiled-lang-across-ht x)
(compiled-lang-cclang x) ;; ensure this is computed
(compiled-lang-raw-across-ht x))
(define (compiled-lang-across-list-ht x)
(compiled-lang-cclang x) ;; ensure this is computed
(compiled-lang-raw-across-list-ht x))
;; lookup-binding : bindings (union sym (cons sym sym)) [(-> any)] -> any
(define (lookup-binding bindings
@ -160,15 +168,18 @@ before the pattern compiler is invoked.
(when (has-underscore? nt)
(error 'compile-language "cannot use underscore in nonterminal name, ~s" nt))))
(let ([compatible-context-language
(build-compatible-context-language clang-ht lang)])
(for-each (lambda (nt)
(hash-set! across-ht (nt-name nt) null)
(hash-set! across-list-ht (nt-name nt) null))
compatible-context-language)
(do-compilation clang-ht clang-list-ht lang #t)
(do-compilation across-ht across-list-ht compatible-context-language #f)
(struct-copy compiled-lang clang [cclang compatible-context-language]))))
(define compatible-context-language
(delay
(let ([compatible-context-language
(build-compatible-context-language clang-ht lang)])
(for-each (lambda (nt)
(hash-set! across-ht (nt-name nt) null)
(hash-set! across-list-ht (nt-name nt) null))
compatible-context-language)
(do-compilation across-ht across-list-ht compatible-context-language #f)
compatible-context-language)))
(do-compilation clang-ht clang-list-ht lang #t)
(struct-copy compiled-lang clang [delayed-cclang compatible-context-language])))
;; extract-literals : (listof nt) -> (listof symbol)
(define (extract-literals nts)
@ -633,8 +644,6 @@ before the pattern compiler is invoked.
(define clang-ht (compiled-lang-ht clang))
(define clang-list-ht (compiled-lang-list-ht clang))
(define has-hole-ht (compiled-lang-has-hole-ht clang))
(define across-ht (compiled-lang-across-ht clang))
(define across-list-ht (compiled-lang-across-list-ht clang))
(define (compile-pattern/default-cache pattern)
(compile-pattern/cache pattern
@ -709,19 +718,21 @@ before the pattern compiler is invoked.
match-raw-name)
has-hole?))])]
[`(cross ,(? symbol? pre-id))
(let ([id (if prefix-cross?
(symbol-append pre-id '- pre-id)
pre-id)])
(cond
[(hash-maps? across-ht id)
(values
(lambda (exp hole-info)
(match-nt (hash-ref across-list-ht id)
(hash-ref across-ht id)
id exp hole-info))
#t)]
[else
(error 'compile-pattern "unknown cross reference ~a" id)]))]
(define across-ht (compiled-lang-across-ht clang))
(define across-list-ht (compiled-lang-across-list-ht clang))
(define id (if prefix-cross?
(symbol-append pre-id '- pre-id)
pre-id))
(cond
[(hash-maps? across-ht id)
(values
(lambda (exp hole-info)
(match-nt (hash-ref across-list-ht id)
(hash-ref across-ht id)
id exp hole-info))
#t)]
[else
(error 'compile-pattern "unknown cross reference ~a" id)])]
[`(name ,name ,pat)
(let-values ([(match-pat has-hole?) (compile-pattern/default-cache pat)])
@ -1613,6 +1624,7 @@ before the pattern compiler is invoked.
(provide (struct-out nt)
(struct-out rhs)
(struct-out compiled-lang)
compiled-lang-cclang
lookup-binding

48
collects/redex/private/rg.rkt
View File

@ -1,4 +1,4 @@
#lang scheme
#lang scheme/base
(require "matcher.rkt"
"reduction-semantics.rkt"
@ -6,10 +6,18 @@
"term.rkt"
"error.rkt"
"struct.rkt"
(for-syntax "rewrite-side-conditions.rkt")
(for-syntax "term-fn.rkt")
(for-syntax "reduction-semantics.rkt")
(for-syntax "keyword-macros.rkt")
(for-syntax scheme/base
"rewrite-side-conditions.rkt"
"term-fn.rkt"
"reduction-semantics.rkt"
"keyword-macros.rkt")
scheme/dict
scheme/contract
scheme/promise
scheme/unit
scheme/match
scheme/pretty
scheme/function
mrlib/tex-table)
(define redex-pseudo-random-generator
@ -149,7 +157,8 @@
[min-size (apply min/f sizes)])
(map cadr (filter (λ (x) (equal? min-size (car x))) (map list sizes prods)))))
(define-struct rg-lang (non-cross cross base-cases))
(define-struct rg-lang (non-cross delayed-cross base-cases))
(define (rg-lang-cross x) (force (rg-lang-delayed-cross x)))
(define (prepare-lang lang)
(let ([parsed (parse-language lang)])
(values parsed (map symbol->string (compiled-lang-literals lang)) (find-base-cases parsed))))
@ -405,7 +414,7 @@
(λ (lang bases any?)
(make-rg-lang
(compile-non-terminals (compiled-lang-lang lang) any?)
(compile-non-terminals (compiled-lang-cclang lang) any?)
(delay (compile-non-terminals (compiled-lang-cclang lang) any?))
bases))]
[(langc sexpc compile-pattern)
(values
@ -422,7 +431,8 @@
[else t]))
(bindings e)))))))))
(define-struct base-cases (cross non-cross))
(define-struct base-cases (delayed-cross non-cross))
(define (base-cases-cross x) (force (base-cases-delayed-cross x)))
;; find-base-cases : (list/c nt) -> base-cases
(define (find-base-cases lang)
@ -469,7 +479,7 @@
(loop a)
(loop b)]
[_ (void)]))
nts))
nts))
;; build-table : (listof nt) -> hash
(define (build-table nts)
@ -479,15 +489,23 @@
nts)
tbl))
;; we can delay the work of computing the base cases for
;; the cross part of the language since none of the productions
;; refer to it (as that's not allowed in general and would be
;; quite confusing if it were...)
(let loop ()
(set! changed? #f)
(for-each (process-nt #f) (compiled-lang-lang lang))
(for-each (process-nt #t) (compiled-lang-cclang lang))
(when changed?
(loop)))
(make-base-cases
(build-table (compiled-lang-cclang lang))
(delay (begin
(let loop ()
(set! changed? #f)
(for-each (process-nt #t) (compiled-lang-cclang lang))
(when changed?
(loop)))
(build-table (compiled-lang-cclang lang))))
(build-table (compiled-lang-lang lang))))
(define min/f
@ -623,10 +641,10 @@
(define ((parse-rhs mode) rhs)
(make-rhs (reassign-classes (parse-pattern (rhs-pattern rhs) lang mode))))
(struct-copy
(struct-copy
compiled-lang lang
[lang (map (parse-nt 'grammar) (compiled-lang-lang lang))]
[cclang (map (parse-nt 'cross) (compiled-lang-cclang lang))]))
[delayed-cclang (delay (map (parse-nt 'cross) (compiled-lang-cclang lang)))]))
;; unparse-pattern: parsed-pattern -> pattern
(define unparse-pattern
@ -1051,7 +1069,7 @@
(struct-out class)
(struct-out binder)
(struct-out rg-lang)
(struct-out base-cases)
(struct-out base-cases) base-cases-cross
(struct-out counterexample)
(struct-out exn:fail:redex:test))