123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444 |
- (define-module (ps-compiler simp pattern)
- #:use-module (system syntax)
- #:use-module (prescheme scheme48)
- #:use-module (prescheme s48-defrecord)
- #:use-module (prescheme record-discloser)
- #:use-module (prescheme syntax-utils)
- #:use-module (ps-compiler node let-nodes)
- #:export (pattern-simplifier))
- (define-syntax pattern-simplifier
- (lambda (x)
- (syntax-case x ()
- ((_ spec ...)
- (set! *generate-symbol-index* 0)
- (let* ((specs (syntax->datum #'(spec ...)))
- (initial (generate-symbol 'initial))
- (exp (match-calls (map (lambda (spec)
- (make-pattern (car spec) (cdr spec)))
- specs)
- initial
- #f
- (lambda (patterns)
- (if (null? patterns)
- (error "no patterns matched" specs)
- (check-predicates patterns initial))))))
- (datum->syntax x `(lambda (,initial)
- ,(cadar (cddr exp)))))))))
- (define (name=? a b)
- (eq? a b))
- (define-record-type pattern
- (spec
- (env)
-
- parent
-
- predicate
- build-spec
- )
- ())
- (define-record-discloser type/pattern
- (lambda (p)
- (list 'pattern (pattern-spec p))))
- (define (pattern-arg pattern i)
- (list-ref (pattern-spec pattern) (+ i 1)))
- (define (make-pattern spec specs)
- (receive (build-spec predicate)
- (if (null? (cdr specs))
- (values (car specs) #f)
- (values (cadr specs) (car specs)))
- (pattern-maker spec '() #f predicate build-spec)))
- (define (extend-pattern-envs patterns i id)
- (map (lambda (pattern)
- (let ((arg (pattern-arg pattern i)))
- (set-pattern-env! pattern
- (cons (if (pair? arg)
- (list (cadr arg) id #t)
- (list arg id #f))
- (pattern-env pattern)))))
- patterns))
- (define (get-pattern-parent pattern)
- (let ((p (pattern-parent pattern)))
- (set-pattern-env! p (pattern-env pattern))
- p))
- (define (match-calls patterns call-var fail-var more)
- (let ((primop-var (generate-symbol 'primop)))
- (let loop ((patterns patterns) (res '()))
- (if (null? patterns)
- (finish-call-match res call-var primop-var fail-var)
- (let ((primop (car (pattern-spec (car patterns)))))
- (receive (same other)
- (partition-list (lambda (p)
- (name=? primop (car (pattern-spec p))))
- (cdr patterns))
- (loop other
- (cons `(,(if (number? primop) 'else `(,primop))
- ,(match-call-args (cons (car patterns) same)
- 0
- call-var
- fail-var
- more))
- res))))))))
- (define (finish-call-match clauses call-var primop-var fail-var)
- (receive (elses other)
- (partition-list (lambda (c)
- (name=? (car c) 'else))
- clauses)
- `(case (primop-id (call-primop ,call-var))
- ,@(reverse other)
- (else ,(cond ((null? elses)
- (if fail-var `(,fail-var) #f))
- ((null? (cdr elses))
- `(let ((,primop-var (call-primop ,call-var)))
- ,(cadar elses)))
- (else
- (error "more than one ELSE clause" elses)))))))
- (define (match-call-args patterns i call-var fail-var more)
- (if (>= i (length (cdr (pattern-spec (car patterns)))))
- (more patterns)
- (receive (atom-patterns other-patterns)
- (partition-list (lambda (p)
- (atom? (pattern-arg p i)))
- patterns)
- (let* ((arg-var (generate-symbol 'arg))
- (else-code (cond ((null? atom-patterns)
- #f)
- (else
- (extend-pattern-envs atom-patterns i arg-var)
- (match-call-args atom-patterns (+ i 1)
- call-var fail-var more))))
- (fail-var (if else-code (generate-symbol 'fail) fail-var))
- (more (lambda (patterns)
- (match-call-args patterns (+ i 1)
- call-var fail-var more))))
- (let loop ((patterns other-patterns) (clauses '()))
- (if (null? patterns)
- (finish-match-call-args i call-var arg-var fail-var
- else-code clauses)
- (let ((first (car patterns)))
- (receive (same other)
- (partition-list (lambda (p)
- (same-arg-pattern? first p i))
- (cdr patterns))
- (loop other
- (cons (match-call-arg (cons first same)
- i
- arg-var
- fail-var
- more)
- clauses))))))))))
- (define (finish-match-call-args i call-var arg-var fail-var else-code clauses)
- `(let ((,arg-var (call-arg ,call-var ,i)))
- ,(if else-code
- `(let ((,fail-var (lambda () ,else-code)))
- (cond ,@clauses (else (,fail-var))))
- `(cond ,@clauses (else ,(if fail-var `(,fail-var) #f))))))
- (define (same-arg-pattern? p1 p2 i)
- (let ((a1 (pattern-arg p1 i))
- (a2 (pattern-arg p2 i)))
- (cond ((atom? a1)
- (atom? a2))
- ((atom? a2)
- #f)
- ((name=? (car a1) 'quote)
- (name=? (car a2) 'quote))
- ((name=? (car a2) 'quote)
- #f)
- (else #t))))
- (define (match-call-arg patterns i arg-var fail-var more)
- (let ((arg (pattern-arg (car patterns) i)))
- (cond ((name=? (car arg) 'quote)
- `((literal-node? ,arg-var)
- ,(match-literal patterns i arg-var fail-var more)))
- (else
- `((call-node? ,arg-var)
- ,(match-calls (map (lambda (p)
- (pattern-maker (pattern-arg p i)
- (pattern-env p)
- p
- (pattern-predicate p)
- (pattern-build-spec p)))
- patterns)
- arg-var
- fail-var
- (lambda (patterns)
- (more (map get-pattern-parent patterns)))))))))
- (define (match-literal patterns i arg-var fail-var more)
- (receive (symbols numbers)
- (partition-list (lambda (p)
- (name? (cadr (pattern-arg p i))))
- patterns)
- (extend-pattern-envs symbols i arg-var)
- (if (null? numbers)
- (more symbols)
- (let loop ((patterns numbers) (clauses '()))
- (if (null? patterns)
- (finish-match-literal clauses
- (if (null? symbols)
- (if fail-var `(,fail-var) #f)
- (more symbols))
- arg-var)
- (receive (same other)
- (partition-list (lambda (p)
- (= (cadr (pattern-arg (car patterns) i))
- (cadr (pattern-arg p i))))
- (cdr patterns))
- (loop other
- (cons `((,(cadr (pattern-arg (car patterns) i)))
- ,(more (cons (car patterns) same)))
- clauses))))))))
- (define (name? x)
- (not (or (pair? x)
- (number? x))))
- (define (finish-match-literal clauses else arg-var)
- (if (null? clauses)
- else
- `(case (literal-value ,arg-var)
- ,@(reverse clauses)
- (else ,else))))
- (define *generate-symbol-index* 0)
- (define (generate-symbol sym)
- (let ((i *generate-symbol-index*))
- (set! *generate-symbol-index* (+ i 1))
- (concatenate-symbol sym "." i)))
- (define (check-predicates patterns initial)
- (let label ((patterns patterns))
- (cond ((null? (cdr patterns))
- (let ((pattern (car patterns)))
- (if (pattern-predicate pattern)
- (make-predicate-check pattern initial #f)
- (make-builder pattern initial))))
- ((pattern-predicate (car patterns))
- (make-predicate-check (car patterns)
- initial
- (label (cdr patterns))))
- (else
- (error "multiple patterns matched ~S"
- patterns)))))
- (define (make-predicate-check pattern initial rest)
- `(if (let ,(map (lambda (p)
- `(,(car p) ,(if (caddr p)
- `(literal-value ,(cadr p))
- (cadr p))))
- (pattern-env pattern))
- ,(pattern-predicate pattern))
- ,(make-builder pattern initial)
- ,rest))
- (define (make-builder pattern initial)
- (let ((env (map (lambda (p)
- (list (car p) (cadr p) #f))
- (pattern-env pattern)))
- (pattern (pattern-build-spec pattern))
- (sym (generate-symbol 'result)))
- (let ((clauses (if (and (pair? pattern)
- (not (name=? (car pattern) 'quote)))
- (reverse (build-call sym pattern env))
- '()))
- (value (cond ((not (pair? pattern))
- (lookup-pattern pattern env))
- ((name=? (car pattern) 'quote)
- `(make-literal-node ,(build-literal (cadr pattern) env)
- (node-type ,initial)))
- (else
- sym))))
- `(begin
- ,@(filter-map (lambda (data)
- (if (caddr data)
- `(detach ,(cadr data))
- #f))
- env)
- (let-nodes ,clauses
- (replace ,initial ,value))))))
- (define (build-call id pattern env)
- (let loop ((arg-patterns (cdr pattern)) (args '()) (clauses '()))
- (if (null? arg-patterns)
- `((,id (,(car pattern) 0 . ,(reverse args)))
- . ,clauses)
- (let ((arg (car arg-patterns)))
- (cond ((atom? arg)
- (loop (cdr arg-patterns)
- (cons (lookup-pattern arg env) args)
- clauses))
- ((name=? (car arg) 'quote)
- (loop (cdr arg-patterns)
- (cons `'(,(build-literal (cadr arg) env)
- type/unknown)
- args)
- clauses))
- (else
- (let ((sym (generate-symbol 'new)))
- (loop (cdr arg-patterns)
- (cons sym args)
- (append (build-call sym arg env) clauses)))))))))
- (define (build-literal spec env)
- (cond ((number? spec)
- spec)
- ((name? spec)
- `(literal-value ,(lookup-literal spec env)))
- (else
- `(,(car spec)
- . ,(map (lambda (a)
- (build-literal a env))
- (cdr spec))))))
- (define (lookup-literal pattern env)
- (cond ((assoc pattern env)
- => cadr)
- (else
- (error "pattern ~S not found in env" pattern))))
- (define (lookup-pattern pattern env)
- (cond ((assoc pattern env)
- => (lambda (data)
- (if (caddr data)
- (error "node ~S is used more than once" (car data)))
- (set-car! (cddr data) 1)
- (cadr data)))
- (else
- (error "pattern ~S not found in env" pattern))))
|