emo/thin-provisioning-tools
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

[functional-tests/regex] tidying

Browse Source
This commit is contained in:
Joe Thornber 2017-08-20 14:36:02 +01:00
parent 08ce1967ae
commit c921233f3c
1 changed files with 64 additions and 64 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

128
functional-tests/regex.scm
View File

@ -125,21 +125,30 @@
(instr (loop (+ 1 pc) (cdr code) (cons instr acc))))))) (instr (loop (+ 1 pc) (cdr code) (cons instr acc)))))))
(define (optimise-jumps! code) (define (optimise-jumps! code)
(upto (n (vector-length code)) (define (single-pass)
(match (vector-ref code n) (let ((changed #f))
(('jmp l) (upto (n (vector-length code))
(when (match-instr? (vector-ref code l)) (match (vector-ref code n)
(vector-set! code n (match-instr)))) (('jmp l)
(when (match-instr? (vector-ref code l))
(set! changed #t)
(vector-set! code n (match-instr))))
(('split l1 l2) (('split l1 l2)
(when (or (match-instr? (vector-ref code l1)) (when (or (match-instr? (vector-ref code l1))
(match-instr? (vector-ref code l2))) (match-instr? (vector-ref code l2)))
(vector-set! code n (match-instr)))) (set! changed #t)
(vector-set! code n (match-instr))))
(_ _))) (_ _)))
changed))
(let loop ()
(when (single-pass)
(loop)))
code) code)
(define (compile-rx% rx) (define (compile-to-symbols rx)
(let ((rx (append-instr rx (match-instr)))) (let ((rx (append-instr rx (match-instr))))
(optimise-jumps! (optimise-jumps!
(list->vector (list->vector
@ -177,14 +186,6 @@
(define (no-threads? y) (define (no-threads? y)
(zero? (yarn-size y))) (zero? (yarn-size y)))
(define (any-matches? y code)
(call/cc
(lambda (k)
(while (i (pop-thread! y))
(if (match-instr? (vector-ref code i))
(k #t)))
#f)))
(define-syntax swap (define-syntax swap
(syntax-rules () (syntax-rules ()
((_ x y) ((_ x y)
@ -193,59 +194,58 @@
(set! y tmp))))) (set! y tmp)))))
(define (compile-rx rx) (define (compile-rx rx)
(let ((code (compile-rx% rx))) (let* ((sym-code (compile-to-symbols rx))
;(fmt #t (dsp "running ") (pretty code) nl) (code-len (vector-length sym-code))
(let ((code-len (vector-length code))) (threads (mk-yarn code-len))
(let ((threads (mk-yarn code-len)) (next-threads (mk-yarn code-len))
(next-threads (mk-yarn code-len))) (code #f))
(define (compile-instr instr) (define (compile-instr instr)
(match instr (match instr
(('match) (('match)
(lambda (in-c pc) 'match)) (lambda (in-c pc) 'match))
(('char c) (('char c)
(lambda (in-c pc) (lambda (in-c pc)
(when (char=? c in-c) ;; use eq? because in-c isn't always a char
(add-thread! next-threads (+ 1 pc))))) (when (eq? c in-c)
(add-thread! next-threads (+ 1 pc)))))
(('jmp l) (('jmp l)
(lambda (in-c pc) (lambda (in-c pc)
(add-thread! threads l))) (add-thread! threads l)))
(('split l1 l2) (('split l1 l2)
(lambda (in-c pc) (lambda (in-c pc)
(add-thread! threads l1) (add-thread! threads l1)
(add-thread! threads l2))))) (add-thread! threads l2)))))
;; compile to closures to avoid calling match in the loop. (define (step in-c)
(let ((code (vector-copy code))) (let loop ((pc (pop-thread! threads)))
(and pc
(if (eq? 'match ((vector-ref code pc) in-c pc))
'match
(loop (pop-thread! threads))))))
(define (step in-c) ;(fmt #t (dsp "running ") (pretty code) nl)
(let loop ((pc (pop-thread! threads)))
(if pc
(if (eq? 'match ((vector-ref code pc) in-c pc))
'match
(loop (pop-thread! threads)))
#f)))
(upto (n code-len) ;; compile to closures to avoid calling match in the loop.
(vector-set! code n (compile-instr (vector-ref code n)))) (upto (n code-len)
(set! code (vector-map compile-instr sym-code)))
(lambda (txt) (lambda (txt)
(add-thread! threads 0) (add-thread! threads 0)
(let ((txt-len (string-length txt))) (let ((txt-len (string-length txt)))
(let c-loop ((c-index 0)) (let c-loop ((c-index 0))
(if (< c-index txt-len) (when (< c-index txt-len)
(if (eq? 'match (step (string-ref txt c-index))) (if (eq? 'match (step (string-ref txt c-index)))
#t #t
(if (no-threads? next-threads) (if (no-threads? next-threads)
#f #f
(begin (begin
(swap threads next-threads) (swap threads next-threads)
(clear-yarn! next-threads) (clear-yarn! next-threads)
(c-loop (+ 1 c-index))))) (c-loop (+ 1 c-index)))))))))))
(any-matches? threads code))))))))))
;;;-------------------------------------------------------- ;;;--------------------------------------------------------
;;; Parser ;;; Parser