Skip to content

Instantly share code, notes, and snippets.

@ktakashi

ktakashi/bench.scm

Created November 15, 2017 07:51
Show Gist options
  • Save ktakashi/03a2edcecc259b4d7b3c8af39e4c19de to your computer and use it in GitHub Desktop.
Save ktakashi/03a2edcecc259b4d7b3c8af39e4c19de to your computer and use it in GitHub Desktop.
Download ZIP
Experimental PEG 2
Raw
bench.scm
(import (rnrs) (packrat) (time))
(define (generator tokens)
(let ((stream tokens))
(lambda ()
(if (null? stream)
(values #f #f)
(let ((base-token (car stream)))
(set! stream (cdr stream))
(values #f base-token))))))
(define calc (packrat-parser expr
(expr ((a <- mulexp '+ b <- mulexp)
(+ a b))
((a <- mulexp) a))
(mulexp ((a <- simple '* b <- simple)
(* a b))
((a <- simple) a))
(simple ((a <- 'num) a)
(('oparen a <- expr 'cparen) a))))
(define-syntax repeat
(syntax-rules ()
((_ n expr expr* ...)
(let ((thunk (lambda () expr expr* ...)))
(do ((t n) (i 0 (+ i 1)))
((= i t))
(thunk))))))
(define count 10000)
(print "Packrat")
(time
(repeat count
(let* ((g (generator '((num . 1) (+) (num . 2) (*) (num . 3)))))
(assert (= 7 (parse-result-semantic-value
(calc (base-generator->results g))))))))
(print "\nMemoized generator")
(load "peg.scm")
(load "peg-calc.scm")
(time
(repeat count
(let ((g (list->generator '((num . 1) (+) (num . 2) (*) (num . 3)))))
(let-values (((s v g) (%expr g)))
(assert (= 7 v))))))
(print "\nLazy sequence")
(load "peg-lseq.scm")
(load "peg-calc.scm")
(time
(repeat count
(let ((l (generator->lseq
(list->generator '((num . 1) (+) (num . 2) (*) (num . 3))))))
(let-values (((s v nl) (%expr l)))
(assert (= 7 v))))))
(print "\nStream")
(load "peg-strm.scm")
(load "peg-calc.scm")
(define-stream (generator->stream g)
(stream-let loop ((v (g)))
(if (eof-object? v)
stream-null
(stream-cons v (loop (g))))))
(time
(repeat count
(let ((l (generator->stream
(list->generator '((num . 1) (+) (num . 2) (*) (num . 3))))))
(let-values (((s v nl) (%expr l)))
(assert (= 7 v))))))
Raw
peg-calc.scm
(define %expr1
($and-let* ((a %mulexp)
( ($? (lambda (v) (eq? (car v) '+))) )
(b %mulexp))
($return (+ a b))))
(define %expr2
($let* ((a %mulexp))
($return a)))
(define %expr ($or %expr1 %expr2))
(define %mulexp1
($and-let* ((a %simple)
( ($? (lambda (v) (eq? (car v) '*))) )
(b %simple))
($return (* a b))))
(define %mulexp2
($let* ((a %simple))
($return a)))
(define %mulexp ($or %mulexp1 %mulexp2))
(define %simple1
($let* ((a ($? (lambda (v) (eq? (car v) 'num))))) ($return (cdr a))))
(define %simple2
($and-let* (( ($= (lambda (v) (eq? (car v) 'oparen))) )
(a %expr)
( ($? (lambda (v) (eq? (car v) 'cparen))) ))
($return (cdr a))))
(define %simple ($or %simple1 %simple2))
Raw
peg-lseq.scm
(import (rnrs) (srfi :127))
(define $return
(case-lambda
((v) (lambda (l) (values 'success v l)))
((v state) (lambda (l) (values state v l)))
((v state l) (lambda (_) (values state v l)))))
(define ($? pred)
(lambda (l)
(let ((v (lseq-car l)))
(if (pred v)
(values 'success v (lseq-cdr l))
(values 'fail v (lseq-cdr l))))))
(define ($eof l)
(if (null? l)
(values 'success l l)
(values 'fail l l)))
(define ($not parser)
(lambda (l)
(let-values (((s v nl) (parser l)))
(case s
((success) (values 'fail v nl))
(else (values 'success v nl))))))
(define ($or . expr)
(lambda (l)
(let loop ((e* expr))
(if (null? e*)
(values 'fail #f l)
(let-values (((s v nl) ((car e*) l)))
(case s
((success) (values s v nl))
(else (loop (cdr expr)))))))))
(define ($and . expr)
(lambda (l)
(let loop ((e* expr) (nl l))
(if (null? e*)
(values 'success #t nl)
(let-values (((s v nl2) ((car e*) nl)))
(case s
((success)
(if (null? (cdr e*))
(values s v nl2)
(loop (cdr expr) nl2)))
(else (values s v l))))))))
(define ($debug parser)
(lambda (s)
(let-values (((r v s) (parser s)))
(display "status : ") (write r) (newline)
(display "result : ") (write v) (newline)
(display "rest : ") (write s) (newline)
(values r v s))))
(define-syntax $let*
(syntax-rules ()
((_ ((var expr)) body)
(lambda (g)
(let-values (((r var ng) (($and ($not $eof) expr) g)))
(case r
((success) (body ng))
(else (values r var ng))))))
((_ ((var expr) rest ...) body)
(lambda (g)
(let-values (((r var ng) (($and ($not $eof) expr) g)))
(case r
((success) (($let* (rest ...) body) ng))
(else (values r var ng))))))))
(define-syntax $and-let*
(syntax-rules ()
((_ "parse" () (b ...) body)
($let* (b ...) body))
((_ "parse" ((e) r ...) (b ...) body)
($and-let* "parse" (r ...) (b ... (d e)) body))
((_ "parse" ((v e) r ...) (b ...) body)
($and-let* "parse" (r ...) (b ... (v e)) body))
((_ (e ...) body)
($and-let* "parse" (e ...) () body))))
Raw
peg-memoized-generator.scm
(import (rnrs) (sagittarius generators) (srfi :117))
;; peg consumes generator
(define $return
(case-lambda
((v) (lambda (g) (values 'success v g)))
((v state) (lambda (g) (values state v g)))
((v state g) (lambda (_) (values state v g)))))
(define ($? pred)
(lambda (g)
(let ((v (g)))
(if (pred v)
(values 'success v g)
(values 'fail v g)))))
(define (make-memoize-generator g)
(define queue (list-queue))
(define use g)
(define (make-queue-generator)
(lambda ()
(when use (set! use #f))
(if (list-queue-empty? queue)
(eof-object)
(list-queue-remove-front! queue))))
(values
(lambda ()
(glet1 v (use)
(list-queue-add-back! queue v)
v))
(gappend (make-queue-generator) g)))
(define ($try parser)
(lambda (g)
(let*-values (((new-g memo-g) (make-memoize-generator g))
((s v _) (parser new-g)))
(case s
((success) (values s v g))
(else (values s v memo-g))))))
(define ($eof g)
(let-values (((new-g memo-g) (make-memoize-generator g)))
(let ((v (new-g)))
(if (eof-object? v)
(values 'success v memo-g)
(values 'fail v memo-g)))))
(define ($not parser)
(lambda (g)
(let-values (((s v ng) (parser g)))
(case s
((success) (values 'fail v ng))
(else (values 'success v ng))))))
(define ($or . expr)
(lambda (g)
(let loop ((e* expr) (g g))
(let-values (((new-g memo-g) (make-memoize-generator g)))
(if (null? e*)
(values 'fail #f memo-g)
(let-values (((s v ng) ((car e*) new-g)))
(case s
((success) (values s v ng))
(else (loop (cdr expr) memo-g)))))))))
(define ($and . expr)
(lambda (g)
(let-values (((new-g memo-g) (make-memoize-generator g)))
(let loop ((e* expr) (g new-g))
(if (null? e*)
(values 'success #t g)
(let-values (((s v ng) ((car e*) g)))
(case s
((success)
(if (null? (cdr e*))
(values s v ng)
(loop (cdr expr) ng)))
(else (values s v memo-g)))))))))
(define ($debug parser)
(lambda (s)
(let-values (((r v s) (parser s)))
(display "status : ") (write r) (newline)
(display "result : ") (write v) (newline)
(display "rest : ") (write s) (newline)
(values r v s))))
(define-syntax $let*
(syntax-rules ()
((_ ((var expr)) body)
(lambda (g)
(let-values (((r var ng) (($and ($not $eof) expr) g)))
(case r
((success) (body ng))
(else (values r var ng))))))
((_ ((var expr) rest ...) body)
(lambda (g)
(let-values (((r var ng) (($and ($not $eof) expr) g)))
(case r
((success) (($let* (rest ...) body) ng))
(else (values r var ng))))))))
(define-syntax $and-let*
(syntax-rules ()
((_ "parse" () (b ...) body)
($let* (b ...) body))
((_ "parse" ((e) r ...) (b ...) body)
($and-let* "parse" (r ...) (b ... (d e)) body))
((_ "parse" ((v e) r ...) (b ...) body)
($and-let* "parse" (r ...) (b ... (v e)) body))
((_ (e ...) body)
($and-let* "parse" (e ...) () body))))
Raw
peg-strm.scm
(import (rnrs) (srfi :41))
(define $return
(case-lambda
((v) (lambda (l) (values 'success v l)))
((v state) (lambda (l) (values state v l)))
((v state l) (lambda (_) (values state v l)))))
(define ($? pred)
(lambda (l)
(let ((v (stream-car l)))
(if (pred v)
(values 'success v (stream-cdr l))
(values 'fail v (stream-cdr l))))))
(define ($eof l)
(if (stream-null? l)
(values 'success l l)
(values 'fail l l)))
(define ($not parser)
(lambda (l)
(let-values (((s v nl) (parser l)))
(case s
((success) (values 'fail v nl))
(else (values 'success v nl))))))
(define ($or . expr)
(lambda (l)
(let loop ((e* expr))
(if (null? e*)
(values 'fail #f l)
(let-values (((s v nl) ((car e*) l)))
(case s
((success) (values s v nl))
(else (loop (cdr expr)))))))))
(define ($and . expr)
(lambda (l)
(let loop ((e* expr) (nl l))
(if (null? e*)
(values 'success #t nl)
(let-values (((s v nl2) ((car e*) nl)))
(case s
((success)
(if (null? (cdr e*))
(values s v nl2)
(loop (cdr expr) nl2)))
(else (values s v l))))))))
(define ($debug parser)
(lambda (s)
(let-values (((r v s) (parser s)))
(display "status : ") (write r) (newline)
(display "result : ") (write v) (newline)
(display "rest : ") (write s) (newline)
(values r v s))))
(define-syntax $let*
(syntax-rules ()
((_ ((var expr)) body)
(lambda (g)
(let-values (((r var ng) (($and ($not $eof) expr) g)))
(case r
((success) (body ng))
(else (values r var ng))))))
((_ ((var expr) rest ...) body)
(lambda (g)
(let-values (((r var ng) (($and ($not $eof) expr) g)))
(case r
((success) (($let* (rest ...) body) ng))
(else (values r var ng))))))))
(define-syntax $and-let*
(syntax-rules ()
((_ "parse" () (b ...) body)
($let* (b ...) body))
((_ "parse" ((e) r ...) (b ...) body)
($and-let* "parse" (r ...) (b ... (d e)) body))
((_ "parse" ((v e) r ...) (b ...) body)
($and-let* "parse" (r ...) (b ... (v e)) body))
((_ (e ...) body)
($and-let* "parse" (e ...) () body))))
Raw
result.log
$ sash bench.scm
Packrat
;; (repeat count (let* ((g (generator '((num . 1) (+) (num . 2) (*) (num . 3))))) (assert (= 7 (parse-result-semantic-value (calc (base-generator->results g)))))))
;; 0.610148 real 0.940000 user 0.024000 sys
Memoized generator
;; (repeat count (let ((g (list->generator '((num . 1) (+) (num . 2) (*) (num . 3))))) (let-values (((s v g) (%expr g))) (assert (= 7 v)))))
;; 0.778732 real 1.236000 user 0.020000 sys
Lazy sequence
;; (repeat count (let ((l (generator->lseq (list->generator '((num . 1) (+) (num . 2) (*) (num . 3)))))) (let-values (((s v nl) (%expr l))) (assert (= 7 v)))))
;; 0.092914 real 0.156000 user 0.004000 sys
Stream
;; (repeat count (let ((l (generator->stream (list->generator '((num . 1) (+) (num . 2) (*) (num . 3)))))) (let-values (((s v nl) (%expr l))) (assert (= 7 v)))))
;; 0.783042 real 1.228000 user 0.024000 sys
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment