From a173c507aa6d87ad2b6daf76a1b43c87aa9f761e Mon Sep 17 00:00:00 2001 From: TREE_3 Date: Tue, 3 Jun 2025 18:21:02 +0800 Subject: [PATCH 1/3] add bench of chez scheme --- bench/rich-integer-chez.scm | 51 +++++++++++++++++++++++++++++++++++++ bench/rich-integer.scm | 47 ++++++++++++++++++++++++++-------- 2 files changed, 87 insertions(+), 11 deletions(-) create mode 100644 bench/rich-integer-chez.scm diff --git a/bench/rich-integer-chez.scm b/bench/rich-integer-chez.scm new file mode 100644 index 00000000..5919b2e1 --- /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 bd778b55..0d69fae5 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,49 @@ (inexact->exact (floor (sqrt data))))) (varlet (funclet rint) '%sqrt %sqrt)) +(define (rich-integer-s7 data) + (define %this (inlet 'data data)) + + (define (%get) (%this 'data)) + + (define (%to-string) (number->string (%this 'data))) + + (define (%to-rich-char) + (rich-char data)) + + (define (%sqrt) + (if (< data 0) + (value-error + (format #f "sqrt of negative integer is undefined! ** Got ~a **" data)) + (inexact->exact (floor (sqrt data))))) + + (varlet %this + 'get %get + 'to-string %to-string + 'to-rich-char %to-rich-char + 'sqrt %sqrt) + %this) + (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))))) +(timing "rich-integer%sqrt:\t\t" (lambda () (repeat 100000 (lambda () ((rich-integer 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))))) -- Gitee From a046a1f98ab249b555dd9bcad5175bbb40394ffe Mon Sep 17 00:00:00 2001 From: TREE_3 Date: Wed, 4 Jun 2025 09:52:35 +0800 Subject: [PATCH 2/3] add bench --- bench/rich-integer.scm | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/bench/rich-integer.scm b/bench/rich-integer.scm index 0d69fae5..68bfb112 100644 --- a/bench/rich-integer.scm +++ b/bench/rich-integer.scm @@ -74,6 +74,12 @@ (define (rich-integer-s7 data) (define %this (inlet 'data 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) (%this 'data)) (define (%to-string) (number->string (%this 'data))) @@ -89,6 +95,7 @@ (varlet %this 'get %get + 'set-number! %set-number! 'to-string %to-string 'to-rich-char %to-rich-char 'sqrt %sqrt) @@ -111,9 +118,12 @@ (timing "rich-integer-s7%sqrt:\t\t" (lambda () (repeat 100000 (lambda () ((rich-integer-s7 65536) :sqrt))))) -(display "\nBench of integer\n") +(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))))) -- Gitee From 9443829c5e7a823328f8ae2c9003b480f97506a1 Mon Sep 17 00:00:00 2001 From: TREE_3 Date: Wed, 4 Jun 2025 13:28:12 +0800 Subject: [PATCH 3/3] add static method --- bench/rich-integer.scm | 85 +++++++++++++++++++++++++++++------------- 1 file changed, 59 insertions(+), 26 deletions(-) diff --git a/bench/rich-integer.scm b/bench/rich-integer.scm index 68bfb112..a8a10e58 100644 --- a/bench/rich-integer.scm +++ b/bench/rich-integer.scm @@ -71,35 +71,68 @@ (inexact->exact (floor (sqrt data))))) (varlet (funclet rint) '%sqrt %sqrt)) -(define (rich-integer-s7 data) - (define %this (inlet 'data 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) (%this 'data)) - (define (%to-string) (number->string (%this 'data))) +(define (rich-integer-s7 . init-instance) + (define static-dispatcher (inlet 'init-instance init-instance)) + (define (@max-value) 9223372036854775807) + (define (@min-value) -9223372036854775808) - (define (%to-rich-char) - (rich-char data)) + (define (rich-integer-instance data) - (define (%sqrt) - (if (< data 0) - (value-error - (format #f "sqrt of negative integer is undefined! ** Got ~a **" data)) - (inexact->exact (floor (sqrt data))))) - - (varlet %this - 'get %get - 'set-number! %set-number! - 'to-string %to-string - 'to-rich-char %to-rich-char - 'sqrt %sqrt) - %this) + (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 100000 (lambda () (number->string 65536))))) -- Gitee