b068d9583c
For the curious, this was an attempt to change the way context matching works. Currently, when matching a pattern, if 'hole' is encountered, the match succeeds and the result just includes the term at that point. This means that when matching (in-hole p1 p2), p1 generally returns multiple results and then those results are thinned out by matching p2 against the thing actually at the hole. Instead, one could pass along the function that does the matching and then, when matching a hole pattern, it could decide right at that point whether or not the match works. This seems like it would be a win overall, but it interferes with caching. Specifically, most reduction systems have lots of rules that all begin (--> (in-hole E ...) ...) and, in the strategy first described above, that matching can be cached. But in the second, it cannot. Overall, this turns out to be a slight lose in the current version of Redex. Maybe if other things change, however, this tradeoff will change. Revert "IN PROGRESS: more context speedup attempt" This reverts commit0134b8753d. Revert "IN PROGRESS: a possible speed up attempt; match the thing in the hole before returning the context matches instead of afterwards" This reverts commit11059e2b5c.
1974 lines
78 KiB
Racket
1974 lines
78 KiB
Racket
#lang racket/base
|
|
|
|
;; optimization ideas:
|
|
;;
|
|
;; -- jay's idea
|
|
;;
|
|
;; -- when a pattern has no bindings, just use 'and's
|
|
;; and 'or's to check for the match (no allocation)
|
|
;;
|
|
;; -- when a list pattern has only a single repeat,
|
|
;; don't search for matches, just count
|
|
;;
|
|
;; -- need to figure out something to do with patterns
|
|
;; that have multiple ellipses in a sequence. Perhaps try
|
|
;; to look for the fixed parts and then see if the others
|
|
;; will fill in between them?
|
|
;;
|
|
;; -- when a match is unambiguous (and possibly only when
|
|
;; there are no names underneath an ellipsis),
|
|
;; pre-allocate the space to store the result (in a vector)
|
|
;;
|
|
;; -- change the way decomposition matching works to pass down
|
|
;; the pattern to match at the hole and match it there, so
|
|
;; that in situations like this: (in-hole E (+ n_1 n_2))
|
|
;; we don't return all of the bogus matches that show up
|
|
;; by treating the hole as 'any'.
|
|
;;
|
|
;; -- combine the left-hand sides of a reduction relation
|
|
;; so to avoid re-doing decompositions over and over
|
|
;; (maybe....)
|
|
;;
|
|
;; -- parallelism? but what about the hash-table?
|
|
;;
|
|
;; -- double check the caching code to make sure it makes
|
|
;; sense in the current uni-hole world
|
|
|
|
#|
|
|
|
|
Note: the patterns described in the documentation are
|
|
slightly different than the patterns processed here.
|
|
See match-a-pattern.rkt for more details
|
|
|
|
|#
|
|
(require racket/list
|
|
racket/match
|
|
racket/contract
|
|
racket/promise
|
|
racket/performance-hint
|
|
(for-syntax racket/base)
|
|
"underscore-allowed.rkt"
|
|
"match-a-pattern.rkt")
|
|
|
|
(define-struct compiled-pattern (cp binds-names? skip-dup-check?) #:transparent)
|
|
|
|
(define caching-enabled? (make-parameter #t))
|
|
|
|
;; lang = (listof nt)
|
|
;; nt = (make-nt sym (listof rhs))
|
|
;; rhs = (make-rhs single-pattern)
|
|
;; single-pattern = sexp
|
|
(define-struct nt (name rhs) #:transparent)
|
|
(define-struct rhs (pattern) #:transparent)
|
|
|
|
;; 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? empty-bindings)
|
|
(let ()
|
|
(define-struct bindings (table) #:transparent) ;; for testing, add inspector
|
|
(define empty-bindings (make-bindings '()))
|
|
(values (lambda (table) (if (null? table) empty-bindings (make-bindings table)))
|
|
bindings-table
|
|
bindings?
|
|
empty-bindings)))
|
|
|
|
(define-struct bind (name exp) #:transparent)
|
|
(define-struct mismatch-bind (name exp) #:transparent)
|
|
|
|
;; repeat = (make-repeat compiled-pattern (listof rib) (or/c #f symbol?) (or/c #f symbol?))
|
|
(define-struct repeat (pat empty-bindings name mismatch) #:transparent)
|
|
|
|
;; compiled-pattern : exp hole-info -> (union #f (listof mtch))
|
|
;; mtch = (make-mtch bindings sexp[context] (union none sexp[hole]))
|
|
;; hole-info = boolean
|
|
;; #f means we're not in a `in-hole' context
|
|
;; #t means we're looking for a hole
|
|
(define-values (mtch-bindings mtch-context mtch-hole make-mtch mtch?)
|
|
(let ()
|
|
(define-struct mtch (bindings context hole) #:inspector (make-inspector))
|
|
(values mtch-bindings
|
|
mtch-context
|
|
mtch-hole
|
|
(lambda (a b c)
|
|
(unless (bindings? a)
|
|
(error 'make-mtch "expected bindings for first agument, got ~e" a))
|
|
(make-mtch a b c))
|
|
mtch?)))
|
|
|
|
(define none
|
|
(let ()
|
|
(define-struct none ())
|
|
(make-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
|
|
|
|
(define-struct compiled-lang (lang delayed-cclang ht list-ht raw-across-ht raw-across-list-ht
|
|
has-hole-or-hide-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
|
|
(begin-encourage-inline
|
|
(define (lookup-binding bindings
|
|
sym
|
|
[fail (lambda ()
|
|
(error 'lookup-binding "didn't find ~e in ~e" sym bindings))])
|
|
(let loop ([ribs (bindings-table bindings)])
|
|
(cond
|
|
[(null? ribs) (fail)]
|
|
[else
|
|
(let ([rib (car ribs)])
|
|
(if (and (bind? rib) (eq? (bind-name rib) sym))
|
|
(bind-exp rib)
|
|
(loop (cdr ribs))))]))))
|
|
|
|
;; compile-language : language-pict-info[see pict.rkt] (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)]
|
|
[across-list-ht (make-hasheq)]
|
|
[has-hole-or-hide-hole-ht (build-has-hole-or-hide-hole-ht lang)]
|
|
[cache (make-hash)]
|
|
[bind-names-cache (make-hash)]
|
|
[literals (extract-literals lang)]
|
|
[clang (make-compiled-lang lang #f clang-ht clang-list-ht
|
|
across-ht across-list-ht
|
|
has-hole-or-hide-hole-ht
|
|
cache bind-names-cache
|
|
pict-info
|
|
literals
|
|
nt-map)]
|
|
[non-list-nt-table (build-non-list-nt-label lang)]
|
|
[list-nt-table (build-list-nt-label lang)]
|
|
[do-compilation
|
|
(lambda (ht list-ht lang)
|
|
(for ([nt (in-list lang)])
|
|
(for ([rhs (in-list (nt-rhs nt))])
|
|
(define-values (compiled-pattern-proc has-hole? has-hide-hole? names)
|
|
(compile-pattern/cross? clang (rhs-pattern rhs) #f))
|
|
(define (add-to-ht ht)
|
|
(define nv (cons (build-compiled-pattern compiled-pattern-proc names)
|
|
(hash-ref ht (nt-name nt))))
|
|
(hash-set! ht (nt-name nt) nv))
|
|
(define may-be-non-list? (may-be-non-list-pattern? (rhs-pattern rhs) non-list-nt-table))
|
|
(define may-be-list? (may-be-list-pattern? (rhs-pattern rhs) list-nt-table))
|
|
(when may-be-non-list? (add-to-ht ht))
|
|
(when may-be-list? (add-to-ht list-ht))
|
|
(unless (or may-be-non-list? may-be-list?)
|
|
(error 'compile-language
|
|
"internal error: unable to determine whether pattern matches lists, non-lists, or both: ~s"
|
|
(rhs-pattern rhs))))))]
|
|
[init-ht
|
|
(lambda (ht)
|
|
(for-each (lambda (nt) (hash-set! ht (nt-name nt) null))
|
|
lang))])
|
|
|
|
(init-ht clang-ht)
|
|
(init-ht clang-list-ht)
|
|
|
|
(hash-for-each
|
|
clang-ht
|
|
(lambda (nt rhs)
|
|
(when (has-underscore? nt)
|
|
(error 'compile-language "cannot use underscore in nonterminal name, ~s" nt))))
|
|
|
|
(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)
|
|
compatible-context-language)))
|
|
(do-compilation clang-ht clang-list-ht lang)
|
|
(struct-copy compiled-lang clang [delayed-cclang compatible-context-language])))
|
|
|
|
;; extract-literals : (listof nt) -> (listof symbol)
|
|
(define (extract-literals nts)
|
|
(let ([literals-ht (make-hasheq)]
|
|
[nt-names (map nt-name nts)])
|
|
(for-each (λ (nt)
|
|
(for-each (λ (rhs) (extract-literals/pat nt-names (rhs-pattern rhs) literals-ht))
|
|
(nt-rhs nt)))
|
|
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)
|
|
(let loop ([pat pat])
|
|
(match-a-pattern pat
|
|
[`any (void)]
|
|
[`number (void)]
|
|
[`string (void)]
|
|
[`natural (void)]
|
|
[`integer (void)]
|
|
[`real (void)]
|
|
[`variable (void)]
|
|
[`(variable-except ,s ...) (void)]
|
|
[`(variable-prefix ,s) (void)]
|
|
[`variable-not-otherwise-mentioned (void)]
|
|
[`hole (void)]
|
|
[`(nt ,id) (void)]
|
|
[`(name ,name ,pat) (loop pat)]
|
|
[`(mismatch-name ,name ,pat) (loop pat)]
|
|
[`(in-hole ,p1 ,p2)
|
|
(loop p1)
|
|
(loop p2)]
|
|
[`(hide-hole ,p) (loop p)]
|
|
[`(side-condition ,p ,g ,e)
|
|
(loop p)]
|
|
[`(cross ,s) (void)]
|
|
[`(list ,sub-pats ...)
|
|
(for ([sub-pat (in-list sub-pats)])
|
|
(match sub-pat
|
|
[`(repeat ,pat ,name ,mismatch)
|
|
(loop pat)]
|
|
[else
|
|
(loop sub-pat)]))]
|
|
[(? (compose not pair?))
|
|
(when (symbol? pat)
|
|
(unless (regexp-match #rx"_" (symbol->string pat))
|
|
(unless (regexp-match #rx"^\\.\\.\\." (symbol->string pat))
|
|
(unless (memq pat nts)
|
|
(hash-set! ht pat #t)))))])))
|
|
|
|
; build-has-hole-or-hide-hole-ht : (listof nt) -> hash[symbol -o> boolean]
|
|
; produces a map of nonterminal -> whether that nonterminal could produce a hole
|
|
(define (build-has-hole-or-hide-hole-ht lang)
|
|
(build-nt-property
|
|
lang
|
|
(lambda (pattern ht)
|
|
(let loop ([pattern pattern])
|
|
(match-a-pattern pattern
|
|
[`any #f]
|
|
[`number #f]
|
|
[`string #f]
|
|
[`natural #f]
|
|
[`integer #f]
|
|
[`real #f]
|
|
[`variable #f]
|
|
[`(variable-except ,vars ...) #f]
|
|
[`(variable-prefix ,var) #f]
|
|
[`variable-not-otherwise-mentioned #f]
|
|
[`hole #t]
|
|
[`(nt ,id) (hash-ref ht id)]
|
|
[`(name ,name ,pat) (loop pat)]
|
|
[`(mismatch-name ,name ,pat) (loop pat)]
|
|
[`(in-hole ,context ,contractum) (loop contractum)]
|
|
[`(hide-hole ,arg) #t]
|
|
[`(side-condition ,pat ,condition ,expr) (loop pat)]
|
|
[`(cross ,nt) #f]
|
|
[`(list ,pats ...)
|
|
(for/or ([pat (in-list pats)])
|
|
(match pat
|
|
[`(repeat ,pat ,name ,mismatch?) (loop pat)]
|
|
[_ (loop pat)]))]
|
|
[(? (compose not pair?)) #f])))
|
|
#f
|
|
(λ (x y) (or x y))))
|
|
|
|
;; build-nt-property : lang
|
|
;; (pattern hash[nt -o> ans] -> ans)
|
|
;; init-ans
|
|
;; (ans ans ans)
|
|
;; -> hash[nt -o> ans]
|
|
;; builds a property table using a fixed point computation,
|
|
;; using base-answer and lub as the lattice
|
|
(define (build-nt-property lang test-rhs base-answer lub)
|
|
(define ht (make-hash))
|
|
(for ([nt (in-list lang)])
|
|
(hash-set! ht (nt-name nt) base-answer))
|
|
(let loop ()
|
|
(define something-changed? #f)
|
|
(for ([nt (in-list lang)])
|
|
(define next-val
|
|
(for/fold ([acc base-answer])
|
|
([rhs (in-list (nt-rhs nt))])
|
|
(lub acc (test-rhs (rhs-pattern rhs) ht))))
|
|
(unless (equal? next-val (hash-ref ht (nt-name nt)))
|
|
(hash-set! ht (nt-name nt) next-val)
|
|
(set! something-changed? #t)))
|
|
(when something-changed? (loop)))
|
|
ht)
|
|
|
|
;; build-compatible-context-language : lang -> lang
|
|
(define (build-compatible-context-language clang-ht lang)
|
|
(remove-empty-compatible-contexts
|
|
(apply
|
|
append
|
|
(map
|
|
(lambda (nt1)
|
|
(map
|
|
(lambda (nt2)
|
|
(let ([compat-nt (build-compatible-contexts/nt clang-ht (nt-name nt1) nt2)])
|
|
(if (eq? (nt-name nt1) (nt-name nt2))
|
|
(make-nt (nt-name compat-nt)
|
|
(cons
|
|
(make-rhs 'hole)
|
|
(nt-rhs compat-nt)))
|
|
compat-nt)))
|
|
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)
|
|
(define (has-cross? pattern crosses)
|
|
(match pattern
|
|
[`(cross ,(? symbol? nt)) (memq nt crosses)]
|
|
[(list-rest p '... rest) (has-cross? rest crosses)]
|
|
[(cons first rest) (or (has-cross? first crosses)
|
|
(has-cross? rest crosses))]
|
|
[_ #f]))
|
|
(define (delete-empty nts)
|
|
(for/fold ([deleted null] [kept null]) ([nt nts])
|
|
(if (null? (nt-rhs nt))
|
|
(values (cons nt deleted) kept)
|
|
(values deleted (cons nt kept)))))
|
|
(define (delete-references deleted-names remaining-nts)
|
|
(map (λ (nt)
|
|
(make-nt (nt-name nt)
|
|
(filter (λ (rhs) (not (has-cross? (rhs-pattern rhs) deleted-names)))
|
|
(nt-rhs nt))))
|
|
remaining-nts))
|
|
|
|
(let loop ([nts lang])
|
|
(let-values ([(deleted kept) (delete-empty nts)])
|
|
(if (null? deleted)
|
|
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)
|
|
(make-nt
|
|
(symbol-append prefix '- (nt-name nt))
|
|
(apply append
|
|
(map
|
|
(lambda (rhs)
|
|
(let-values ([(maker count) (build-compatible-context-maker clang-ht
|
|
(rhs-pattern rhs)
|
|
prefix)])
|
|
(let loop ([i count])
|
|
(cond
|
|
[(zero? i) null]
|
|
[else (let ([nts (build-across-nts (nt-name nt) count (- i 1))])
|
|
(cons (make-rhs (maker (box nts)))
|
|
(loop (- i 1))))]))))
|
|
(nt-rhs nt)))))
|
|
|
|
(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)
|
|
(let loop ([j count])
|
|
(cond
|
|
[(zero? j) null]
|
|
[else
|
|
(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)
|
|
(let ([count 0])
|
|
(define maker
|
|
(let loop ([pattern pattern])
|
|
(define (untouched-pattern _)
|
|
(values pattern #f))
|
|
(match-a-pattern pattern
|
|
[`any untouched-pattern]
|
|
[`number untouched-pattern]
|
|
[`string untouched-pattern]
|
|
[`natural untouched-pattern]
|
|
[`integer untouched-pattern]
|
|
[`real untouched-pattern]
|
|
[`variable untouched-pattern]
|
|
[`(variable-except ,vars ...) untouched-pattern]
|
|
[`(variable-prefix ,var) untouched-pattern]
|
|
[`variable-not-otherwise-mentioned untouched-pattern]
|
|
[`hole untouched-pattern]
|
|
[`(nt ,name)
|
|
(cond
|
|
[(hash-ref clang-ht name #f)
|
|
(set! count (+ count 1))
|
|
(lambda (l)
|
|
(let ([fst (car (unbox l))])
|
|
(set-box! l (cdr (unbox l)))
|
|
(if fst
|
|
(values `(cross ,(symbol-append prefix '- name)) #t)
|
|
(values pattern #f))))]
|
|
[else untouched-pattern])]
|
|
[`(name ,name ,pat)
|
|
(let ([patf (loop pat)])
|
|
(lambda (l)
|
|
(let-values ([(p h?) (patf l)])
|
|
(values `(name ,name ,p) h?))))]
|
|
[`(mismatch-name ,name ,pat)
|
|
(let ([patf (loop pat)])
|
|
(lambda (l)
|
|
(let-values ([(p h?) (patf l)])
|
|
(values `(mismatch-name ,name ,p) h?))))]
|
|
[`(in-hole ,context ,contractum)
|
|
(let ([match-context (loop context)]
|
|
[match-contractum (loop contractum)])
|
|
(lambda (l)
|
|
(let-values ([(ctxt _) (match-context l)]
|
|
[(ctct h?) (match-contractum l)])
|
|
(values `(in-hole ,ctxt ,ctct) h?))))]
|
|
[`(hide-hole ,p)
|
|
(let ([m (loop p)])
|
|
(lambda (l)
|
|
(let-values ([(p h?) (m l)])
|
|
(if h?
|
|
(values p #t)
|
|
(values `(hide-hole ,p) #f)))))]
|
|
[`(side-condition ,pat ,condition ,expr)
|
|
(let ([patf (loop pat)])
|
|
(lambda (l)
|
|
(let-values ([(p h?) (patf l)])
|
|
(values `(side-condition ,p ,condition ,expr) h?))))]
|
|
[`(cross ,arg) untouched-pattern]
|
|
[`(list ,pats ...)
|
|
(define pre-cross
|
|
(for/list ([sub-pat (in-list pats)])
|
|
(match sub-pat
|
|
[`(repeat ,pat ,name ,mismatch)
|
|
(list (loop pat) sub-pat)]
|
|
[else
|
|
(list (loop sub-pat) #f)])))
|
|
(λ (l)
|
|
(define any-cross? #f)
|
|
(define post-cross
|
|
(map (match-lambda
|
|
[(list f r?)
|
|
(let-values ([(p h?) (f l)])
|
|
(set! any-cross? (or any-cross? h?))
|
|
(list p h? r?))])
|
|
pre-cross))
|
|
(define (hide p)
|
|
(if any-cross?
|
|
(match p
|
|
[`(repeat ,p ,name ,mismatch?)
|
|
`(repeat (hide-hole ,p) ,name ,mismatch?)]
|
|
[_
|
|
`(hide-hole ,p)])
|
|
p))
|
|
(values
|
|
`(list ,@(foldr (λ (post tail)
|
|
(match post
|
|
[(list p* #t (and (not #f) p))
|
|
`(,(hide p) ,p* ,(hide p) . ,tail)]
|
|
[(list p #f (not #f))
|
|
`((repeat ,(hide p) #f #f) . ,tail)]
|
|
[(list p* #t #f)
|
|
`(,p* . ,tail)]
|
|
[(list p #f #f)
|
|
`(,(hide p) . ,tail)]))
|
|
'()
|
|
post-cross))
|
|
any-cross?))]
|
|
[(? (compose not pair?)) untouched-pattern])))
|
|
(values (λ (l) (let-values ([(p _) (maker l)]) p))
|
|
count)))
|
|
|
|
;; build-list-nt-label : lang -> hash[symbol -o> boolean]
|
|
(define (build-list-nt-label lang)
|
|
(build-nt-property lang
|
|
may-be-list-pattern?
|
|
#f
|
|
(λ (x y) (or x y))))
|
|
|
|
(define (may-be-list-pattern? pattern nt-table)
|
|
(let loop ([pattern pattern])
|
|
(match-a-pattern pattern
|
|
[`any #t]
|
|
[`number #f]
|
|
[`string #f]
|
|
[`natural #f]
|
|
[`integer #f]
|
|
[`real #f]
|
|
[`variable #f]
|
|
[`(variable-except ,vars ...) #f]
|
|
[`(variable-prefix ,var) #f]
|
|
[`variable-not-otherwise-mentioned #f]
|
|
[`hole #t]
|
|
[`(nt ,id) (hash-ref nt-table id)]
|
|
[`(name ,id ,pat) (loop pat)]
|
|
[`(mismatch-name ,id ,pat) (loop pat)]
|
|
[`(in-hole ,context ,contractum)
|
|
;; pessimistic, assumes that context can be 'hole' directly
|
|
(or (loop context) (loop contractum))]
|
|
[`(hide-hole ,p) (loop p)]
|
|
[`(side-condition ,pat ,condition ,expr) (loop pat)]
|
|
[`(cross ,nt) #t]
|
|
[`(list ,pats ...) #t]
|
|
[(? (compose not pair?)) #f])))
|
|
|
|
|
|
;; build-non-list-nt-label : lang -> hash[symbol -o> boolean]
|
|
(define (build-non-list-nt-label lang)
|
|
(build-nt-property lang
|
|
may-be-non-list-pattern?
|
|
#f
|
|
(λ (x y) (or x y))))
|
|
|
|
(define (may-be-non-list-pattern? pattern ht)
|
|
(let loop ([pattern pattern])
|
|
(match-a-pattern pattern
|
|
[`any #t]
|
|
[`number #t]
|
|
[`string #t]
|
|
[`natural #t]
|
|
[`integer #t]
|
|
[`real #t]
|
|
[`variable #t]
|
|
[`(variable-except ,vars ...) #t]
|
|
[`(variable-prefix ,prefix) #t]
|
|
[`variable-not-otherwise-mentioned #t]
|
|
[`hole #t]
|
|
[`(nt ,nt) (hash-ref ht nt)]
|
|
[`(name ,name ,pat) (loop pat)]
|
|
[`(mismatch-name ,name ,pat) (loop pat)]
|
|
[`(in-hole ,context ,contractum)
|
|
;; pessimistic, assumes that context can be 'hole' directly
|
|
(or (loop context) (loop contractum))]
|
|
[`(hide-hole ,p) (loop p)]
|
|
[`(side-condition ,pat ,condition ,expr) (loop pat)]
|
|
[`(cross ,nt) #t]
|
|
[`(list ,pats ...) #f]
|
|
[(? (compose not pair?)) #t])))
|
|
|
|
;; match-pattern : compiled-pattern exp -> (union #f (listof bindings))
|
|
(define (match-pattern compiled-pattern exp)
|
|
(let ([results ((compiled-pattern-cp compiled-pattern) exp #f)])
|
|
(if (compiled-pattern-skip-dup-check? compiled-pattern)
|
|
results
|
|
(and results
|
|
(let ([filtered (filter-multiples results)])
|
|
(and (not (null? filtered))
|
|
filtered))))))
|
|
|
|
;; filter-multiples : (listof mtch) -> (listof mtch)
|
|
(define (filter-multiples matches)
|
|
;(printf "matches ~s\n" matches)
|
|
(let loop ([matches matches]
|
|
[acc null])
|
|
(cond
|
|
[(null? matches)
|
|
;; this reverse here is to get things back
|
|
;; in the same order that they'd be in if the
|
|
;; skip-dup-check? bolean had been true
|
|
(reverse acc)]
|
|
[else
|
|
(let ([merged (merge-multiples/remove (car matches))])
|
|
(if merged
|
|
(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)
|
|
(let/ec fail
|
|
(let (
|
|
;; match-ht : sym -o> sexp
|
|
[match-ht (make-hash)]
|
|
|
|
;; mismatch-ht : sym -o> hash[sexp -o> #t]
|
|
[mismatch-ht (make-hash)]
|
|
|
|
[ribs (bindings-table (mtch-bindings match))])
|
|
(for-each
|
|
(lambda (rib)
|
|
(cond
|
|
[(bind? rib)
|
|
(let ([name (bind-name rib)]
|
|
[exp (bind-exp rib)])
|
|
(let ([previous-exp (hash-ref match-ht name uniq)])
|
|
(cond
|
|
[(eq? previous-exp uniq)
|
|
(hash-set! match-ht name exp)]
|
|
[else
|
|
(unless (equal? exp previous-exp)
|
|
(fail #f))])))]
|
|
[(mismatch-bind? rib)
|
|
(let* ([name (mismatch-bind-name rib)]
|
|
[exp (mismatch-bind-exp rib)]
|
|
[priors (hash-ref mismatch-ht name uniq)])
|
|
(when (eq? priors uniq)
|
|
(let ([table (make-hash)])
|
|
(hash-set! mismatch-ht name table)
|
|
(set! priors table)))
|
|
(when (hash-ref priors exp #f)
|
|
(fail #f))
|
|
(hash-set! priors exp #t))]))
|
|
ribs)
|
|
(make-mtch
|
|
(make-bindings (hash-map match-ht make-bind))
|
|
(mtch-context match)
|
|
(mtch-hole match)))))
|
|
|
|
;; compile-pattern : compiled-lang pattern boolean -> compiled-pattern
|
|
(define (compile-pattern clang pattern bind-names?)
|
|
(let-values ([(pattern has-hole? has-hide-hole? names) (compile-pattern/cross? clang pattern bind-names?)])
|
|
(build-compiled-pattern (if (or has-hole? has-hide-hole? (not (null? names)))
|
|
pattern
|
|
(convert-matcher pattern))
|
|
names)))
|
|
|
|
(define (build-compiled-pattern proc names)
|
|
(make-compiled-pattern proc
|
|
|
|
(null? names)
|
|
|
|
;; none of the names are duplicated
|
|
(and (equal? names (remove-duplicates names))
|
|
|
|
;; no mismatch names
|
|
(not (for/or ([name (in-list names)])
|
|
(pair? name))))))
|
|
|
|
;; compile-pattern/cross? : compiled-lang pattern boolean -> (values compiled-pattern boolean)
|
|
(define (compile-pattern/cross? clang pattern bind-names?)
|
|
(define clang-ht (compiled-lang-ht clang))
|
|
(define clang-list-ht (compiled-lang-list-ht clang))
|
|
(define has-hole-or-hide-hole-ht (compiled-lang-has-hole-or-hide-hole-ht clang))
|
|
|
|
(define (compile-pattern/default-cache pattern)
|
|
(compile-pattern/cache pattern
|
|
(if bind-names?
|
|
(compiled-lang-bind-names-cache clang)
|
|
(compiled-lang-cache clang))))
|
|
|
|
(define in-name-parameter (make-parameter #f))
|
|
|
|
(define (compile-pattern/cache pattern compiled-pattern-cache)
|
|
(let ([compiled-cache (hash-ref compiled-pattern-cache pattern uniq)])
|
|
(cond
|
|
[(eq? compiled-cache uniq)
|
|
(define-values (compiled-pattern has-hole? has-hide-hole? names) (true-compile-pattern pattern))
|
|
(unless (equal? (if (or has-hole? has-hide-hole? (not (null? names)))
|
|
2
|
|
1)
|
|
(procedure-arity compiled-pattern))
|
|
(error 'compile-pattern "got procedure with wrong arity; pattern ~s ~s ~s ~s ~s\n"
|
|
pattern compiled-pattern has-hole? has-hide-hole? names))
|
|
(define val (list (match pattern
|
|
[`(nt ,p)
|
|
(memoize compiled-pattern has-hole?)]
|
|
[_ compiled-pattern])
|
|
has-hole?
|
|
has-hide-hole?
|
|
names))
|
|
(hash-set! compiled-pattern-cache pattern val)
|
|
(apply values val)]
|
|
[else
|
|
(apply values compiled-cache)])))
|
|
|
|
;; invariant : if both result booleans are #f (ie, no-hole and no names), then
|
|
;; the result (matching) function returns a boolean and has arity 1.
|
|
;; otherwise it is a compiled-pattern function (ie returning a list
|
|
;; of assoc tables)
|
|
(define (true-compile-pattern pattern)
|
|
(match-a-pattern pattern
|
|
[`any (simple-match (λ (x) #t))]
|
|
[`number (simple-match number?)]
|
|
[`string (simple-match string?)]
|
|
[`natural (simple-match exact-nonnegative-integer?)]
|
|
[`integer (simple-match exact-integer?)]
|
|
[`real (simple-match real?)]
|
|
[`variable (simple-match symbol?)]
|
|
[`(variable-except ,vars ...)
|
|
(simple-match
|
|
(λ (exp)
|
|
(and (symbol? exp)
|
|
(not (memq exp vars)))))]
|
|
[`(variable-prefix ,var)
|
|
(define prefix-str (symbol->string var))
|
|
(define prefix-len (string-length prefix-str))
|
|
(simple-match
|
|
(λ (exp)
|
|
(and (symbol? exp)
|
|
(let ([str (symbol->string exp)])
|
|
(and ((string-length str) . >= . prefix-len)
|
|
(string=? (substring str 0 prefix-len) prefix-str))))))]
|
|
[`variable-not-otherwise-mentioned
|
|
(let ([literals (compiled-lang-literals clang)])
|
|
(simple-match
|
|
(λ (exp)
|
|
(and (symbol? exp)
|
|
(not (memq exp literals))))))]
|
|
[`hole
|
|
(values match-hole #t #f '())]
|
|
[`(nt ,nt)
|
|
(define in-name? (in-name-parameter))
|
|
(define has-hole? (hash-ref has-hole-or-hide-hole-ht nt))
|
|
(values
|
|
(if has-hole?
|
|
(λ (exp hole-info)
|
|
(match-nt (hash-ref clang-list-ht nt)
|
|
(hash-ref clang-ht nt)
|
|
nt exp hole-info))
|
|
(λ (exp)
|
|
(match-nt/boolean
|
|
(hash-ref clang-list-ht nt)
|
|
(hash-ref clang-ht nt)
|
|
nt exp)))
|
|
has-hole?
|
|
#f
|
|
'())]
|
|
[`(name ,name ,pat)
|
|
(define-values (match-pat has-hole? has-hide-hole? names)
|
|
(parameterize ([in-name-parameter #t])
|
|
(compile-pattern/default-cache pat)))
|
|
(values (match-named-pat name (if (or has-hide-hole? has-hole? (not (null? names)))
|
|
match-pat
|
|
(convert-matcher match-pat))
|
|
#f)
|
|
has-hole?
|
|
has-hide-hole?
|
|
(cons name names))]
|
|
[`(mismatch-name ,name ,pat)
|
|
(define-values (match-pat has-hole? has-hide-hole? names) (compile-pattern/default-cache pat))
|
|
(values (match-named-pat name (if (or has-hide-hole? has-hole? (not (null? names)))
|
|
match-pat
|
|
(convert-matcher match-pat))
|
|
#t)
|
|
has-hole?
|
|
has-hide-hole?
|
|
(cons `(mismatch-name name) names))]
|
|
[`(in-hole ,context ,contractum)
|
|
(define-values (match-context ctxt-has-hole? ctxt-has-hide-hole? ctxt-names)
|
|
(compile-pattern/default-cache context))
|
|
(define-values (match-contractum contractum-has-hole? contractum-has-hide-hole? contractum-names)
|
|
(compile-pattern/default-cache contractum))
|
|
(unless ctxt-has-hole?
|
|
(error 'compile-pattern
|
|
"found an in-hole pattern whose context position has no hole ~s"
|
|
pattern))
|
|
(values
|
|
(if (or ctxt-has-hide-hole?
|
|
contractum-has-hole?
|
|
contractum-has-hide-hole?
|
|
(not (null? ctxt-names))
|
|
(not (null? contractum-names)))
|
|
(match-in-hole context
|
|
contractum
|
|
exp
|
|
match-context
|
|
(if (or contractum-has-hole? contractum-has-hide-hole? (not (null? contractum-names)))
|
|
match-contractum
|
|
(convert-matcher match-contractum)))
|
|
(match-in-hole/contractum-boolean context
|
|
contractum
|
|
exp
|
|
match-context
|
|
match-contractum))
|
|
contractum-has-hole?
|
|
(or ctxt-has-hide-hole? contractum-has-hide-hole?)
|
|
(append ctxt-names contractum-names))]
|
|
[`(hide-hole ,p)
|
|
(define-values (match-pat has-hole? has-hide-hole? names) (compile-pattern/default-cache p))
|
|
(values
|
|
(cond
|
|
[(or has-hole? has-hide-hole? (not (null? names)))
|
|
(lambda (exp hole-info)
|
|
(let ([matches (match-pat exp #f)])
|
|
(and matches
|
|
(map (λ (match) (make-mtch (mtch-bindings match)
|
|
(hole->not-hole (mtch-context match))
|
|
none))
|
|
matches))))]
|
|
[else
|
|
(lambda (exp hole-info)
|
|
(let ([matches (match-pat exp)])
|
|
(and matches
|
|
(list (make-mtch empty-bindings
|
|
(hole->not-hole exp)
|
|
none)))))])
|
|
#f
|
|
#t
|
|
names)]
|
|
[`(side-condition ,pat ,condition ,expr)
|
|
(define-values (match-pat has-hole? has-hide-hole? names) (compile-pattern/default-cache pat))
|
|
(values
|
|
(if (or has-hole? has-hide-hole? (not (null? names)))
|
|
(λ (exp hole-info)
|
|
(let ([matches (match-pat exp hole-info)])
|
|
(and matches
|
|
(let ([filtered (filter (λ (m) (condition (mtch-bindings m)))
|
|
(filter-multiples matches))])
|
|
(if (null? filtered)
|
|
#f
|
|
filtered)))))
|
|
(λ (exp)
|
|
(and (match-pat exp)
|
|
(condition empty-bindings))))
|
|
has-hole?
|
|
has-hide-hole?
|
|
names)]
|
|
[`(cross ,(? symbol? id))
|
|
(define across-ht (compiled-lang-across-ht clang))
|
|
(define across-list-ht (compiled-lang-across-list-ht clang))
|
|
(cond
|
|
[(hash-maps? across-ht id)
|
|
(values
|
|
(λ (exp hole-info)
|
|
(match-nt (hash-ref across-list-ht id)
|
|
(hash-ref across-ht id)
|
|
id exp hole-info))
|
|
#t
|
|
#f
|
|
'())]
|
|
[else
|
|
(error 'compile-pattern "unknown cross reference ~a" id)])]
|
|
[`(list ,pats ...)
|
|
(define-values (rewritten has-hole?s has-hide-hole?s namess) (rewrite-ellipses pats compile-pattern/default-cache))
|
|
(define any-has-hole? (ormap values has-hole?s))
|
|
(define any-has-hide-hole? (ormap values has-hide-hole?s))
|
|
(define repeats (length (filter repeat? rewritten)))
|
|
(define non-repeats (length (filter (λ (x) (not (repeat? x))) rewritten)))
|
|
(define names (apply append namess))
|
|
(define rewritten/coerced
|
|
(for/list ([pat (in-list rewritten)]
|
|
[has-hole? (in-list has-hole?s)]
|
|
[has-hide-hole? (in-list has-hide-hole?s)]
|
|
[names (in-list namess)])
|
|
(cond
|
|
[(repeat? pat)
|
|
;; have to use procedure arity test here in case the
|
|
;; name on this pattern is in the repeat (in which case
|
|
;; the has-hide-hole? boolean will be true, but pat
|
|
;; may not need converting)
|
|
(if (equal? (procedure-arity (repeat-pat pat))
|
|
2)
|
|
pat
|
|
(struct-copy repeat pat [pat (convert-matcher (repeat-pat pat))]))]
|
|
[else
|
|
(if (or has-hole? has-hide-hole? (not (null? names)))
|
|
pat
|
|
(convert-matcher pat))])))
|
|
(values
|
|
(cond
|
|
[(not (or any-has-hole? any-has-hide-hole? (not (null? names))))
|
|
(λ (exp)
|
|
(cond
|
|
[(list? exp) (match-list/boolean rewritten exp)]
|
|
[else #f]))]
|
|
[(= 0 repeats)
|
|
(λ (exp hole-info)
|
|
(cond
|
|
[(list? exp)
|
|
;; shortcircuit: if the list isn't the right length, give up immediately.
|
|
(if (= (length exp) non-repeats)
|
|
(match-list/no-repeats rewritten/coerced exp hole-info)
|
|
#f)]
|
|
[else #f]))]
|
|
[else
|
|
(λ (exp hole-info)
|
|
(cond
|
|
[(list? exp)
|
|
;; shortcircuit: if the list doesn't have the right number of
|
|
;; fixed parts, give up immediately
|
|
(if (>= (length exp) non-repeats)
|
|
(match-list rewritten/coerced exp hole-info)
|
|
#f)]
|
|
[else #f]))])
|
|
any-has-hole?
|
|
any-has-hide-hole?
|
|
names)]
|
|
|
|
[(? (compose not pair?))
|
|
(cond
|
|
[(compiled-pattern? pattern) ;; can this really happen anymore?!
|
|
(values (compiled-pattern-cp pattern)
|
|
;; return #ts here as a failsafe; no way to check better.
|
|
#t
|
|
#t)]
|
|
[(eq? pattern '....)
|
|
;; this should probably be checked at compile time, not here
|
|
(error 'compile-language "the pattern .... can only be used in extend-language")]
|
|
[else
|
|
(simple-match
|
|
(λ (exp)
|
|
(equal? pattern exp)))])]))
|
|
|
|
;; simple-match : (any -> bool) -> (values <compiled-pattern> boolean boolean)
|
|
;; does a match based on a predicate
|
|
(define (simple-match pred)
|
|
(values (lambda (exp) (pred exp))
|
|
#f
|
|
#f
|
|
'()))
|
|
|
|
(compile-pattern/default-cache pattern))
|
|
|
|
|
|
;; convert-matcher : (any -> boolean) -> <compiled-pattern>
|
|
(define (convert-matcher boolean-based-matcher)
|
|
(unless (equal? (procedure-arity boolean-based-matcher) 1)
|
|
(error 'convert-matcher
|
|
"not a unary proc: ~s"
|
|
boolean-based-matcher))
|
|
(λ (exp hole-info)
|
|
(and (boolean-based-matcher exp)
|
|
(list (make-mtch empty-bindings
|
|
(build-flat-context exp)
|
|
none)))))
|
|
|
|
;; match-named-pat : symbol <compiled-pattern> -> <compiled-pattern>
|
|
(define (match-named-pat name match-pat mismatch-bind?)
|
|
(λ (exp hole-info)
|
|
(let ([matches (match-pat exp hole-info)])
|
|
(and matches
|
|
(map (lambda (match)
|
|
(make-mtch
|
|
(make-bindings (cons (if mismatch-bind?
|
|
(make-mismatch-bind name (mtch-context match))
|
|
(make-bind name (mtch-context match)))
|
|
(bindings-table (mtch-bindings match))))
|
|
(mtch-context match)
|
|
(mtch-hole match)))
|
|
matches)))))
|
|
|
|
;; has-underscore? : symbol -> boolean
|
|
(define (has-underscore? sym)
|
|
(memq #\_ (string->list (symbol->string sym))))
|
|
|
|
(define (memoize f needs-all-args?)
|
|
(case (procedure-arity f)
|
|
[(1) (memoize/1 f nohole)]
|
|
[(2) (memoize/2 f w/hole)]
|
|
[else (error 'memoize "unknown arity for ~s" f)]))
|
|
|
|
(define cache-size 63)
|
|
(define (set-cache-size! cs) (set! cache-size cs))
|
|
|
|
;; original version, but without closure allocation in hash lookup
|
|
(define-syntax (mk-memoize-key stx)
|
|
(syntax-case stx ()
|
|
[(_ arity)
|
|
(with-syntax ([(args ...) (generate-temporaries (build-list (syntax-e #'arity) (λ (x) 'x)))])
|
|
(with-syntax ([key-exp (if (= 1 (syntax-e #'arity))
|
|
(car (syntax->list #'(args ...)))
|
|
#'(list args ...))])
|
|
#'(λ (f statsbox)
|
|
(let ([ht (make-hash)]
|
|
[entries 0])
|
|
(lambda (args ...)
|
|
(cond
|
|
[(not (caching-enabled?)) (f args ...)]
|
|
[else
|
|
(let* ([key key-exp])
|
|
;(record-cache-test! statsbox)
|
|
(unless (< entries cache-size)
|
|
(set! entries 0)
|
|
(set! ht (make-hash)))
|
|
(let ([ans (hash-ref ht key uniq)])
|
|
(cond
|
|
[(eq? ans uniq)
|
|
;(record-cache-miss! statsbox)
|
|
(set! entries (+ entries 1))
|
|
(let ([res (f args ...)])
|
|
(hash-set! ht key res)
|
|
res)]
|
|
[else ans])))]))))))]))
|
|
|
|
;(define memoize/1 (mk-memoize-key 1))
|
|
;(define memoize/2 (mk-memoize-key 2))
|
|
|
|
(define-syntax (mk-memoize-vec stx)
|
|
(syntax-case stx ()
|
|
[(_ arity)
|
|
(with-syntax ([(args ...) (generate-temporaries (build-list (syntax-e #'arity) (λ (x) 'x)))])
|
|
(with-syntax ([key-exp (if (= 1 (syntax-e #'arity))
|
|
(car (syntax->list #'(args ...)))
|
|
#'(list args ...))])
|
|
#'(λ (f statsbox)
|
|
(let* ([uniq (gensym)]
|
|
[this-cache-size cache-size]
|
|
[ans-vec (make-vector this-cache-size uniq)]
|
|
[key-vec (make-vector this-cache-size uniq)])
|
|
(lambda (args ...)
|
|
(cond
|
|
[(not (caching-enabled?)) (f args ...)]
|
|
[else
|
|
;(record-cache-test! statsbox)
|
|
;(when (zero? (modulo (cache-stats-hits statsbox) 1000))
|
|
; (record-cache-size! statsbox (cons ans-vec key-vec)))
|
|
(let* ([key key-exp]
|
|
[index (modulo (equal-hash-code key) this-cache-size)])
|
|
(cond
|
|
[(equal? (vector-ref key-vec index) key)
|
|
(vector-ref ans-vec index)]
|
|
[else
|
|
;(record-cache-miss! statsbox)
|
|
(unless (eq? uniq (vector-ref key-vec index)) (record-cache-clobber! statsbox))
|
|
(let ([ans (f args ...)])
|
|
(vector-set! key-vec index key)
|
|
(vector-set! ans-vec index ans)
|
|
ans)]))]))))))]))
|
|
|
|
(define memoize/1 (mk-memoize-vec 1))
|
|
(define memoize/2 (mk-memoize-vec 2))
|
|
|
|
;; 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)]
|
|
[when-to-evict-table (make-hasheq)]
|
|
[pointer 0])
|
|
(lambda (x y)
|
|
(record-cache-test! statsbox)
|
|
(let* ([key (key-fn x y)]
|
|
[value-in-cache (hash-ref ht key uniq)])
|
|
(cond
|
|
[(eq? value-in-cache uniq)
|
|
(record-cache-miss! statsbox)
|
|
(let ([res (f x y)])
|
|
(let ([to-remove (hash-ref when-to-evict-table pointer uniq)])
|
|
(unless (eq? uniq to-remove)
|
|
(hash-remove! ht to-remove)))
|
|
(hash-set! when-to-evict-table pointer key)
|
|
(hash-set! ht key res)
|
|
(set! pointer (modulo (+ pointer 1) cache-size))
|
|
res)]
|
|
[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)
|
|
(let* ([cache-size 50]
|
|
[cache '()])
|
|
(lambda (x y)
|
|
(record-cache-test! statsbox)
|
|
(let ([key (key-fn x y)])
|
|
(cond
|
|
[(null? cache)
|
|
;; empty cache
|
|
(let ([ans (f x y)])
|
|
(record-cache-miss! statsbox)
|
|
(set! cache (cons (cons key ans) '()))
|
|
ans)]
|
|
[(null? (cdr cache))
|
|
;; one element cache
|
|
(if (equal? (car (car cache)) key)
|
|
(cdr (car cache))
|
|
(let ([ans (f x y)])
|
|
(record-cache-miss! statsbox)
|
|
(set! cache (cons (cons key ans) cache))
|
|
ans))]
|
|
[else
|
|
;; two of more element cache
|
|
(cond
|
|
[(equal? (car (car cache)) key)
|
|
;; check first element
|
|
(cdr (car cache))]
|
|
[(equal? (car (cadr cache)) key)
|
|
;; check second element
|
|
(cdr (cadr cache))]
|
|
[else
|
|
;; iterate from the 3rd element onwards
|
|
(let loop ([previous2 cache]
|
|
[previous1 (cdr cache)]
|
|
[current (cddr cache)]
|
|
[i 0])
|
|
(cond
|
|
[(null? current)
|
|
;; found the end of the cache -- need to drop the last element if the cache is too full,
|
|
;; and put the current value at the front of the cache.
|
|
(let ([ans (f x y)])
|
|
(record-cache-miss! statsbox)
|
|
(set! cache (cons (cons key ans) cache))
|
|
(unless (< i cache-size)
|
|
;; drop the last element from the cache
|
|
(set-cdr! previous2 '()))
|
|
ans)]
|
|
[else
|
|
(let ([entry (car current)])
|
|
(cond
|
|
[(equal? (car entry) key)
|
|
;; found a hit
|
|
|
|
; remove this element from the list where it is.
|
|
(set-cdr! previous1 (cdr current))
|
|
|
|
; move it to the front of the cache
|
|
(set! cache (cons current cache))
|
|
|
|
; return the found element
|
|
(cdr entry)]
|
|
[else
|
|
;; didn't hit yet, continue searching
|
|
(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)
|
|
(let* ([cache-size 50]
|
|
[ht (make-hash)]
|
|
[uniq (gensym)]
|
|
[vector (make-vector cache-size uniq)] ;; vector is only used to evict things from the hash
|
|
[pointer 0])
|
|
(lambda (x y)
|
|
(let* ([key (key-fn x y)]
|
|
[value-in-cache (hash-ref ht key uniq)])
|
|
(cond
|
|
[(eq? value-in-cache uniq)
|
|
(let ([res (f x y)])
|
|
(let ([to-remove (vector-ref vector pointer)])
|
|
(unless (eq? uniq to-remove)
|
|
(hash-remove! ht to-remove)))
|
|
(vector-set! vector pointer key)
|
|
(hash-set! ht key res)
|
|
(set! pointer (modulo (+ pointer 1) cache-size))
|
|
res)]
|
|
[else
|
|
value-in-cache])))))
|
|
|
|
;; 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
|
|
[cache (make-vector cache-size #f)]
|
|
[pointer 0])
|
|
(lambda (x y)
|
|
(let ([key (key-fn x y)])
|
|
(let loop ([i 0])
|
|
(cond
|
|
[(= i cache-size)
|
|
(unless (vector-ref cache pointer)
|
|
(vector-set! cache pointer (cons #f #f)))
|
|
(let ([pair (vector-ref cache pointer)]
|
|
[ans (f x y)])
|
|
(set-car! pair key)
|
|
(set-cdr! pair ans)
|
|
(set! pointer (modulo (+ 1 pointer) cache-size))
|
|
ans)]
|
|
[else
|
|
(let ([entry (vector-ref cache i)])
|
|
(if entry
|
|
(let ([e-key (car entry)]
|
|
[e-val (cdr entry)])
|
|
(if (equal? e-key key)
|
|
e-val
|
|
(loop (+ i 1))))
|
|
|
|
;; 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)
|
|
(let ([ht (make-hash)]
|
|
[entries 0])
|
|
(lambda (x y)
|
|
(record-cache-test! statsbox)
|
|
(let* ([key (key-fn x y)]
|
|
[compute/cache
|
|
(lambda ()
|
|
(set! entries (+ entries 1))
|
|
(record-cache-miss! statsbox)
|
|
(let ([res (f x y)])
|
|
(hash-set! ht key res)
|
|
res))])
|
|
(unless (< entries 200) ; 10000 was original size
|
|
(set! entries 0)
|
|
(set! ht (make-hash)))
|
|
(hash-ref ht key compute/cache)))))
|
|
|
|
(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)
|
|
(set-cache-stats-hits! statsbox (add1 (cache-stats-hits statsbox))))
|
|
|
|
(define (record-cache-clobber! statsbox)
|
|
(set-cache-stats-clobber-hits! statsbox (add1 (cache-stats-clobber-hits statsbox))))
|
|
|
|
(define-struct cache-stats (name misses hits clobber-hits sizes) #:mutable)
|
|
(define (new-cache-stats name) (make-cache-stats name 0 0 0 '()))
|
|
|
|
(define w/hole (new-cache-stats "hole"))
|
|
(define nohole (new-cache-stats "no-hole"))
|
|
|
|
(define (record-cache-size! cache-stats cache)
|
|
(define size
|
|
(let loop ([cache cache])
|
|
(cond
|
|
[(vector? cache)
|
|
(for/fold ([size (vector-length cache)])
|
|
([ele (in-vector cache)])
|
|
(+ size (loop ele)))]
|
|
[(pair? cache)
|
|
(+ 1 (loop (car cache)) (loop (cdr cache)))]
|
|
[else 1])))
|
|
(set-cache-stats-sizes! cache-stats (cons size (cache-stats-sizes cache-stats))))
|
|
|
|
(define (print-stats)
|
|
(let ((stats (list w/hole nohole)))
|
|
(for-each
|
|
(lambda (s)
|
|
(when (> (+ (cache-stats-hits s) (cache-stats-misses s)) 0)
|
|
(printf "~a has ~a hits, ~a misses (~a% miss rate)\n"
|
|
(cache-stats-name s)
|
|
(cache-stats-hits s)
|
|
(cache-stats-misses s)
|
|
(floor
|
|
(* 100 (/ (cache-stats-misses s)
|
|
(+ (cache-stats-hits s) (cache-stats-misses s))))))))
|
|
stats)
|
|
(let ((overall-hits (apply + (map cache-stats-hits stats)))
|
|
(overall-miss (apply + (map cache-stats-misses stats)))
|
|
(overall-clobber-hits (apply + (map cache-stats-clobber-hits stats))))
|
|
(printf "---\nOverall hits: ~a\n" overall-hits)
|
|
(printf "Overall misses: ~a\n" overall-miss)
|
|
(when (> (+ overall-hits overall-miss) 0)
|
|
(printf "Overall miss rate: ~a%\n"
|
|
(floor (* 100 (/ overall-miss (+ overall-hits overall-miss))))))
|
|
(printf "Overall clobbering hits: ~a\n" overall-clobber-hits))
|
|
|
|
(let* ([sizes (apply append (map cache-stats-sizes stats))]
|
|
[len (length sizes)])
|
|
(unless (zero? len)
|
|
(let ([avg (/ (apply + 0.0 sizes) len)])
|
|
(printf "Average cache size ~s; ~a samples\n" avg len))))))
|
|
|
|
;; match-hole : compiled-pattern
|
|
(define match-hole
|
|
(λ (exp hole-info)
|
|
(if hole-info
|
|
(list (make-mtch empty-bindings
|
|
the-hole
|
|
exp))
|
|
(and (hole? exp)
|
|
(list (make-mtch empty-bindings
|
|
the-hole
|
|
none))))))
|
|
|
|
;; match-in-hole : sexp sexp sexp compiled-pattern compiled-pattern -> compiled-pattern
|
|
(define (match-in-hole context contractum exp match-context match-contractum)
|
|
(λ (exp old-hole-info)
|
|
(let ([mtches (match-context exp #t)])
|
|
(and mtches
|
|
(let loop ([mtches mtches]
|
|
[acc null])
|
|
(cond
|
|
[(null? mtches) acc]
|
|
[else
|
|
(let* ([mtch (car mtches)]
|
|
[bindings (mtch-bindings mtch)]
|
|
[hole-exp (mtch-hole mtch)]
|
|
[contractum-mtches (match-contractum hole-exp old-hole-info)])
|
|
(when (eq? none hole-exp)
|
|
(error 'matcher.rkt "found no hole when matching a decomposition"))
|
|
(if contractum-mtches
|
|
(let i-loop ([contractum-mtches contractum-mtches]
|
|
[acc acc])
|
|
(cond
|
|
[(null? contractum-mtches) (loop (cdr mtches) acc)]
|
|
[else (let* ([contractum-mtch (car contractum-mtches)]
|
|
[contractum-bindings (mtch-bindings contractum-mtch)])
|
|
(i-loop
|
|
(cdr contractum-mtches)
|
|
(cons
|
|
(make-mtch (make-bindings
|
|
(append (bindings-table contractum-bindings)
|
|
(bindings-table bindings)))
|
|
(build-nested-context
|
|
(mtch-context mtch)
|
|
(mtch-context contractum-mtch))
|
|
(mtch-hole contractum-mtch))
|
|
acc)))]))
|
|
(loop (cdr mtches) acc)))]))))))
|
|
|
|
(define (match-in-hole/contractum-boolean context contractum exp match-context match-contractum)
|
|
(λ (exp)
|
|
(let ([mtches (match-context exp #t)])
|
|
(and mtches
|
|
(let loop ([mtches mtches])
|
|
(cond
|
|
[(null? mtches) #f]
|
|
[else
|
|
(let* ([mtch (car mtches)]
|
|
[hole-exp (mtch-hole mtch)]
|
|
[contractum-mtches (match-contractum hole-exp)])
|
|
(when (eq? none hole-exp)
|
|
(error 'matcher.rkt "found no hole when matching a decomposition"))
|
|
(or contractum-mtches
|
|
(loop (cdr mtches))))]))))))
|
|
|
|
;; match-list/boolean : (listof (union repeat (any hole-info -> boolean))) sexp hole-info -> boolean
|
|
(define (match-list/boolean patterns exp)
|
|
(let loop ([exp exp]
|
|
[patterns patterns])
|
|
(cond
|
|
[(null? exp)
|
|
(let loop ([patterns patterns])
|
|
(or (null? patterns)
|
|
(and (repeat? (car patterns))
|
|
(loop (cdr patterns)))))]
|
|
[(null? patterns) #f]
|
|
[(repeat? (car patterns))
|
|
(or (loop exp (cdr patterns))
|
|
(and ((repeat-pat (car patterns)) (car exp))
|
|
(loop (cdr exp) patterns)))]
|
|
[else
|
|
(and ((car patterns) (car exp))
|
|
(loop (cdr exp) (cdr patterns)))])))
|
|
|
|
;; 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)])
|
|
|
|
(and (not (null? raw-match))
|
|
(let loop ([raw-match raw-match])
|
|
(cond
|
|
[(null? raw-match) '()]
|
|
[else (append (combine-matches (car raw-match))
|
|
(loop (cdr raw-match)))])))))
|
|
|
|
;; 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]
|
|
;; fail : -> alpha
|
|
;; causes one possible expansion of ellipses to fail
|
|
;; initially there is only one possible expansion, so
|
|
;; everything fails.
|
|
[fail (lambda () (k null))])
|
|
(cond
|
|
[(pair? patterns)
|
|
(let ([fst-pat (car patterns)])
|
|
(cond
|
|
[(repeat? fst-pat)
|
|
(if (or (null? exp) (pair? exp))
|
|
(let ([r-pat (repeat-pat fst-pat)]
|
|
[r-mt (make-mtch (make-bindings (repeat-empty-bindings fst-pat))
|
|
(build-flat-context '())
|
|
none)])
|
|
(apply
|
|
append
|
|
(cons (let/ec k
|
|
(let ([mt-fail (lambda () (k null))])
|
|
(map (lambda (pat-ele)
|
|
(cons (add-ellipses-index (list r-mt) (repeat-name fst-pat) (repeat-mismatch fst-pat) 0)
|
|
pat-ele))
|
|
(loop (cdr patterns) exp mt-fail))))
|
|
(let r-loop ([exp exp]
|
|
;; past-matches is in reverse order
|
|
;; it gets reversed before put into final list
|
|
[past-matches (list r-mt)]
|
|
[index 1])
|
|
(cond
|
|
[(pair? exp)
|
|
(let* ([fst (car exp)]
|
|
[m (r-pat fst hole-info)])
|
|
(if m
|
|
(let* ([combined-matches (collapse-single-multiples m past-matches)]
|
|
[reversed
|
|
(add-ellipses-index
|
|
(reverse-multiples combined-matches)
|
|
(repeat-name fst-pat)
|
|
(repeat-mismatch fst-pat)
|
|
index)])
|
|
(cons
|
|
(let/ec fail-k
|
|
(map (lambda (x) (cons reversed x))
|
|
(loop (cdr patterns)
|
|
(cdr exp)
|
|
(lambda () (fail-k null)))))
|
|
(r-loop (cdr exp)
|
|
combined-matches
|
|
(+ index 1))))
|
|
(list null)))]
|
|
;; what about dotted pairs?
|
|
[else (list null)])))))
|
|
(fail))]
|
|
[else
|
|
(cond
|
|
[(pair? exp)
|
|
(let* ([fst-exp (car exp)]
|
|
[match (fst-pat fst-exp hole-info)])
|
|
(if match
|
|
(let ([exp-match (map (λ (mtch) (make-mtch (mtch-bindings mtch)
|
|
(build-list-context (mtch-context mtch))
|
|
(mtch-hole mtch)))
|
|
match)])
|
|
(map (lambda (x) (cons exp-match x))
|
|
(loop (cdr patterns) (cdr exp) fail)))
|
|
(fail)))]
|
|
[else
|
|
(fail)])]))]
|
|
[else
|
|
(if (null? exp)
|
|
(list null)
|
|
(fail))]))))
|
|
|
|
(define null-match (list (make-mtch (make-bindings '()) '() none)))
|
|
|
|
(define (match-list/no-repeats patterns exp hole-info)
|
|
|
|
(define (match-list/raw/no-repeats/no-ambiguity patterns exp hole-info)
|
|
(let/ec k
|
|
(define-values (bindings lst hole)
|
|
(let loop ([patterns patterns]
|
|
[exp exp])
|
|
(cond
|
|
[(pair? patterns)
|
|
(let ([fst-pat (car patterns)])
|
|
(cond
|
|
[(pair? exp)
|
|
(let* ([fst-exp (car exp)]
|
|
[fst-mtchs (fst-pat fst-exp hole-info)])
|
|
(cond
|
|
[(not fst-mtchs) (k #f)]
|
|
[(null? (cdr fst-mtchs))
|
|
(define mtch1 (car fst-mtchs))
|
|
(define-values (bindings lst hole) (loop (cdr patterns) (cdr exp)))
|
|
(define new-bindings (bindings-table (mtch-bindings mtch1)))
|
|
(values (append new-bindings bindings)
|
|
(build-cons-context (mtch-context mtch1) lst)
|
|
(pick-hole (mtch-hole mtch1) hole))]
|
|
[else
|
|
(error 'ack)]))]
|
|
[else (k #f)]))]
|
|
[else
|
|
(if (null? exp)
|
|
(values '() '() none)
|
|
(k #f))])))
|
|
(list (make-mtch (make-bindings bindings) lst hole))))
|
|
|
|
(define (match-list/raw/no-repeats patterns exp hole-info)
|
|
(let/ec k
|
|
(let loop ([patterns patterns]
|
|
[exp exp])
|
|
(cond
|
|
[(pair? patterns)
|
|
(let ([fst-pat (car patterns)])
|
|
(cond
|
|
[(pair? exp)
|
|
(let* ([fst-exp (car exp)]
|
|
[fst-mtchs (fst-pat fst-exp hole-info)])
|
|
(cond
|
|
[fst-mtchs
|
|
(define rst-mtchs (loop (cdr patterns) (cdr exp)))
|
|
(cond
|
|
[rst-mtchs
|
|
(combine-pair/no-repeat fst-mtchs rst-mtchs)]
|
|
[else
|
|
(k #f)])]
|
|
[else (k #f)]))]
|
|
[else (k #f)]))]
|
|
[else
|
|
(if (null? exp)
|
|
null-match
|
|
(k #f))]))))
|
|
|
|
;; combine-pair : (listof mtch) (listof mtch) -> (listof mtch)
|
|
(define (combine-pair/no-repeat fst snd)
|
|
(let ([mtchs null])
|
|
(for-each
|
|
(lambda (mtch1)
|
|
(for-each
|
|
(lambda (mtch2)
|
|
(set! mtchs (cons (make-mtch
|
|
(make-bindings (append (bindings-table (mtch-bindings mtch1))
|
|
(bindings-table (mtch-bindings mtch2))))
|
|
(build-cons-context (mtch-context mtch1) (mtch-context mtch2))
|
|
(pick-hole (mtch-hole mtch1)
|
|
(mtch-hole mtch2)))
|
|
mtchs)))
|
|
snd))
|
|
fst)
|
|
mtchs))
|
|
|
|
;(match-list/raw/no-repeats/no-ambiguity patterns exp hole-info)
|
|
(match-list/raw/no-repeats patterns exp hole-info)
|
|
)
|
|
|
|
;; add-ellipses-index : (listof mtch) (or/c sym #f) (or/c sym #f) number -> (listof mtch)
|
|
(define (add-ellipses-index mtchs name mismatch-name i)
|
|
(let* ([ribs '()]
|
|
[ribs (if name
|
|
(cons (make-bind name i) ribs)
|
|
ribs)]
|
|
[ribs (if mismatch-name
|
|
(cons (make-mismatch-bind mismatch-name i) ribs)
|
|
ribs)])
|
|
(map (λ (mtch) (make-mtch (make-bindings (append ribs (bindings-table (mtch-bindings mtch))))
|
|
(mtch-context mtch)
|
|
(mtch-hole mtch)))
|
|
mtchs)))
|
|
|
|
;; 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)
|
|
(let ([multiple-bindings (mtch-bindings multiple-match)])
|
|
(map
|
|
(lambda (single-match)
|
|
(let ([single-bindings (mtch-bindings single-match)])
|
|
(make-mtch (make-bindings
|
|
(map (match-lambda*
|
|
[`(,(struct bind (name sing-exp)) ,(struct bind (name mult-exp)))
|
|
(make-bind name (cons sing-exp mult-exp))]
|
|
[`(,(struct mismatch-bind (name sing-exp)) ,(struct mismatch-bind (name mult-exp)))
|
|
(make-mismatch-bind name (cons sing-exp mult-exp))]
|
|
[else
|
|
(error 'collapse-single-multiples
|
|
"internal error: expected matches' bindings in same order; got\n ~e\n ~e"
|
|
single-bindings
|
|
multiple-bindings)])
|
|
(bindings-table single-bindings)
|
|
(bindings-table multiple-bindings)))
|
|
(build-cons-context
|
|
(mtch-context single-match)
|
|
(mtch-context multiple-match))
|
|
(pick-hole (mtch-hole single-match)
|
|
(mtch-hole multiple-match)))))
|
|
bindingss)))
|
|
multiple-bindingss)))
|
|
|
|
;; 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.rkt "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)
|
|
(map (lambda (match)
|
|
(let ([bindings (mtch-bindings match)])
|
|
(make-mtch
|
|
(make-bindings
|
|
(map (lambda (rib)
|
|
(cond
|
|
[(bind? rib)
|
|
(make-bind (bind-name rib)
|
|
(reverse (bind-exp rib)))]
|
|
[(mismatch-bind? rib)
|
|
(make-mismatch-bind (mismatch-bind-name rib)
|
|
(reverse (mismatch-bind-exp rib)))]))
|
|
(bindings-table bindings)))
|
|
(reverse-context (mtch-context match))
|
|
(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)
|
|
(if hole-info
|
|
|
|
(let loop ([rhss (if (or (null? term) (pair? term))
|
|
list-rhs
|
|
non-list-rhs)]
|
|
[ans '()])
|
|
(cond
|
|
[(null? rhss)
|
|
(if (null? ans)
|
|
#f
|
|
(begin
|
|
(when (check-redudancy)
|
|
(let ([rd (remove-duplicates ans)])
|
|
(unless (= (length rd) (length ans))
|
|
(eprintf "found redundancy when matching the non-terminal ~s against:\n~s~a"
|
|
nt
|
|
term
|
|
(apply
|
|
string-append
|
|
(map (λ (x) (format "\n ~s" x))
|
|
ans))))))
|
|
ans))]
|
|
[else
|
|
(let ([mth (call-nt-proc/bindings (car rhss) term hole-info)])
|
|
(cond
|
|
[mth
|
|
(loop (cdr rhss) (append mth ans))]
|
|
[else
|
|
(loop (cdr rhss) ans)]))]))
|
|
|
|
;; if we're not doing a decomposition, we just need
|
|
;; to find the first match, not all of the matches
|
|
(let loop ([rhss (if (or (null? term) (pair? term))
|
|
list-rhs
|
|
non-list-rhs)])
|
|
(cond
|
|
[(null? rhss) #f]
|
|
[else
|
|
(or (call-nt-proc/bindings (car rhss) term hole-info)
|
|
(loop (cdr rhss)))]))))
|
|
|
|
(define check-redudancy (make-parameter #f))
|
|
|
|
(define (match-nt/boolean list-rhs non-list-rhs nt term)
|
|
(let loop ([rhss (if (or (null? term) (pair? term))
|
|
list-rhs
|
|
non-list-rhs)])
|
|
(cond
|
|
[(null? rhss) #f]
|
|
[else
|
|
(or (call-nt-proc/bool (compiled-pattern-cp (car rhss)) term)
|
|
(loop (cdr rhss)))])))
|
|
|
|
(define (call-nt-proc/bool nt-proc exp)
|
|
(if (procedure-arity-includes? nt-proc 1)
|
|
(nt-proc exp)
|
|
(and (remove-bindings/filter (nt-proc exp #f)) #t)))
|
|
|
|
(define (call-nt-proc/bindings compiled-pattern exp hole-info)
|
|
(define nt-proc (compiled-pattern-cp compiled-pattern))
|
|
(define skip-dup? (compiled-pattern-skip-dup-check? compiled-pattern))
|
|
(define has-names? (compiled-pattern-binds-names? compiled-pattern))
|
|
(cond
|
|
[(procedure-arity-includes? nt-proc 1)
|
|
(and (nt-proc exp)
|
|
(list (make-mtch empty-bindings
|
|
(build-flat-context exp)
|
|
none)))]
|
|
[skip-dup?
|
|
(define res (nt-proc exp hole-info))
|
|
(and res
|
|
(not (null? res))
|
|
(if has-names?
|
|
(map (λ (match)
|
|
(make-mtch empty-bindings
|
|
(mtch-context match)
|
|
(mtch-hole match)))
|
|
res)
|
|
res))]
|
|
[else
|
|
(remove-bindings/filter (nt-proc exp hole-info))]))
|
|
|
|
;; remove-bindings/filter : (union #f (listof mtch)) -> (union #f (listof mtch))
|
|
(define (remove-bindings/filter matches)
|
|
(and matches
|
|
(let ([filtered (filter-multiples matches)])
|
|
;(printf ">> ~s\n=> ~s\n\n" matches filtered)
|
|
(and (not (null? filtered))
|
|
(map (λ (match)
|
|
(make-mtch empty-bindings
|
|
(mtch-context match)
|
|
(mtch-hole match)))
|
|
matches)))))
|
|
|
|
;; rewrite-ellipses : (listof l-pat)
|
|
;; (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 pattern compile)
|
|
(define (maybe-cons hd tl) (if hd (cons hd tl) tl))
|
|
(let loop ([exp-eles pattern])
|
|
(match exp-eles
|
|
[`() (values empty empty empty empty)]
|
|
[(cons `(repeat ,pat ,name ,mismatch-name) rst)
|
|
(define-values (fst-compiled fst-has-hole? fst-has-hide-hole? fst-names) (compile pat))
|
|
(define-values (rst-compiled rst-has-hole? rst-has-hide-hole? rst-names) (loop rst))
|
|
(values (cons (make-repeat fst-compiled
|
|
(extract-empty-bindings pat)
|
|
name
|
|
mismatch-name)
|
|
rst-compiled)
|
|
(cons fst-has-hole? rst-has-hole?)
|
|
(cons (or fst-has-hide-hole? name mismatch-name) rst-has-hide-hole?)
|
|
(cons (maybe-cons name (maybe-cons (and mismatch-name `(mismatch , mismatch-name))
|
|
fst-names))
|
|
rst-names))]
|
|
[(cons pat rst)
|
|
(define-values (fst-compiled fst-has-hole? fst-has-hide-hole? fst-names) (compile pat))
|
|
(define-values (rst-compiled rst-has-hole? rst-has-hide-hole? rst-names) (loop rst))
|
|
(values (cons fst-compiled rst-compiled)
|
|
(cons fst-has-hole? rst-has-hole?)
|
|
(cons fst-has-hide-hole? rst-has-hide-hole?)
|
|
(cons fst-names rst-names))])))
|
|
|
|
(define (prefixed-with? prefix exp)
|
|
(and (symbol? exp)
|
|
(let* ([str (symbol->string exp)]
|
|
[len (string-length str)])
|
|
(and (len . >= . (string-length prefix))
|
|
(string=? (substring str 0 (string-length prefix))
|
|
prefix)))))
|
|
|
|
(define dummy (box 0))
|
|
|
|
;; extract-empty-bindings : pattern -> (listof rib)
|
|
(define (extract-empty-bindings pattern)
|
|
(let loop ([pattern pattern]
|
|
[ribs null])
|
|
(match-a-pattern pattern
|
|
[`any ribs]
|
|
[`number ribs]
|
|
[`string ribs]
|
|
[`natural ribs]
|
|
[`integer ribs]
|
|
[`real ribs]
|
|
[`variable ribs]
|
|
[`(variable-except ,vars ...) ribs]
|
|
[`(variable-prefix ,vars) ribs]
|
|
[`variable-not-otherwise-mentioned ribs]
|
|
|
|
[`hole ribs]
|
|
[`(nt ,nt) ribs]
|
|
[`(name ,name ,pat)
|
|
(cons (make-bind name '()) (loop pat ribs))]
|
|
[`(mismatch-name ,name ,pat)
|
|
(cons (make-mismatch-bind name '()) (loop pat ribs))]
|
|
[`(in-hole ,context ,contractum) (loop contractum (loop context ribs))]
|
|
[`(hide-hole ,p) (loop p ribs)]
|
|
[`(side-condition ,pat ,test ,expr) (loop pat ribs)]
|
|
[`(cross ,id) ribs]
|
|
[`(list ,pats ...)
|
|
(let-values ([(rewritten has-hole? has-hide-hole? names)
|
|
(rewrite-ellipses pats (lambda (x) (values x #f #f '())))])
|
|
(let i-loop ([r-exps rewritten]
|
|
[ribs ribs])
|
|
(cond
|
|
[(null? r-exps) ribs]
|
|
[else (let ([r-exp (car r-exps)])
|
|
(cond
|
|
[(repeat? r-exp)
|
|
(define bindings (if (repeat-mismatch r-exp)
|
|
(list (make-mismatch-bind (repeat-mismatch r-exp) '()))
|
|
'()))
|
|
(define bindings2 (if (repeat-name r-exp)
|
|
(cons (make-bind (repeat-name r-exp) '()) bindings)
|
|
bindings))
|
|
(append bindings2
|
|
(repeat-empty-bindings r-exp)
|
|
(i-loop (cdr r-exps) ribs))]
|
|
[else
|
|
(loop (car r-exps) (i-loop (cdr r-exps) ribs))]))])))]
|
|
[(? (compose not pair?)) 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)
|
|
(let loop ([matchess matchess])
|
|
(cond
|
|
[(null? matchess) combine-matches-base-case]
|
|
[else (combine-pair (car matchess) (loop (cdr matchess)))])))
|
|
|
|
;; this 'inlines' build-flat-context so that the definition can remain here, near where it is used.
|
|
(define combine-matches-base-case (list (make-mtch empty-bindings
|
|
'() #;(build-flat-context '())
|
|
none)))
|
|
|
|
;; combine-pair : (listof mtch) (listof mtch) -> (listof mtch)
|
|
(define (combine-pair fst snd)
|
|
(let ([mtchs null])
|
|
(for-each
|
|
(lambda (mtch1)
|
|
(for-each
|
|
(lambda (mtch2)
|
|
(set! mtchs (cons (make-mtch
|
|
(make-bindings (append (bindings-table (mtch-bindings mtch1))
|
|
(bindings-table (mtch-bindings mtch2))))
|
|
(build-append-context (mtch-context mtch1) (mtch-context mtch2))
|
|
(pick-hole (mtch-hole mtch1)
|
|
(mtch-hole mtch2)))
|
|
mtchs)))
|
|
snd))
|
|
fst)
|
|
mtchs))
|
|
|
|
(define (hash-maps? ht key)
|
|
(not (eq? (hash-ref ht key uniq) uniq)))
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; context adt
|
|
;;
|
|
|
|
#|
|
|
;; This version of the ADT isn't right yet --
|
|
;; need to figure out what to do about (name ...) patterns.
|
|
|
|
(define-values (struct:context make-context context? context-ref context-set!)
|
|
(make-struct-type 'context #f 1 0 #f '() #f 0))
|
|
(define hole values)
|
|
(define (build-flat-context exp) (make-context (lambda (x) exp)))
|
|
(define (build-cons-context c1 c2) (make-context (lambda (x) (cons (c1 x) (c2 x)))))
|
|
(define (build-append-context l1 l2) (make-context (lambda (x) (append (l1 x) (l2 x)))))
|
|
(define (build-list-context l) (make-context (lambda (x) (list (l x)))))
|
|
(define (build-nested-context c1 c2) (make-context (lambda (x) (c1 (c2 x)))))
|
|
(define (plug exp hole-stuff) (exp hole-stuff))
|
|
(define (reverse-context c) (make-context (lambda (x) (reverse (c x)))))
|
|
|
|
|#
|
|
(define (context? x) #t)
|
|
(define-values (the-hole the-not-hole hole?)
|
|
(let ()
|
|
(define-struct hole (id)
|
|
#:property prop:equal+hash (list (λ (x y recur) #t) (λ (v recur) 255) (λ (v recur) 65535))
|
|
#:inspector #f)
|
|
(define the-hole (make-hole 'the-hole))
|
|
(define the-not-hole (make-hole 'the-not-hole))
|
|
(values the-hole the-not-hole hole?)))
|
|
|
|
(define (hole->not-hole exp)
|
|
(let loop ([exp exp])
|
|
(cond
|
|
[(pair? exp)
|
|
(define old-car (car exp))
|
|
(define new-car (loop old-car))
|
|
(cond
|
|
[(eq? new-car old-car)
|
|
(define old-cdr (cdr exp))
|
|
(define new-cdr (loop old-cdr))
|
|
(if (eq? new-cdr old-cdr)
|
|
exp
|
|
(cons new-car new-cdr))]
|
|
[else (cons new-car (cdr exp))])]
|
|
[(eq? exp the-hole)
|
|
the-not-hole]
|
|
[else exp])))
|
|
|
|
(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)
|
|
(plug c1 c2))
|
|
|
|
(define (plug exp hole-stuff)
|
|
(let loop ([exp exp])
|
|
(cond
|
|
[(pair? exp)
|
|
(define old-car (car exp))
|
|
(define new-car (loop old-car))
|
|
(cond
|
|
[(eq? new-car old-car)
|
|
(define old-cdr (cdr exp))
|
|
(define new-cdr (loop old-cdr))
|
|
(if (eq? new-cdr old-cdr)
|
|
exp
|
|
(cons new-car new-cdr))]
|
|
[else (cons new-car (cdr exp))])]
|
|
[(eq? the-not-hole exp)
|
|
the-not-hole]
|
|
[(eq? the-hole exp)
|
|
hole-stuff]
|
|
[else exp])))
|
|
|
|
;;
|
|
;; end context adt
|
|
;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; used in hash lookups to tell when something isn't in the table
|
|
(define uniq (gensym))
|
|
|
|
(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! (-> (and/c integer? positive?) void?))
|
|
(cache-size (and/c integer? positive?))
|
|
|
|
(mtch? predicate/c)
|
|
(make-mtch (bindings? any/c any/c . -> . mtch?))
|
|
(mtch-bindings (mtch? . -> . bindings?))
|
|
(mtch-context (mtch? . -> . any/c))
|
|
(mtch-hole (mtch? . -> . (or/c none? any/c)))
|
|
|
|
(make-bindings ((listof bind?) . -> . bindings?))
|
|
(bindings-table (bindings? . -> . (listof bind?)))
|
|
(bindings? predicate/c)
|
|
|
|
(make-bind (symbol? any/c . -> . bind?))
|
|
(bind? predicate/c)
|
|
(bind-name (bind? . -> . symbol?))
|
|
(bind-exp (bind? . -> . any/c))
|
|
(compile-language (-> any/c (listof nt?) (listof (listof symbol?)) compiled-lang?)))
|
|
(provide compiled-pattern?
|
|
print-stats)
|
|
|
|
;; for test suite
|
|
(provide build-cons-context
|
|
build-flat-context
|
|
context?
|
|
extract-empty-bindings
|
|
(rename-out [bindings-table bindings-table-unchecked])
|
|
(struct-out mismatch-bind)
|
|
(struct-out compiled-pattern))
|
|
|
|
(provide (struct-out nt)
|
|
(struct-out rhs)
|
|
(struct-out compiled-lang)
|
|
compiled-lang-cclang
|
|
|
|
lookup-binding
|
|
|
|
compiled-pattern
|
|
|
|
plug
|
|
none? none
|
|
|
|
make-repeat
|
|
the-not-hole the-hole hole?
|
|
rewrite-ellipses
|
|
build-compatible-context-language
|
|
caching-enabled?
|
|
check-redudancy)
|