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

[functional-tests/regex] more optimisation.

Browse Source 
I think we're going to have to lose the call/cc; something is allocating
a lot of memory.
This commit is contained in:
Joe Thornber 2017-08-18 19:28:07 +01:00
parent 2fb7eb265f
commit 27eb4d8ce4
2 changed files with 51 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
functional-tests/regex-bench.scm Normal file
View File

@ -0,0 +1,11 @@
(import (chezscheme)
(regex)
(loops))
(let ((rx (compile-rx
(seq (seq (star (lit "a"))
(lit "foo"))
(plus
(lit "b"))))))
(time (upto (n 1000000)
(rx "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaafoobbbbbbb"))))

79
functional-tests/regex.scm
View File

@ -6,8 +6,7 @@
opt opt
star star
plus plus
compile-rx compile-rx)
match-rx)
(import (chezscheme) (import (chezscheme)
(fmt fmt) (fmt fmt)
(loops) (loops)
@ -140,7 +139,7 @@
(_ _))) (_ _)))
code) code)
(define (compile-rx rx) (define (compile-rx% rx)
(let ((rx (append-instr rx (match-instr)))) (let ((rx (append-instr rx (match-instr))))
(optimise-jumps! (optimise-jumps!
(list->vector (list->vector
@ -200,48 +199,50 @@
(set! x y) (set! x y)
(set! y tmp))))) (set! y tmp)))))
(define (match-rx code txt) (define (compile-rx rx)
; (fmt #t (dsp "running ") (pretty code) nl) ; (fmt #t (dsp "running ") (pretty code) nl)
(call/cc (let ((code (compile-rx% rx)))
(lambda (k) (let ((code-len (vector-length code)))
(let ((code-len (vector-length code))) (let ((threads (mk-thread-set code-len))
(let ((threads (mk-thread-set code-len)) (next-threads (mk-thread-set code-len)))
(next-threads (mk-thread-set code-len)))
(define (compile-instr instr) (define (compile-instr instr)
(match instr (match instr
(('match) (('match)
(lambda (_ pc) (k #t))) (lambda (in-c pc k) (k #t)))
(('char c) (('char c)
(lambda (in-c pc) (lambda (in-c pc k)
(when (char=? c in-c) (when (char=? c in-c)
(add-thread! next-threads (+ 1 pc))))) (add-thread! next-threads (+ 1 pc)))))
(('jmp l) (('jmp l)
(lambda (in-c pc) (lambda (in-c pc k)
(add-thread! threads l))) (add-thread! threads l)))
(('split l1 l2) (('split l1 l2)
(lambda (in-c pc) (lambda (in-c pc k)
(add-thread! threads l1) (add-thread! threads l1)
(add-thread! threads l2))))) (add-thread! threads l2)))))
;; compile to thunks to avoid calling match in the loop. ;; compile to thunks to avoid calling match in the loop.
(let ((code (vector-copy code))) (let ((code (vector-copy code)))
(upto (n code-len) (upto (n code-len)
(vector-set! code n (compile-instr (vector-ref code n)))) (vector-set! code n (compile-instr (vector-ref code n))))
(add-thread! threads 0) (lambda (txt)
(string-iter (in-c txt) (call/cc
; (fmt #t (dsp "processing: ") (wrt in-c) nl) (lambda (k)
(while (pc (pop-thread! threads)) (add-thread! threads 0)
((vector-ref code pc) in-c pc)) (string-iter (in-c txt)
(if (no-threads? next-threads) ; (fmt #t (dsp "processing: ") (wrt in-c) nl)
(k #f) (while (pc (pop-thread! threads))
(begin ((vector-ref code pc) in-c pc k))
(swap threads next-threads) (if (no-threads? next-threads)
(clear-thread-set! next-threads))))) (k #f)
(any-matches? threads code)))))) (begin
(swap threads next-threads)
(clear-thread-set! next-threads))))
(any-matches? threads code)))))))))
) )