;;; -*- Mode: scheme; coding:us-ascii -*-
;;; This is code for MIT/GNU Scheme. We attempt to measure the speed of ASSQ.
;;; The code avoids obvious abstractions because we don't want to
;;; measure the speed of function calling.
;; Inline the standard scheme primitives.
(declare (usual-integrations))
;; We change the size and alignment of the heap by consing a small
;; data structure to this list.
(define *change-heap-size-and-alignment* '())
;;; Creates a test alist that looks like this:
;;; ((13 . "13")
;;; (23 . "23")
;;; (25 . "25")
;;; (18 . "18")
;;; (0 . "0")
;;; (19 . "19")
;;; (5 . "5")
;;; (4 . "4")
;;; (6 . "6")
;;; ...
;;;
(define (make-test-alist n-elements)
(let ((alist
(fold-left (lambda (alist number)
(alist-cons number (number->string number)
alist))
'()
;; shuffle the numbers from 1 to n
(map car
(sort
(map (lambda (n)
(cons n (random 1.0)))
(iota n-elements))
(lambda (l r) (< (cdr l) (cdr r))))))))
(gc-flip)
(set! *change-heap-size-and-alignment*
(cons (vector #f) *change-heap-size-and-alignment*))
alist))
;;; Creates an alist of <size> entries and then measures the time to
;;; perform n-lookups on it. Specialized to fixnum-only arithmetic.
(define (time-alist size n-lookups)
(let ((test-alist (make-test-alist size)))
(show-time
(lambda ()
(do ((i 0 (fix:+ i 1))
(idx 0 (if (fix:> idx size)
0
(fix:+ idx 1)))
(answer '() (assq idx test-alist)))
((fix:>= i n-lookups) answer))))))
Here's a sample run on my laptop. We make an alist with 10 elements and call ASSQ 100,000,000 times on it, fetching each entry about the same number of times.1 ]=> (do ((i 0 (+ i 1))) ((not (< i 10))) (time-alist 10 100000000)) ;process time: 2260 (2260 RUN + 0 GC); real time: 2259 ;process time: 2260 (2260 RUN + 0 GC); real time: 2265 ;process time: 2290 (2290 RUN + 0 GC); real time: 2291 ;process time: 2250 (2250 RUN + 0 GC); real time: 2247 ;process time: 2260 (2260 RUN + 0 GC); real time: 2259 ;process time: 2240 (2240 RUN + 0 GC); real time: 2240 ;process time: 2240 (2240 RUN + 0 GC); real time: 2243 ;process time: 2250 (2250 RUN + 0 GC); real time: 2258 ;process time: 2240 (2240 RUN + 0 GC); real time: 2247 ;process time: 2250 (2250 RUN + 0 GC); real time: 2250Process time is reported in milliseconds, so it took about 2.26 seconds to do 100,000,000 million lookups. This divides out to .0000000225 seconds = 22.5 nanoseconds per lookup.
It should be about linear with the size of the list, so we'd expect a 100 element list to take somewhere around 225 nanoseconds.
1 ]=> (do ((i 0 (+ i 1))) ((not (< i 10))) (time-alist 100 100000000)) ;process time: 20720 (20720 RUN + 0 GC); real time: 20753 ;process time: 20700 (20700 RUN + 0 GC); real time: 20733 ;process time: 20640 (20640 RUN + 0 GC); real time: 20671 ;process time: 20690 (20690 RUN + 0 GC); real time: 20695 ;process time: 20670 (20670 RUN + 0 GC); real time: 20690 ;process time: 21010 (21010 RUN + 0 GC); real time: 21026 ;process time: 20800 (20800 RUN + 0 GC); real time: 20832 ;process time: 20760 (20760 RUN + 0 GC); real time: 20747 ;process time: 20710 (20710 RUN + 0 GC); real time: 20702 ;process time: 20690 (20690 RUN + 0 GC); real time: 20700 ;Value: #tTesting a hash table:
(define (make-test-hash-table n-entries)
(alist->hash-table (make-test-alist n-entries)))
;;; Creates a hash-table of <size> entries and then measures the time to
;;; perform n-lookups on it. Specialized to fixnum-only arithmetic.
(define (time-hash-table size n-lookups)
(let ((test-hash-table (make-test-hash-table size)))
(show-time
(lambda ()
(do ((i 0 (fix:+ i 1))
(idx 0 (if (fix:> idx size)
0
(fix:+ idx 1)))
(answer '() (hash-table/get test-hash-table idx #f)))
((fix:>= i n-lookups) answer))))))
Put 10 elements or a thousand in a hash table, it takes a constant amount of time to look things up:1 ]=> (do ((i 0 (+ i 1))) ((not (< i 10))) (time-hash-table 10 100000000)) ;process time: 8320 (8320 RUN + 0 GC); real time: 8321 ;process time: 8300 (8300 RUN + 0 GC); real time: 8304 ;process time: 8420 (8420 RUN + 0 GC); real time: 8419 ;process time: 8280 (8280 RUN + 0 GC); real time: 8304 ;process time: 8380 (8380 RUN + 0 GC); real time: 8387 ;process time: 8280 (8280 RUN + 0 GC); real time: 8288 ;process time: 8320 (8320 RUN + 0 GC); real time: 8311 ;process time: 8330 (8330 RUN + 0 GC); real time: 8327 ;process time: 8290 (8290 RUN + 0 GC); real time: 8290 ;process time: 8310 (8310 RUN + 0 GC); real time: 8307 ;Value: #t 1 ]=> (do ((i 0 (+ i 1))) ((not (< i 10))) (time-hash-table 1000 100000000)) ;process time: 8400 (8400 RUN + 0 GC); real time: 8403 ;process time: 8550 (8550 RUN + 0 GC); real time: 8553 ;process time: 8620 (8620 RUN + 0 GC); real time: 8639 ;process time: 8420 (8420 RUN + 0 GC); real time: 8435 ;process time: 8400 (8400 RUN + 0 GC); real time: 8425 ;process time: 8460 (8460 RUN + 0 GC); real time: 8455 ;process time: 8460 (8460 RUN + 0 GC); real time: 8459 ;process time: 8480 (8480 RUN + 0 GC); real time: 8486 ;process time: 8500 (8500 RUN + 0 GC); real time: 8502 ;process time: 8520 (8520 RUN + 0 GC); real time: 8518 ;Value: #tTesting an rb-tree:
(define (make-test-rb-tree n-entries)
(alist->rb-tree (make-test-alist n-entries) fix:= fix:<))
;;; Creates a rb-tree of <size> entries and then measures the time to
;;; perform n-lookups on it. Specialized to fixnum-only arithmetic.
(define (time-rb-tree size n-lookups)
(let ((test-rb-tree (make-test-rb-tree size)))
(show-time
(lambda ()
(do ((i 0 (fix:+ i 1))
(idx 0 (if (fix:> idx size)
0
(fix:+ idx 1)))
(answer '() (rb-tree/lookup test-rb-tree idx #f)))
((fix:>= i n-lookups) answer))))))
1 ]=> (do ((i 0 (+ i 1))) ((not (< i 10))) (time-rb-tree 10 100000000))
;process time: 3910 (3910 RUN + 0 GC); real time: 3908
;process time: 3810 (3810 RUN + 0 GC); real time: 3805
;process time: 4090 (4090 RUN + 0 GC); real time: 4090
;process time: 3970 (3970 RUN + 0 GC); real time: 3967
;process time: 4060 (4060 RUN + 0 GC); real time: 4051
;process time: 3980 (3980 RUN + 0 GC); real time: 3979
;process time: 4040 (4040 RUN + 0 GC); real time: 4040
;process time: 4090 (4090 RUN + 0 GC); real time: 4094
;process time: 3810 (3810 RUN + 0 GC); real time: 3810
;process time: 4090 (4090 RUN + 0 GC); real time: 4092
;Value: #t
1 ]=> (do ((i 0 (+ i 1))) ((not (< i 10))) (time-rb-tree 100 100000000))
;process time: 7700 (7700 RUN + 0 GC); real time: 7720
;process time: 7760 (7760 RUN + 0 GC); real time: 7767
;process time: 7700 (7700 RUN + 0 GC); real time: 7710
;process time: 7890 (7890 RUN + 0 GC); real time: 7893
;process time: 7920 (7920 RUN + 0 GC); real time: 7914
;process time: 7650 (7650 RUN + 0 GC); real time: 7646
;process time: 7740 (7740 RUN + 0 GC); real time: 7738
;process time: 7760 (7760 RUN + 0 GC); real time: 7761
;process time: 7670 (7670 RUN + 0 GC); real time: 7671
;process time: 8140 (8140 RUN + 0 GC); real time: 8136
;Value: #t
1 ]=> (do ((i 0 (+ i 1))) ((not (< i 10))) (time-rb-tree 1000 100000000))
;process time: 13130 (13130 RUN + 0 GC); real time: 13124
;process time: 13160 (13160 RUN + 0 GC); real time: 13153
;process time: 13150 (13150 RUN + 0 GC); real time: 13149
;process time: 13140 (13140 RUN + 0 GC); real time: 13140
;process time: 13310 (13310 RUN + 0 GC); real time: 13304
;process time: 13170 (13170 RUN + 0 GC); real time: 13172
;process time: 13140 (13140 RUN + 0 GC); real time: 13167
;process time: 13250 (13250 RUN + 0 GC); real time: 13238
;process time: 13300 (13300 RUN + 0 GC); real time: 13318
;process time: 13420 (13420 RUN + 0 GC); real time: 13416
;Value: #t
And wt-trees while we're at it:(define (make-test-wt-tree n-elements)
(alist->wt-tree number-wt-type (make-test-alist n-elements)))
(define (time-wt-tree size n-lookups)
(let ((test-wt-tree (make-test-wt-tree size)))
(show-time
(lambda ()
(do ((i 0 (fix:+ i 1))
(idx 0 (if (fix:> idx size)
0
(fix:+ idx 1)))
(answer '() (wt-tree/lookup test-wt-tree idx #f)))
((fix:>= i n-lookups) answer))))))1 ]=> (do ((i 0 (+ i 1))) ((not (< i 10))) (time-wt-tree 100 100000000)) ;process time: 6400 (6400 RUN + 0 GC); real time: 6397 ;process time: 6740 (6740 RUN + 0 GC); real time: 6736 ;process time: 6760 (6760 RUN + 0 GC); real time: 6763 ;process time: 6070 (6070 RUN + 0 GC); real time: 6068 ;process time: 6450 (6450 RUN + 0 GC); real time: 6461 ;process time: 6800 (6800 RUN + 0 GC); real time: 6812 ;process time: 6330 (6330 RUN + 0 GC); real time: 6346 ;process time: 6060 (6060 RUN + 0 GC); real time: 6066 ;process time: 6050 (6050 RUN + 0 GC); real time: 6039 ;process time: 6300 (6300 RUN + 0 GC); real time: 6303 ;Value: #t
No comments:
Post a Comment