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