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

added a parameter to disable the various caches in redex

Browse Source 
svn: r13024
This commit is contained in:
Robby Findler 2009-01-07 00:54:48 +00:00
parent 090c73647f
commit a5b53c63fc
5 changed files with 1627 additions and 1569 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

448
collects/redex/private/matcher.ss
View File

@ -16,28 +16,30 @@ before the pattern compiler is invoked.
scheme/contract scheme/contract
"underscore-allowed.ss") "underscore-allowed.ss")
(define-struct compiled-pattern (cp)) (define-struct compiled-pattern (cp))
(define count 0) (define count 0)
;; lang = (listof nt) (define caching-enabled? (make-parameter #t))
;; nt = (make-nt sym (listof rhs))
;; rhs = (make-rhs single-pattern (listof var-info??))
;; single-pattern = sexp
(define-struct nt (name rhs) #:inspector (make-inspector))
(define-struct rhs (pattern var-info) #:inspector (make-inspector))
;; var = (make-var sym sexp) ;; lang = (listof nt)
;; patterns are sexps with `var's embedded ;; nt = (make-nt sym (listof rhs))
;; in them. It means to match the ;; rhs = (make-rhs single-pattern (listof var-info??))
;; embedded sexp and return that binding ;; single-pattern = sexp
(define-struct nt (name rhs) #:inspector (make-inspector))
(define-struct rhs (pattern var-info) #:inspector (make-inspector))
;; bindings = (make-bindings (listof rib)) ;; var = (make-var sym sexp)
;; rib = (make-bind sym sexp) ;; patterns are sexps with `var's embedded
;; if a rib has a pair, the first element of the pair should be treated as a prefix on the identifer ;; in them. It means to match the
;; NOTE: the bindings may contain mismatch-ribs temporarily, but they are all removed ;; embedded sexp and return that binding
;; by merge-multiples/remove, a helper function called from match-pattern
(define-values (make-bindings bindings-table bindings?) ;; bindings = (make-bindings (listof rib))
;; rib = (make-bind sym sexp)
;; if a rib has a pair, the first element of the pair should be treated as a prefix on the identifer
;; NOTE: the bindings may contain mismatch-ribs temporarily, but they are all removed
;; by merge-multiples/remove, a helper function called from match-pattern
(define-values (make-bindings bindings-table bindings?)
(let () (let ()
(define-struct bindings (table) #:inspector (make-inspector)) ;; for testing, add inspector (define-struct bindings (table) #:inspector (make-inspector)) ;; for testing, add inspector
(values (lambda (table) (values (lambda (table)
@ -48,16 +50,16 @@ before the pattern compiler is invoked.
bindings-table bindings-table
bindings?))) bindings?)))
(define-struct bind (name exp) #:inspector (make-inspector)) ;; for testing, add inspector (define-struct bind (name exp) #:inspector (make-inspector)) ;; for testing, add inspector
(define-struct mismatch-bind (name exp) #:inspector (make-inspector)) ;; for testing, add inspector (define-struct mismatch-bind (name exp) #:inspector (make-inspector)) ;; for testing, add inspector
;; repeat = (make-repeat compiled-pattern (listof rib) (union #f symbol) boolean) ;; repeat = (make-repeat compiled-pattern (listof rib) (union #f symbol) boolean)
(define-struct repeat (pat empty-bindings suffix mismatch?) #:inspector (make-inspector)) ;; inspector for tests below (define-struct repeat (pat empty-bindings suffix mismatch?) #:inspector (make-inspector)) ;; inspector for tests below
;; compiled-pattern : exp (union #f none sym) -> (union #f (listof mtch)) ;; compiled-pattern : exp (union #f none sym) -> (union #f (listof mtch))
;; mtch = (make-mtch bindings sexp[context w/none-inside for the hole] (union none sexp[hole])) ;; mtch = (make-mtch bindings sexp[context w/none-inside for the hole] (union none sexp[hole]))
;; mtch is short for "match" ;; mtch is short for "match"
(define-values (mtch-bindings mtch-context mtch-hole make-mtch mtch?) (define-values (mtch-bindings mtch-context mtch-hole make-mtch mtch?)
(let () (let ()
(define-struct mtch (bindings context hole) #:inspector (make-inspector)) (define-struct mtch (bindings context hole) #:inspector (make-inspector))
(values mtch-bindings (values mtch-bindings
@ -69,33 +71,33 @@ before the pattern compiler is invoked.
(make-mtch a b c)) (make-mtch a b c))
mtch?))) mtch?)))
;; used to mean no context is available; also used as the "name" for an unnamed (ie, normal) hole ;; used to mean no context is available; also used as the "name" for an unnamed (ie, normal) hole
(define none (define none
(let () (let ()
(define-struct none ()) (define-struct none ())
(make-none))) (make-none)))
(define (none? x) (eq? x none)) (define (none? x) (eq? x none))
;; compiled-lang : (make-compiled-lang (listof nt) ;; compiled-lang : (make-compiled-lang (listof nt)
;; hash[sym -o> compiled-pattern] ;; hash[sym -o> compiled-pattern]
;; hash[sym -o> compiled-pattern] ;; hash[sym -o> compiled-pattern]
;; hash[sym -o> compiled-pattern] ;; hash[sym -o> compiled-pattern]
;; hash[sym -o> boolean]) ;; hash[sym -o> boolean])
;; hash[sexp[pattern] -o> (cons compiled-pattern boolean)] ;; hash[sexp[pattern] -o> (cons compiled-pattern boolean)]
;; hash[sexp[pattern] -o> (cons compiled-pattern boolean)] ;; hash[sexp[pattern] -o> (cons compiled-pattern boolean)]
;; pict-builder ;; pict-builder
;; (listof symbol) ;; (listof symbol)
;; (listof (listof symbol))) -- keeps track of `primary' non-terminals ;; (listof (listof symbol))) -- keeps track of `primary' non-terminals
;; hole-info = (union #f none) ;; hole-info = (union #f none)
;; #f means we're not in a `in-hole' context ;; #f means we're not in a `in-hole' context
;; none means we're looking for a hole ;; none means we're looking for a hole
(define-struct compiled-lang (lang cclang ht list-ht across-ht across-list-ht (define-struct compiled-lang (lang cclang ht list-ht across-ht across-list-ht
has-hole-ht cache bind-names-cache pict-builder has-hole-ht cache bind-names-cache pict-builder
literals nt-map)) literals nt-map))
;; lookup-binding : bindings (union sym (cons sym sym)) [(-> any)] -> any ;; lookup-binding : bindings (union sym (cons sym sym)) [(-> any)] -> any
(define (lookup-binding bindings (define (lookup-binding bindings
sym sym
[fail (lambda () [fail (lambda ()
(error 'lookup-binding "didn't find ~e in ~e" sym bindings))]) (error 'lookup-binding "didn't find ~e in ~e" sym bindings))])
@ -108,8 +110,8 @@ before the pattern compiler is invoked.
(bind-exp rib) (bind-exp rib)
(loop (cdr ribs))))]))) (loop (cdr ribs))))])))
;; compile-language : language-pict-info[see pict.ss] (listof nt) (listof (listof sym)) -> compiled-lang ;; compile-language : language-pict-info[see pict.ss] (listof nt) (listof (listof sym)) -> compiled-lang
(define (compile-language pict-info lang nt-map) (define (compile-language pict-info lang nt-map)
(let* ([clang-ht (make-hasheq)] (let* ([clang-ht (make-hasheq)]
[clang-list-ht (make-hasheq)] [clang-list-ht (make-hasheq)]
[across-ht (make-hasheq)] [across-ht (make-hasheq)]
@ -175,8 +177,8 @@ before the pattern compiler is invoked.
(do-compilation across-ht across-list-ht compatible-context-language #f) (do-compilation across-ht across-list-ht compatible-context-language #f)
(struct-copy compiled-lang clang [cclang compatible-context-language])))) (struct-copy compiled-lang clang [cclang compatible-context-language]))))
;; extract-literals : (listof nt) -> (listof symbol) ;; extract-literals : (listof nt) -> (listof symbol)
(define (extract-literals nts) (define (extract-literals nts)
(let ([literals-ht (make-hasheq)] (let ([literals-ht (make-hasheq)]
[nt-names (map nt-name nts)]) [nt-names (map nt-name nts)])
(for-each (λ (nt) (for-each (λ (nt)
@ -185,9 +187,9 @@ before the pattern compiler is invoked.
nts) nts)
(hash-map literals-ht (λ (x y) x)))) (hash-map literals-ht (λ (x y) x))))
;; extract-literals/pat : (listof sym) pattern ht -> void ;; extract-literals/pat : (listof sym) pattern ht -> void
;; inserts the literals mentioned in pat into ht ;; inserts the literals mentioned in pat into ht
(define (extract-literals/pat nts pat ht) (define (extract-literals/pat nts pat ht)
(let loop ([pat pat]) (let loop ([pat pat])
(match pat (match pat
[`any (void)] [`any (void)]
@ -217,9 +219,9 @@ before the pattern compiler is invoked.
(loop (car l-pat)) (loop (car l-pat))
(l-loop (cdr l-pat))))]))) (l-loop (cdr l-pat))))])))
; build-has-hole-ht : (listof nt) -> hash[symbol -o> boolean] ; build-has-hole-ht : (listof nt) -> hash[symbol -o> boolean]
; produces a map of nonterminal -> whether that nonterminal could produce a hole ; produces a map of nonterminal -> whether that nonterminal could produce a hole
(define (build-has-hole-ht lang) (define (build-has-hole-ht lang)
(build-nt-property (build-nt-property
lang lang
(lambda (pattern recur) (lambda (pattern recur)
@ -249,9 +251,9 @@ before the pattern compiler is invoked.
#t #t
(lambda (lst) (ormap values lst)))) (lambda (lst) (ormap values lst))))
;; build-nt-property : lang (pattern[not-non-terminal] (pattern -> boolean) -> boolean) boolean ;; build-nt-property : lang (pattern[not-non-terminal] (pattern -> boolean) -> boolean) boolean
;; -> hash[symbol[nt] -> boolean] ;; -> hash[symbol[nt] -> boolean]
(define (build-nt-property lang test-rhs conservative-answer combine-rhss) (define (build-nt-property lang test-rhs conservative-answer combine-rhss)
(let ([ht (make-hasheq)] (let ([ht (make-hasheq)]
[rhs-ht (make-hasheq)]) [rhs-ht (make-hasheq)])
(for-each (for-each
@ -281,8 +283,8 @@ before the pattern compiler is invoked.
lang) lang)
ht))) ht)))
;; build-compatible-context-language : lang -> lang ;; build-compatible-context-language : lang -> lang
(define (build-compatible-context-language clang-ht lang) (define (build-compatible-context-language clang-ht lang)
(remove-empty-compatible-contexts (remove-empty-compatible-contexts
(apply (apply
append append
@ -300,10 +302,10 @@ before the pattern compiler is invoked.
lang)) lang))
lang)))) lang))))
;; remove-empty-compatible-contexts : lang -> lang ;; remove-empty-compatible-contexts : lang -> lang
;; Removes the empty compatible context non-terminals and the ;; Removes the empty compatible context non-terminals and the
;; rhss that reference them. ;; rhss that reference them.
(define (remove-empty-compatible-contexts lang) (define (remove-empty-compatible-contexts lang)
(define (has-cross? pattern crosses) (define (has-cross? pattern crosses)
(match pattern (match pattern
[`(cross ,(? symbol? nt)) (memq nt crosses)] [`(cross ,(? symbol? nt)) (memq nt crosses)]
@ -329,9 +331,9 @@ before the pattern compiler is invoked.
kept kept
(loop (delete-references (map nt-name deleted) kept)))))) (loop (delete-references (map nt-name deleted) kept))))))
;; build-compatible-contexts : clang-ht prefix nt -> nt ;; build-compatible-contexts : clang-ht prefix nt -> nt
;; constructs the compatible closure evaluation context from nt. ;; constructs the compatible closure evaluation context from nt.
(define (build-compatible-contexts/nt clang-ht prefix nt) (define (build-compatible-contexts/nt clang-ht prefix nt)
(make-nt (make-nt
(symbol-append prefix '- (nt-name nt)) (symbol-append prefix '- (nt-name nt))
(apply append (apply append
@ -348,11 +350,11 @@ before the pattern compiler is invoked.
(loop (- i 1))))])))) (loop (- i 1))))]))))
(nt-rhs nt))))) (nt-rhs nt)))))
(define (symbol-append . args) (define (symbol-append . args)
(string->symbol (apply string-append (map symbol->string args)))) (string->symbol (apply string-append (map symbol->string args))))
;; build-across-nts : symbol number number -> (listof pattern) ;; build-across-nts : symbol number number -> (listof pattern)
(define (build-across-nts nt count i) (define (build-across-nts nt count i)
(let loop ([j count]) (let loop ([j count])
(cond (cond
[(zero? j) null] [(zero? j) null]
@ -360,12 +362,12 @@ before the pattern compiler is invoked.
(cons (= i (- j 1)) (cons (= i (- j 1))
(loop (- j 1)))]))) (loop (- j 1)))])))
;; build-compatible-context-maker : symbol pattern -> (values ((box (listof pattern)) -> pattern) number) ;; build-compatible-context-maker : symbol pattern -> (values ((box (listof pattern)) -> pattern) number)
;; when the result function is applied, it takes each element ;; when the result function is applied, it takes each element
;; of the of the boxed list and plugs them into the places where ;; of the of the boxed list and plugs them into the places where
;; the nt corresponding from this rhs appeared in the original pattern. ;; the nt corresponding from this rhs appeared in the original pattern.
;; The number result is the number of times that the nt appeared in the pattern. ;; The number result is the number of times that the nt appeared in the pattern.
(define (build-compatible-context-maker clang-ht pattern prefix) (define (build-compatible-context-maker clang-ht pattern prefix)
(let ([count 0]) (let ([count 0])
(values (values
(let loop ([pattern pattern]) (let loop ([pattern pattern])
@ -455,8 +457,8 @@ before the pattern compiler is invoked.
(lambda (l) pattern)])) (lambda (l) pattern)]))
count))) count)))
;; build-list-nt-label : lang -> hash[symbol -o> boolean] ;; build-list-nt-label : lang -> hash[symbol -o> boolean]
(define (build-list-nt-label lang) (define (build-list-nt-label lang)
(build-nt-property (build-nt-property
lang lang
(lambda (pattern recur) (lambda (pattern recur)
@ -466,7 +468,7 @@ before the pattern compiler is invoked.
#t #t
(lambda (lst) (ormap values lst)))) (lambda (lst) (ormap values lst))))
(define (may-be-list-pattern? pattern list-nt-table) (define (may-be-list-pattern? pattern list-nt-table)
(let loop ([pattern pattern]) (let loop ([pattern pattern])
(may-be-list-pattern?/internal (may-be-list-pattern?/internal
pattern pattern
@ -474,7 +476,7 @@ before the pattern compiler is invoked.
(hash-ref list-nt-table (symbol->nt sym) #t)) (hash-ref list-nt-table (symbol->nt sym) #t))
loop))) loop)))
(define (may-be-list-pattern?/internal pattern handle-symbol recur) (define (may-be-list-pattern?/internal pattern handle-symbol recur)
(match pattern (match pattern
[`any #t] [`any #t]
[`number #f] [`number #f]
@ -502,8 +504,8 @@ before the pattern compiler is invoked.
(or (null? pattern) (pair? pattern))])) (or (null? pattern) (pair? pattern))]))
;; build-non-list-nt-label : lang -> hash[symbol -o> boolean] ;; build-non-list-nt-label : lang -> hash[symbol -o> boolean]
(define (build-non-list-nt-label lang) (define (build-non-list-nt-label lang)
(build-nt-property (build-nt-property
lang lang
(lambda (pattern recur) (lambda (pattern recur)
@ -513,7 +515,7 @@ before the pattern compiler is invoked.
#t #t
(lambda (lst) (ormap values lst)))) (lambda (lst) (ormap values lst))))
(define (may-be-non-list-pattern? pattern non-list-nt-table) (define (may-be-non-list-pattern? pattern non-list-nt-table)
(let loop ([pattern pattern]) (let loop ([pattern pattern])
(may-be-non-list-pattern?/internal (may-be-non-list-pattern?/internal
pattern pattern
@ -521,7 +523,7 @@ before the pattern compiler is invoked.
(hash-ref non-list-nt-table (symbol->nt sym) #t)) (hash-ref non-list-nt-table (symbol->nt sym) #t))
loop))) loop)))
(define (may-be-non-list-pattern?/internal pattern handle-sym recur) (define (may-be-non-list-pattern?/internal pattern handle-sym recur)
(match pattern (match pattern
[`any #t] [`any #t]
[`number #t] [`number #t]
@ -547,16 +549,16 @@ before the pattern compiler is invoked.
;; is this right?! ;; is this right?!
(not (or (null? pattern) (pair? pattern)))])) (not (or (null? pattern) (pair? pattern)))]))
;; match-pattern : compiled-pattern exp -> (union #f (listof bindings)) ;; match-pattern : compiled-pattern exp -> (union #f (listof bindings))
(define (match-pattern compiled-pattern exp) (define (match-pattern compiled-pattern exp)
(let ([results ((compiled-pattern-cp compiled-pattern) exp #f)]) (let ([results ((compiled-pattern-cp compiled-pattern) exp #f)])
(and results (and results
(let ([filtered (filter-multiples results)]) (let ([filtered (filter-multiples results)])
(and (not (null? filtered)) (and (not (null? filtered))
filtered))))) filtered)))))
;; filter-multiples : (listof mtch) -> (listof mtch) ;; filter-multiples : (listof mtch) -> (listof mtch)
(define (filter-multiples matches) (define (filter-multiples matches)
(let loop ([matches matches] (let loop ([matches matches]
[acc null]) [acc null])
(cond (cond
@ -567,10 +569,10 @@ before the pattern compiler is invoked.
(loop (cdr matches) (cons merged acc)) (loop (cdr matches) (cons merged acc))
(loop (cdr matches) acc)))]))) (loop (cdr matches) acc)))])))
;; merge-multiples/remove : bindings -> (union #f bindings) ;; merge-multiples/remove : bindings -> (union #f bindings)
;; returns #f if all duplicate bindings don't bind the same thing ;; returns #f if all duplicate bindings don't bind the same thing
;; returns a new bindings ;; returns a new bindings
(define (merge-multiples/remove match) (define (merge-multiples/remove match)
(let/ec fail (let/ec fail
(let ( (let (
;; match-ht : sym -o> sexp ;; match-ht : sym -o> sexp
@ -610,17 +612,17 @@ before the pattern compiler is invoked.
(mtch-context match) (mtch-context match)
(mtch-hole match))))) (mtch-hole match)))))
;; compile-pattern : compiled-lang pattern boolean (listof sym) -> compiled-pattern ;; compile-pattern : compiled-lang pattern boolean (listof sym) -> compiled-pattern
(define (compile-pattern clang pattern bind-names?) (define (compile-pattern clang pattern bind-names?)
(let-values ([(pattern has-hole?) (compile-pattern/cross? clang pattern #t bind-names?)]) (let-values ([(pattern has-hole?) (compile-pattern/cross? clang pattern #t bind-names?)])
(make-compiled-pattern pattern))) (make-compiled-pattern pattern)))
;; name-to-key/binding : hash[symbol -o> key-wrap] ;; name-to-key/binding : hash[symbol -o> key-wrap]
(define name-to-key/binding (make-hasheq)) (define name-to-key/binding (make-hasheq))
(define-struct key-wrap (sym) #:inspector (make-inspector)) (define-struct key-wrap (sym) #:inspector (make-inspector))
;; compile-pattern/cross? : compiled-lang pattern boolean boolean -> (values compiled-pattern boolean) ;; compile-pattern/cross? : compiled-lang pattern boolean boolean -> (values compiled-pattern boolean)
(define (compile-pattern/cross? clang pattern prefix-cross? bind-names?) (define (compile-pattern/cross? clang pattern prefix-cross? bind-names?)
(define clang-ht (compiled-lang-ht clang)) (define clang-ht (compiled-lang-ht clang))
(define clang-list-ht (compiled-lang-list-ht clang)) (define clang-list-ht (compiled-lang-list-ht clang))
(define has-hole-ht (compiled-lang-has-hole-ht clang)) (define has-hole-ht (compiled-lang-has-hole-ht clang))
@ -835,8 +837,8 @@ before the pattern compiler is invoked.
(compile-pattern/default-cache pattern)) (compile-pattern/default-cache pattern))
;; match-named-pat : symbol <compiled-pattern> -> <compiled-pattern> ;; match-named-pat : symbol <compiled-pattern> -> <compiled-pattern>
(define (match-named-pat name match-pat) (define (match-named-pat name match-pat)
(let ([mismatch-bind? (regexp-match #rx"_!_" (symbol->string name))]) (let ([mismatch-bind? (regexp-match #rx"_!_" (symbol->string name))])
(lambda (exp hole-info) (lambda (exp hole-info)
(let ([matches (match-pat exp hole-info)]) (let ([matches (match-pat exp hole-info)])
@ -851,10 +853,10 @@ before the pattern compiler is invoked.
(mtch-hole match))) (mtch-hole match)))
matches)))))) matches))))))
;; split-underscore : symbol -> symbol ;; split-underscore : symbol -> symbol
;; returns the text before the underscore in a symbol (as a symbol) ;; returns the text before the underscore in a symbol (as a symbol)
;; raise an error if there is more than one underscore in the input ;; raise an error if there is more than one underscore in the input
(define (split-underscore sym) (define (split-underscore sym)
(let ([str (symbol->string sym)]) (let ([str (symbol->string sym)])
(cond (cond
[(regexp-match #rx"^([^_]*)_[^_]*$" str) [(regexp-match #rx"^([^_]*)_[^_]*$" str)
@ -866,38 +868,40 @@ before the pattern compiler is invoked.
[else [else
(error 'compile-pattern "found a symbol with multiple underscores: ~s" sym)]))) (error 'compile-pattern "found a symbol with multiple underscores: ~s" sym)])))
;; has-underscore? : symbol -> boolean ;; has-underscore? : symbol -> boolean
(define (has-underscore? sym) (define (has-underscore? sym)
(memq #\_ (string->list (symbol->string sym)))) (memq #\_ (string->list (symbol->string sym))))
;; symbol->nt : symbol -> symbol ;; symbol->nt : symbol -> symbol
;; strips the trailing underscore from a symbol, if one is there. ;; strips the trailing underscore from a symbol, if one is there.
(define (symbol->nt sym) (define (symbol->nt sym)
(cond (cond
[(has-underscore? sym) [(has-underscore? sym)
(split-underscore sym)] (split-underscore sym)]
[else sym])) [else sym]))
(define (memoize f needs-all-args?) (define (memoize f needs-all-args?)
(if needs-all-args? (if needs-all-args?
(memoize2 f) (memoize2 f)
(memoize1 f))) (memoize1 f)))
; memoize1 : (x y -> w) -> x y -> w ; memoize1 : (x y -> w) -> x y -> w
; memoizes a function of two arguments under the assumption ; memoizes a function of two arguments under the assumption
; that the function is constant w.r.t the second ; that the function is constant w.r.t the second
(define (memoize1 f) (memoize/key f (lambda (x y) x) nohole)) (define (memoize1 f) (memoize/key f (lambda (x y) x) nohole))
(define (memoize2 f) (memoize/key f cons w/hole)) (define (memoize2 f) (memoize/key f cons w/hole))
(define cache-size 350) (define cache-size 350)
(define (set-cache-size! cs) (set! cache-size cs)) (define (set-cache-size! cs) (set! cache-size cs))
;; original version, but without closure allocation in hash lookup ;; original version, but without closure allocation in hash lookup
(define (memoize/key f key-fn statsbox) (define (memoize/key f key-fn statsbox)
(let ([ht (make-hash)] (let ([ht (make-hash)]
[entries 0]) [entries 0])
(lambda (x y) (lambda (x y)
(if cache-size (cond
[(not (caching-enabled?)) (f x y)]
[else
(let* ([key (key-fn x y)]) (let* ([key (key-fn x y)])
;(record-cache-test! statsbox) ;(record-cache-test! statsbox)
(unless (< entries cache-size) (unless (< entries cache-size)
@ -912,12 +916,11 @@ before the pattern compiler is invoked.
(hash-set! ht key res) (hash-set! ht key res)
res)] res)]
[else [else
ans]))) ans])))]))))
(f x y)))))
;; hash version, but with an extra hash that tells when to evict cache entries ;; hash version, but with an extra hash that tells when to evict cache entries
#; #;
(define (memoize/key f key-fn statsbox) (define (memoize/key f key-fn statsbox)
(let* ([cache-size 50] (let* ([cache-size 50]
[ht (make-hash)] [ht (make-hash)]
[uniq (gensym)] [uniq (gensym)]
@ -941,10 +944,10 @@ before the pattern compiler is invoked.
[else [else
value-in-cache]))))) value-in-cache])))))
;; lru cache ;; lru cache
;; for some reason, this seems to hit *less* than the "just dump stuff out" strategy! ;; for some reason, this seems to hit *less* than the "just dump stuff out" strategy!
#; #;
(define (memoize/key f key-fn statsbox) (define (memoize/key f key-fn statsbox)
(let* ([cache-size 50] (let* ([cache-size 50]
[cache '()]) [cache '()])
(lambda (x y) (lambda (x y)
@ -1009,9 +1012,9 @@ before the pattern compiler is invoked.
;; didnt hit yet, continue searchign ;; didnt hit yet, continue searchign
(loop previous1 current (cdr current) (+ i 1))]))]))])]))))) (loop previous1 current (cdr current) (+ i 1))]))]))])])))))
;; hash version, but with a vector that tells when to evict cache entries ;; hash version, but with a vector that tells when to evict cache entries
#; #;
(define (memoize/key f key-fn statsbox) (define (memoize/key f key-fn statsbox)
(let* ([cache-size 50] (let* ([cache-size 50]
[ht (make-hash)] [ht (make-hash)]
[uniq (gensym)] [uniq (gensym)]
@ -1033,9 +1036,9 @@ before the pattern compiler is invoked.
[else [else
value-in-cache]))))) value-in-cache])))))
;; vector-based version, with a cleverer replacement strategy ;; vector-based version, with a cleverer replacement strategy
#; #;
(define (memoize/key f key-fn statsbox) (define (memoize/key f key-fn statsbox)
(let* ([cache-size 20] (let* ([cache-size 20]
;; cache : (vector-of (union #f (cons key val))) ;; cache : (vector-of (union #f (cons key val)))
;; the #f correspond to empty spots in the cache ;; the #f correspond to empty spots in the cache
@ -1066,9 +1069,9 @@ before the pattern compiler is invoked.
;; if we hit a #f, just skip ahead and store this in the cache ;; if we hit a #f, just skip ahead and store this in the cache
(loop cache-size)))])))))) (loop cache-size)))]))))))
;; original version ;; original version
#; #;
(define (memoize/key f key-fn statsbox) (define (memoize/key f key-fn statsbox)
(let ([ht (make-hash)] (let ([ht (make-hash)]
[entries 0]) [entries 0])
(lambda (x y) (lambda (x y)
@ -1086,20 +1089,20 @@ before the pattern compiler is invoked.
(set! ht (make-hash))) (set! ht (make-hash)))
(hash-ref ht key compute/cache))))) (hash-ref ht key compute/cache)))))
(define (record-cache-miss! statsbox) (define (record-cache-miss! statsbox)
(set-cache-stats-hits! statsbox (sub1 (cache-stats-hits statsbox))) (set-cache-stats-hits! statsbox (sub1 (cache-stats-hits statsbox)))
(set-cache-stats-misses! statsbox (add1 (cache-stats-misses statsbox)))) (set-cache-stats-misses! statsbox (add1 (cache-stats-misses statsbox))))
(define (record-cache-test! statsbox) (define (record-cache-test! statsbox)
(set-cache-stats-hits! statsbox (add1 (cache-stats-hits statsbox)))) (set-cache-stats-hits! statsbox (add1 (cache-stats-hits statsbox))))
(define-struct cache-stats (name misses hits) #:mutable) (define-struct cache-stats (name misses hits) #:mutable)
(define (new-cache-stats name) (make-cache-stats name 0 0)) (define (new-cache-stats name) (make-cache-stats name 0 0))
(define w/hole (new-cache-stats "hole")) (define w/hole (new-cache-stats "hole"))
(define nohole (new-cache-stats "no-hole")) (define nohole (new-cache-stats "no-hole"))
(define (print-stats) (define (print-stats)
(let ((stats (list w/hole nohole))) (let ((stats (list w/hole nohole)))
(for-each (for-each
(lambda (s) (lambda (s)
@ -1120,8 +1123,8 @@ before the pattern compiler is invoked.
(printf "Overall miss rate: ~a%\n" (printf "Overall miss rate: ~a%\n"
(floor (* 100 (/ overall-miss (+ overall-hits overall-miss))))))))) (floor (* 100 (/ overall-miss (+ overall-hits overall-miss)))))))))
;; match-hole : (union none symbol) -> compiled-pattern ;; match-hole : (union none symbol) -> compiled-pattern
(define (match-hole hole-id) (define (match-hole hole-id)
(let ([mis-matched-hole (let ([mis-matched-hole
(λ (exp) (λ (exp)
(and (hole? exp) (and (hole? exp)
@ -1137,8 +1140,8 @@ before the pattern compiler is invoked.
(mis-matched-hole exp)) (mis-matched-hole exp))
(mis-matched-hole exp))))) (mis-matched-hole exp)))))
;; match-in-hole : sexp sexp sexp compiled-pattern compiled-pattern hole-info -> compiled-pattern ;; match-in-hole : sexp sexp sexp compiled-pattern compiled-pattern hole-info -> compiled-pattern
(define (match-in-hole context contractum exp match-context match-contractum hole-info) (define (match-in-hole context contractum exp match-context match-contractum hole-info)
(lambda (exp old-hole-info) (lambda (exp old-hole-info)
(let ([mtches (match-context exp hole-info)]) (let ([mtches (match-context exp hole-info)])
(and mtches (and mtches
@ -1174,8 +1177,8 @@ before the pattern compiler is invoked.
acc)))])) acc)))]))
(loop (cdr mtches) acc)))])))))) (loop (cdr mtches) acc)))]))))))
;; match-list : (listof (union repeat compiled-pattern)) sexp hole-info -> (union #f (listof bindings)) ;; match-list : (listof (union repeat compiled-pattern)) sexp hole-info -> (union #f (listof bindings))
(define (match-list patterns exp hole-info) (define (match-list patterns exp hole-info)
(let (;; raw-match : (listof (listof (listof mtch))) (let (;; raw-match : (listof (listof (listof mtch)))
[raw-match (match-list/raw patterns exp hole-info)]) [raw-match (match-list/raw patterns exp hole-info)])
@ -1192,18 +1195,18 @@ before the pattern compiler is invoked.
(apply append combined-matches))]) (apply append combined-matches))])
flattened-matches)))) flattened-matches))))
;; match-list/raw : (listof (union repeat compiled-pattern)) ;; match-list/raw : (listof (union repeat compiled-pattern))
;; sexp ;; sexp
;; hole-info ;; hole-info
;; -> (listof (listof (listof mtch))) ;; -> (listof (listof (listof mtch)))
;; the result is the raw accumulation of the matches for each subpattern, as follows: ;; the result is the raw accumulation of the matches for each subpattern, as follows:
;; (listof (listof (listof mtch))) ;; (listof (listof (listof mtch)))
;; \ \ \-------------/ a match for one position in the list (failures don't show up) ;; \ \ \-------------/ a match for one position in the list (failures don't show up)
;; \ \-------------------/ one element for each position in the pattern list ;; \ \-------------------/ one element for each position in the pattern list
;; \-------------------------/ one element for different expansions of the ellipses ;; \-------------------------/ one element for different expansions of the ellipses
;; the failures to match are just removed from the outer list before this function finishes ;; the failures to match are just removed from the outer list before this function finishes
;; via the `fail' argument to `loop'. ;; via the `fail' argument to `loop'.
(define (match-list/raw patterns exp hole-info) (define (match-list/raw patterns exp hole-info)
(let/ec k (let/ec k
(let loop ([patterns patterns] (let loop ([patterns patterns]
[exp exp] [exp exp]
@ -1280,8 +1283,8 @@ before the pattern compiler is invoked.
(list null) (list null)
(fail))])))) (fail))]))))
;; add-ellipses-index : (listof mtch) sym boolean number -> (listof mtch) ;; add-ellipses-index : (listof mtch) sym boolean number -> (listof mtch)
(define (add-ellipses-index mtchs key mismatch-bind? i) (define (add-ellipses-index mtchs key mismatch-bind? i)
(if key (if key
(let ([rib (if mismatch-bind? (let ([rib (if mismatch-bind?
(make-mismatch-bind key i) (make-mismatch-bind key i)
@ -1292,8 +1295,8 @@ before the pattern compiler is invoked.
mtchs)) mtchs))
mtchs)) mtchs))
;; collapse-single-multiples : (listof mtch) (listof mtch[to-lists]) -> (listof mtch[to-lists]) ;; collapse-single-multiples : (listof mtch) (listof mtch[to-lists]) -> (listof mtch[to-lists])
(define (collapse-single-multiples bindingss multiple-bindingss) (define (collapse-single-multiples bindingss multiple-bindingss)
(apply append (apply append
(map (map
(lambda (multiple-match) (lambda (multiple-match)
@ -1333,16 +1336,16 @@ before the pattern compiler is invoked.
bindingss))) bindingss)))
multiple-bindingss))) multiple-bindingss)))
;; pick-hole : (union none sexp) (union none sexp) -> (union none sexp) ;; pick-hole : (union none sexp) (union none sexp) -> (union none sexp)
(define (pick-hole s1 s2) (define (pick-hole s1 s2)
(cond (cond
[(eq? none s1) s2] [(eq? none s1) s2]
[(eq? none s2) s1] [(eq? none s2) s1]
[(error 'matcher.ss "found two holes")])) [(error 'matcher.ss "found two holes")]))
;; reverse-multiples : (listof mtch[to-lists]) -> (listof mtch[to-lists]) ;; reverse-multiples : (listof mtch[to-lists]) -> (listof mtch[to-lists])
;; reverses the rhs of each rib in the bindings and reverses the context. ;; reverses the rhs of each rib in the bindings and reverses the context.
(define (reverse-multiples matches) (define (reverse-multiples matches)
(map (lambda (match) (map (lambda (match)
(let ([bindings (mtch-bindings match)]) (let ([bindings (mtch-bindings match)])
(make-mtch (make-mtch
@ -1360,9 +1363,9 @@ before the pattern compiler is invoked.
(mtch-hole match)))) (mtch-hole match))))
matches)) matches))
;; match-nt : (listof compiled-rhs) (listof compiled-rhs) sym exp hole-info ;; match-nt : (listof compiled-rhs) (listof compiled-rhs) sym exp hole-info
;; -> (union #f (listof bindings)) ;; -> (union #f (listof bindings))
(define (match-nt list-rhs non-list-rhs nt term hole-info) (define (match-nt list-rhs non-list-rhs nt term hole-info)
(let loop ([rhss (if (or (null? term) (pair? term)) (let loop ([rhss (if (or (null? term) (pair? term))
list-rhs list-rhs
non-list-rhs)] non-list-rhs)]
@ -1382,8 +1385,8 @@ before the pattern compiler is invoked.
[else [else
(loop (cdr rhss) ht)]))]))) (loop (cdr rhss) ht)]))])))
;; remove-bindings/filter : (union #f (listof mtch)) -> (union #f (listof mtch)) ;; remove-bindings/filter : (union #f (listof mtch)) -> (union #f (listof mtch))
(define (remove-bindings/filter matches) (define (remove-bindings/filter matches)
(and matches (and matches
(let ([filtered (filter-multiples matches)]) (let ([filtered (filter-multiples matches)])
(and (not (null? filtered)) (and (not (null? filtered))
@ -1393,12 +1396,12 @@ before the pattern compiler is invoked.
(mtch-hole match))) (mtch-hole match)))
matches))))) matches)))))
;; rewrite-ellipses : (symbol -> boolean) ;; rewrite-ellipses : (symbol -> boolean)
;; (listof pattern) ;; (listof pattern)
;; (pattern -> (values compiled-pattern boolean)) ;; (pattern -> (values compiled-pattern boolean))
;; -> (values (listof (union repeat compiled-pattern)) boolean) ;; -> (values (listof (union repeat compiled-pattern)) boolean)
;; moves the ellipses out of the list and produces repeat structures ;; moves the ellipses out of the list and produces repeat structures
(define (rewrite-ellipses non-underscore-binder? pattern compile) (define (rewrite-ellipses non-underscore-binder? pattern compile)
(let loop ([exp-eles pattern] (let loop ([exp-eles pattern]
[fst dummy]) [fst dummy])
(cond (cond
@ -1431,7 +1434,7 @@ before the pattern compiler is invoked.
(cons compiled rest) (cons compiled rest)
(or has-hole? rest-has-hole?)))]))]))) (or has-hole? rest-has-hole?)))]))])))
(define (prefixed-with? prefix exp) (define (prefixed-with? prefix exp)
(and (symbol? exp) (and (symbol? exp)
(let* ([str (symbol->string exp)] (let* ([str (symbol->string exp)]
[len (string-length str)]) [len (string-length str)])
@ -1439,10 +1442,10 @@ before the pattern compiler is invoked.
(string=? (substring str 0 (string-length prefix)) (string=? (substring str 0 (string-length prefix))
prefix))))) prefix)))))
(define dummy (box 0)) (define dummy (box 0))
;; extract-empty-bindings : (symbol -> boolean) pattern -> (listof rib) ;; extract-empty-bindings : (symbol -> boolean) pattern -> (listof rib)
(define (extract-empty-bindings non-underscore-binder? pattern) (define (extract-empty-bindings non-underscore-binder? pattern)
(let loop ([pattern pattern] (let loop ([pattern pattern]
[ribs null]) [ribs null])
(match pattern (match pattern
@ -1484,17 +1487,17 @@ before the pattern compiler is invoked.
(loop (car r-exps) ribs))]))])))] (loop (car r-exps) ribs))]))])))]
[else ribs]))) [else ribs])))
;; combine-matches : (listof (listof mtch)) -> (listof mtch) ;; combine-matches : (listof (listof mtch)) -> (listof mtch)
;; input is the list of bindings corresonding to a piecewise match ;; input is the list of bindings corresonding to a piecewise match
;; of a list. produces all of the combinations of complete matches ;; of a list. produces all of the combinations of complete matches
(define (combine-matches matchess) (define (combine-matches matchess)
(let loop ([matchess matchess]) (let loop ([matchess matchess])
(cond (cond
[(null? matchess) (list (make-mtch (make-bindings null) (build-flat-context '()) none))] [(null? matchess) (list (make-mtch (make-bindings null) (build-flat-context '()) none))]
[else (combine-pair (car matchess) (loop (cdr matchess)))]))) [else (combine-pair (car matchess) (loop (cdr matchess)))])))
;; combine-pair : (listof mtch) (listof mtch) -> (listof mtch) ;; combine-pair : (listof mtch) (listof mtch) -> (listof mtch)
(define (combine-pair fst snd) (define (combine-pair fst snd)
(let ([mtchs null]) (let ([mtchs null])
(for-each (for-each
(lambda (mtch1) (lambda (mtch1)
@ -1511,16 +1514,16 @@ before the pattern compiler is invoked.
fst) fst)
mtchs)) mtchs))
(define (hash-maps? ht key) (define (hash-maps? ht key)
(not (eq? (hash-ref ht key uniq) uniq))) (not (eq? (hash-ref ht key uniq) uniq)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;
;; context adt ;; context adt
;; ;;
#| #|
;; This version of the ADT isn't right yet -- ;; This version of the ADT isn't right yet --
;; need to figure out what to do about (name ...) patterns. ;; need to figure out what to do about (name ...) patterns.
@ -1536,21 +1539,21 @@ before the pattern compiler is invoked.
(define (reverse-context c) (make-context (lambda (x) (reverse (c x))))) (define (reverse-context c) (make-context (lambda (x) (reverse (c x)))))
|# |#
(define (context? x) #t) (define (context? x) #t)
(define-values (the-hole hole?) (define-values (the-hole hole?)
(let () (let ()
(define-struct hole () #:inspector #f) (define-struct hole () #:inspector #f)
(define the-hole (make-hole)) (define the-hole (make-hole))
(values the-hole hole?))) (values the-hole hole?)))
(define (build-flat-context exp) exp) (define (build-flat-context exp) exp)
(define (build-cons-context e1 e2) (cons e1 e2)) (define (build-cons-context e1 e2) (cons e1 e2))
(define (build-append-context e1 e2) (append e1 e2)) (define (build-append-context e1 e2) (append e1 e2))
(define (build-list-context x) (list x)) (define (build-list-context x) (list x))
(define (reverse-context x) (reverse x)) (define (reverse-context x) (reverse x))
(define (build-nested-context c1 c2 hole-info) (define (build-nested-context c1 c2 hole-info)
(plug c1 c2 hole-info)) (plug c1 c2 hole-info))
(define plug (define plug
(case-lambda (case-lambda
[(exp hole-stuff) (plug exp hole-stuff none)] [(exp hole-stuff) (plug exp hole-stuff none)]
[(exp hole-stuff hole-info) [(exp hole-stuff hole-info)
@ -1568,20 +1571,20 @@ before the pattern compiler is invoked.
hole-stuff] hole-stuff]
[else exp])))])) [else exp])))]))
;; ;;
;; end context adt ;; end context adt
;; ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; used in hash lookups to tell when something isn't in the table ;; used in hash lookups to tell when something isn't in the table
(define uniq (gensym)) (define uniq (gensym))
(provide/contract (provide/contract
(match-pattern (compiled-pattern? any/c . -> . (or/c false/c (listof mtch?)))) (match-pattern (compiled-pattern? any/c . -> . (or/c false/c (listof mtch?))))
(compile-pattern (-> compiled-lang? any/c boolean? (compile-pattern (-> compiled-lang? any/c boolean?
compiled-pattern?)) compiled-pattern?))
(set-cache-size! (-> (or/c false/c (and/c integer? positive?)) void?)) (set-cache-size! (-> (and/c integer? positive?) void?))
(make-bindings ((listof bind?) . -> . bindings?)) (make-bindings ((listof bind?) . -> . bindings?))
(bindings-table (bindings? . -> . (listof bind?))) (bindings-table (bindings? . -> . (listof bind?)))
@ -1601,15 +1604,15 @@ before the pattern compiler is invoked.
(symbol->nt (symbol? . -> . symbol?)) (symbol->nt (symbol? . -> . symbol?))
(has-underscore? (symbol? . -> . boolean?)) (has-underscore? (symbol? . -> . boolean?))
(split-underscore (symbol? . -> . symbol?))) (split-underscore (symbol? . -> . symbol?)))
(provide compiled-pattern? (provide compiled-pattern?
print-stats) print-stats)
;; for test suite ;; for test suite
(provide build-cons-context (provide build-cons-context
build-flat-context build-flat-context
context?) context?)
(provide (struct-out nt) (provide (struct-out nt)
(struct-out rhs) (struct-out rhs)
(struct-out compiled-lang) (struct-out compiled-lang)
@ -1623,4 +1626,5 @@ before the pattern compiler is invoked.
make-repeat make-repeat
the-hole hole? the-hole hole?
rewrite-ellipses rewrite-ellipses
build-compatible-context-language) build-compatible-context-language
caching-enabled?)

2
collects/redex/private/reduction-semantics.ss
View File

@ -1136,7 +1136,7 @@
(λ (exp) (λ (exp)
(let ([cache-ref (hash-ref cache exp not-in-cache)]) (let ([cache-ref (hash-ref cache exp not-in-cache)])
(cond (cond
[(eq? cache-ref not-in-cache) [(or (not (caching-enabled?)) (eq? cache-ref not-in-cache))
(when dom-compiled-pattern (when dom-compiled-pattern
(unless (match-pattern dom-compiled-pattern exp) (unless (match-pattern dom-compiled-pattern exp)
(redex-error name (redex-error name

39
collects/redex/private/tl-test.ss
View File

@ -195,6 +195,45 @@
#t)) #t))
;; test caching
(let ()
(define match? #t)
(define-language lang
(x (side-condition any match?)))
(test (pair? (redex-match lang x 1)) #t)
(set! match? #f)
(test (pair? (redex-match lang x 1)) #t)
(parameterize ([caching-enabled? #f])
(test (pair? (redex-match lang x 1)) #f)))
(let ()
(define sc-eval-count 0)
(define-language lang
(x (side-condition any (begin (set! sc-eval-count (+ sc-eval-count 1))
#t))))
(redex-match lang x 1)
(redex-match lang x 1)
(parameterize ([caching-enabled? #f])
(redex-match lang x 1))
(test sc-eval-count 2))
(let ()
(define rhs-eval-count 0)
(define-metafunction empty-language
[(f any) ,(begin (set! rhs-eval-count (+ rhs-eval-count 1))
1)])
(term (f 1))
(term (f 1))
(parameterize ([caching-enabled? #f])
(term (f 1)))
(test rhs-eval-count 2))
; ;
; ;
; ;;; ; ; ;;; ;

31
collects/redex/redex.scrbl
View File

@ -328,16 +328,28 @@ clause is followed by an ellipsis. Nested ellipses produce
nested lists. nested lists.
} }
@defproc[(set-cache-size! [size (or/c false/c positive-integer?)]) void?]{ @defproc[(set-cache-size! [size positive-integer?]) void?]{
Changes the cache size; a #f disables the cache Changes the cache size; the default size is @scheme[350].
entirely. The default size is 350.
The cache is per-pattern (ie, each pattern has a cache of The cache is per-pattern (ie, each pattern has a cache of size at most
size at most 350 (by default)) and is a simple table that 350 (by default)) and is a simple table that maps expressions to how
maps expressions to how they matched the pattern. When the they matched the pattern (ie, the bindings for the pattern
cache gets full, it is thrown away and a new cache is variables). When the cache gets full, it is thrown away and a new
started. cache is started.
}
@defparam[caching-enabled? on? boolean?]{
This is a parameter that controls whether or not a cache
is consulted (and updated) while matching and while evaluating
metafunctions.
If it is @scheme[#t], then side-conditions and the right-hand sides
of metafunctions are assumed to only depend on the values of the
pattern variables in scope (and thus not on any other external
state).
Defaults to @scheme[#t].
} }
@section{Terms} @section{Terms}
@ -859,7 +871,8 @@ no clauses match, if one of the clauses matches multiple ways, or
if the contract is violated. if the contract is violated.
Note that metafunctions are assumed to always return the same results Note that metafunctions are assumed to always return the same results
for the same inputs, and their results are cached. Accordingly, if a for the same inputs, and their results are cached, unless
@scheme[caching-enable?] is set to @scheme[#f]. Accordingly, if a
metafunction is called with the same inputs twice, then its body is metafunction is called with the same inputs twice, then its body is
only evaluated a single time. only evaluated a single time.

4
collects/redex/reduction-semantics.ss
View File

@ -29,7 +29,9 @@
define-metafunction define-metafunction
define-metafunction/extension define-metafunction/extension
metafunction metafunction
in-domain?) in-domain?
caching-enabled?)
(provide (rename-out [test-match redex-match]) (provide (rename-out [test-match redex-match])
term-match term-match