diff --git a/bench/rich-integer-chez.scm b/bench/rich-integer-chez.scm new file mode 100644 index 0000000000000000000000000000000000000000..5919b2e1a1b5159731d2f5ed035b8404a2bd7880 --- /dev/null +++ b/bench/rich-integer-chez.scm @@ -0,0 +1,51 @@ +(define-syntax chained-lambda + (syntax-rules () + ((_ (args ...) body ...) + (lambda (args ... . rest) + (let ((result (begin body ...))) + (if (null? rest) + result + (apply result rest))))))) + +(define (gen-dispatcher table) + (lambda args + (cond + ((null? args) (error 'me "unexpected")) + (else + (apply + (symbol-hashtable-ref table (car args) (lambda r (error 'me "unexpected"))) + (cdr args)))))) + +(define (rint x) + (let ((self '*)) + (define table (make-hashtable symbol-hash eq?)) + (set! self (gen-dispatcher table)) + + (symbol-hashtable-set! table 'set! (chained-lambda (y) (set! x y) self)) + (symbol-hashtable-set! table 'sqrt + (lambda () + (if (< x 0) + (error) + (inexact->exact (floor (sqrt x)))))) + (symbol-hashtable-set! table 'to-string (lambda () (number->string x))) + self)) + +(define (repeat n proc) + (when (>= n 0) + (proc) + (repeat (- n 1) proc))) + +(define (timing msg thunk) + (let* ((start-time (current-time)) + (result (thunk)) + (end-time (current-time))) + (format #t "~a elapsed ~a ms\n" msg (/ (time-nanosecond (time-difference end-time start-time)) 1000000.0)))) + +(timing "rint sqrt" (lambda () (repeat 100000 (lambda () ((rint 65536) 'sqrt))))) +(timing "rint to-string" (lambda () (repeat 100000 (lambda () ((rint 65536) 'to-string))))) +(timing "rint set!+sqrt" + (lambda () + (let loop ((n 100000)) + (when (> n 0) + ((rint 65536) 'set! n 'sqrt) + (loop (- n 1)))))) diff --git a/bench/rich-integer.scm b/bench/rich-integer.scm index bd778b5581fa331ac5dcb382dbb1b893d8c415a8..a8a10e581fa0b4129055536d5e7324ed4c8a5298 100644 --- a/bench/rich-integer.scm +++ b/bench/rich-integer.scm @@ -20,7 +20,7 @@ (let* ((start (current-jiffy)) (val (thunk)) (end (current-jiffy))) - (display* msg (number->string (- end start)) "\n"))) + (display* msg (number->string (/ (- end start) 1000.0)) " ms \n"))) (define (repeat n proc) (when (>= n 0) @@ -52,7 +52,7 @@ r)))) (define rint-lambda -(lambda args (define (@is-type-of obj) (and (case-class? obj) (obj :is-instance-of 'rich-integer))) (define (@max-value) 9223372036854775807) (define (@min-value) -9223372036854775808) (define (is-normal-function? msg) (and (symbol? msg) (char=? (string-ref (symbol->string msg) 0) #\:))) (define (static-dispatcher msg . args) (cond ((eq? msg :is-type-of) (apply @is-type-of args)) ((eq? msg :max-value) (apply @max-value args)) ((eq? msg :min-value) (apply @min-value args)) (else (value-error "No such static method " msg)))) (define* (make-case-class-rich-integer data) (unless (integer? data) (type-error (format #f "In funtion #<~a ~a>: argument *~a* must be *~a*! **Got ~a**" make-case-class-rich-integer '(data) 'data "integer" (object->string data)))) (define {gensym}-171 #f) (define (%this . xs) (if (null? xs) {gensym}-171 (apply {gensym}-171 xs))) (define (%is-instance-of x) (eq? x 'rich-integer)) (define (%equals that) (unless (case-class? that) (type-error (format #f "In funtion #<~a ~a>: argument *~a* must be *~a*! **Got ~a**" %equals '(that) 'that "case-class" (object->string that)))) (and (that :is-instance-of 'rich-integer) (equal? data (that 'data)))) (define (%apply . args) (cond ((null? args) (value-error rich-integer "Apply on zero args is not implemented")) ((equal? ((symbol->string (car args)) 0) #\:) (value-error rich-integer "No such method: " (car args))) (else (value-error rich-integer "No such field: " (car args))))) (define (%to-string) (let ((field-strings (list (string-append ":data" " " (object->string data))))) (let loop ((strings field-strings) (acc "")) (if (null? strings) (string-append "(" "rich-integer" " " acc ")") (loop (cdr strings) (if (zero? (string-length acc)) (car strings) (string-append acc " " (car strings)))))))) (define (%get) data) (define (%to n) (unless (integer? n) (type-error (format #f "In funtion #<~a ~a>: argument *~a* must be *~a*! **Got ~a**" %to '(n) 'n "integer" (object->string n)))) (if (< n data) (rich-list (list)) (rich-list (iota (+ (- n data) 1) data)))) (define (%until n) (unless (integer? n) (type-error (format #f "In funtion #<~a ~a>: argument *~a* must be *~a*! **Got ~a**" %until '(n) 'n "integer" (object->string n)))) (if (<= n data) (rich-list (list)) (rich-list (iota (+ (- n data)) data)))) (define (%to-rich-char) (rich-char data)) (define (%to-string) (number->string data)) (define (%sqrt) (if (< data 0) (value-error (format #f "sqrt of negative integer is undefined! ** Got ~a **" data)) (inexact->exact (floor (sqrt data))))) (define (instance-dispatcher) (lambda (msg . args) (cond ((eq? msg :sqrt) (apply %sqrt args)) ((eq? msg :is-instance-of) (apply %is-instance-of args)) ((eq? msg :equals) (apply %equals args)) ((eq? msg :to-string) (%to-string)) ((eq? msg :this) (apply %this args)) ((eq? msg :data) (rich-integer (car args))) ((is-normal-function? msg) (case msg ((:get) (apply %get args)) ((:to) (apply %to args)) ((:until) (apply %until args)) ((:to-rich-char) (apply %to-rich-char args)) ((:to-string) (apply %to-string args)) ((:sqrt) (apply %sqrt args)) (else (value-error rich-integer "No such method: " msg)))) ((eq? msg 'data) data) (else (apply %apply (cons msg args)))))) (set! {gensym}-171 (instance-dispatcher)) {gensym}-171) (if (null? args) (make-case-class-rich-integer) (let ((msg (car args))) (cond ((in? msg (list :max-value :min-value :is-type-of)) (apply static-dispatcher args)) ((and (zero? 1) (in? :apply (list :max-value :min-value))) (apply static-dispatcher (cons :apply args))) (else (apply make-case-class-rich-integer args)))))) +(lambda args (define (@is-type-of obj) (and (case-class? obj) (obj :is-instance-of 'rich-integer))) (define (@max-value) 9223372036854775807) (define (@min-value) -9223372036854775808) (define (is-normal-function? msg) (and (symbol? msg) (char=? (string-ref (symbol->string msg) 0) #\:))) (define (static-dispatcher msg . args) (cond ((eq? msg :is-type-of) (apply @is-type-of args)) ((eq? msg :max-value) (apply @max-value args)) ((eq? msg :min-value) (apply @min-value args)) (else (value-error "No such static method " msg)))) (define* (make-case-class-rich-integer data) (unless (integer? data) (type-error (format #f "In funtion #<~a ~a>: argument *~a* must be *~a*! **Got ~a**" make-case-class-rich-integer '(data) 'data "integer" (object->string data)))) (define {gensym}-171 #f) (define (%this . xs) (if (null? xs) {gensym}-171 (apply {gensym}-171 xs))) (define (%is-instance-of x) (eq? x 'rich-integer)) (define (%equals that) (unless (case-class? that) (type-error (format #f "In funtion #<~a ~a>: argument *~a* must be *~a*! **Got ~a**" %equals '(that) 'that "case-class" (object->string that)))) (and (that :is-instance-of 'rich-integer) (equal? data (that 'data)))) (define (%apply . args) (cond ((null? args) (value-error rich-integer "Apply on zero args is not implemented")) ((equal? ((symbol->string (car args)) 0) #\:) (value-error rich-integer "No such method: " (car args))) (else (value-error rich-integer "No such field: " (car args))))) (define (%to-string) (let ((field-strings (list (string-append ":data" " " (object->string data))))) (let loop ((strings field-strings) (acc "")) (if (null? strings) (string-append "(" "rich-integer" " " acc ")") (loop (cdr strings) (if (zero? (string-length acc)) (car strings) (string-append acc " " (car strings)))))))) (define (%get) data) (define (%to n) (unless (integer? n) (type-error (format #f "In funtion #<~a ~a>: argument *~a* must be *~a*! **Got ~a**" %to '(n) 'n "integer" (object->string n)))) (if (< n data) (rich-list (list)) (rich-list (iota (+ (- n data) 1) data)))) (define (%until n) (unless (integer? n) (type-error (format #f "In funtion #<~a ~a>: argument *~a* must be *~a*! **Got ~a**" %until '(n) 'n "integer" (object->string n)))) (if (<= n data) (rich-list (list)) (rich-list (iota (+ (- n data)) data)))) (define (%to-rich-char) (rich-char data)) (define (%to-string) (number->string data)) (define (%sqrt) (if (< data 0) (value-error (format #f "sqrt of negative integer is undefined! ** Got ~a **" data)) (inexact->exact (floor (sqrt data))))) (define (instance-dispatcher) (lambda (msg . args) (cond ((eq? msg :sqrt) (apply %sqrt args)) ((eq? msg :is-instance-of) (apply %is-instance-of args)) ((eq? msg :equals) (apply %equals args)) ((eq? msg :to-string) (%to-string)) ((eq? msg :this) (apply %this args)) ((eq? msg :data) (rich-integer (car args))) ((is-normal-function? msg) (case msg ((:get) (apply %get args)) ((:to) (apply %to args)) ((:until) (apply %until args)) ((:to-rich-char) (apply %to-rich-char args)) ((:to-string) (apply %to-string args)) ((:sqrt) (apply %sqrt args)) (else (value-error rich-integer "No such method: " msg)))) ((eq? msg 'data) data) (else (apply %apply (cons msg args)))))) (set! {gensym}-171 (instance-dispatcher)) {gensym}-171) (if (null? args) (make-case-class-rich-integer) (let ((msg (car args))) (cond ((member msg (list :max-value :min-value :is-type-of)) (apply static-dispatcher args)) ((and (zero? 1) (member :apply (list :max-value :min-value))) (apply static-dispatcher (cons :apply args))) (else (apply make-case-class-rich-integer args)))))) ) (with-let (funclet rint) @@ -71,24 +71,92 @@ (inexact->exact (floor (sqrt data))))) (varlet (funclet rint) '%sqrt %sqrt)) + +(define (rich-integer-s7 . init-instance) + (define static-dispatcher (inlet 'init-instance init-instance)) + (define (@max-value) 9223372036854775807) + (define (@min-value) -9223372036854775808) + + (define (rich-integer-instance data) + + (define %this (inlet 'data data)) + + (define (%is-instance-of x) (eq? x 'rich-integer)) + + (define (%apply msg . args) + (if (defined? msg %this) + (apply (%this msg) args))) + + (define (%equals that) + (= (%this 'data) (that 'data))) + + (define (%set-number! new-num . rest-agrs) + (let-set! %this 'data new-num) + (if (null? rest-agrs) + %this + (apply %this rest-agrs))) + + (define (%get-number) (%this 'data)) + + (define (%to-string) (number->string (%this 'data))) + + (define (%to-rich-string) (rich-string (number->string (%this 'data)))) + + (define (%to n) + (if (< n (%this 'data)) + (list) + (iota (+ (- n (%this 'data)) 1) (%this 'data)))) + + (define (%sqrt) + (if (< data 0) + (error 'value (format #f "sqrt of negative integer is undefined! ** Got ~a **" data)) + (inexact->exact (floor (sqrt data))))) + + (varlet %this + 'equals %equals + 'set-number! %set-number! + 'get-number %get-number + 'to-string %to-string + 'apply %apply + 'to-rich-string %to-rich-string + 'is-instance-of %is-instance-of + 'to %to) + + %this) + + (varlet static-dispatcher + 'max-value @max-value + 'min-value @min-value) + + (if (and (symbol? (car init-instance)) + (defined? (car init-instance) static-dispatcher #t)) + (apply static-dispatcher init-instance) + (apply rich-integer-instance init-instance)) +) + (display* "Bench of number->string:\n") -(timing "prim%to-string:\t\t\t" (lambda () (repeat 10000 (lambda () (number->string 65536))))) -(timing "rich-integer%to-string:\t\t" (lambda () (repeat 10000 (lambda () ((rich-integer 65536) :to-string))))) -(timing "rich-integer2%to-string:\t" (lambda () (repeat 10000 (lambda () ((rich-integer2 65536) :to-string))))) -(timing "rint%to-string:\t\t\t" (lambda () (repeat 10000 (lambda () ((rint 65536) :to-string))))) +(timing "prim%to-string:\t\t\t" (lambda () (repeat 100000 (lambda () (number->string 65536))))) +(timing "rich-integer%to-string:\t\t" (lambda () (repeat 100000 (lambda () ((rich-integer 65536) :to-string))))) +(timing "rich-integer2%to-string:\t" (lambda () (repeat 100000 (lambda () ((rich-integer2 65536) :to-string))))) +(timing "rint%to-string:\t\t\t" (lambda () (repeat 100000 (lambda () ((rint 65536) :to-string))))) +(timing "rich-integer-s7%to-string:\t" (lambda () (repeat 100000 (lambda () ((rich-integer-s7 65536) :to-string))))) (display* ((rint 65535) :to-string)) (newline) (display* "\n\nBench of SQRT:\n") -(timing "prim%sqrt:\t\t\t" (lambda () (repeat 10000 (lambda () (prim-sqrt 65536))))) -(timing "rint%sqrt:\t\t\t" (lambda () (repeat 10000 (lambda () ((rint 65536) :sqrt))))) -(timing "rint-lambda%sqrt:\t\t" (lambda () (repeat 10000 (lambda () ((rint-lambda 65536) :sqrt))))) +(timing "prim%sqrt:\t\t\t" (lambda () (repeat 100000 (lambda () (prim-sqrt 65536))))) +(timing "rint%sqrt:\t\t\t" (lambda () (repeat 100000 (lambda () ((rint 65536) :sqrt))))) +(timing "rint-lambda%sqrt:\t\t" (lambda () (repeat 100000 (lambda () ((rint-lambda 65536) :sqrt))))) +(timing "rich-integer-s7%sqrt:\t\t" (lambda () (repeat 100000 (lambda () ((rich-integer-s7 65536) :sqrt))))) -(display "\nBench of integer\n") -(timing "rich-integer%sqrt:\t\t" (lambda () (repeat 10000 (lambda () ((rich-integer 65536) :sqrt))))) -(display* ((rint 65535) :sqrt)) +(display "\nBench of origin-rich-integer\n") +(timing "rich-integer%sqrt:\t\t" (lambda () (repeat 100000 (lambda () ((rich-integer 65536) :sqrt))))) +(display "\nBench of new-rich-integer\n") +(timing "rich-integer-s7%set!+sqrt:\t" (lambda () (repeat 100000 (lambda () ((rich-integer-s7 65536) :set-number! 65536 :sqrt))))) + +(display* ((rint 65535) :sqrt)) ; slow because of rich-string ; (timing "rint%to-rich-string " (lambda () (repeat 1000 (lambda () (((rint 65536) :to-rich-string) :length)))))