Commit | Line | Data |
---|---|---|
1b706edf LC |
1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
2 | ; File: perm9.sch | |
3 | ; Description: memory system benchmark using Zaks's permutation generator | |
4 | ; Author: Lars Hansen, Will Clinger, and Gene Luks | |
5 | ; Created: 18-Mar-94 | |
6 | ; Language: Scheme | |
7 | ; Status: Public Domain | |
8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
9 | ||
10 | ; 940720 / lth Added some more benchmarks for the thesis paper. | |
11 | ; 970215 / wdc Increased problem size from 8 to 9; improved tenperm9-benchmark. | |
12 | ; 970531 / wdc Cleaned up for public release. | |
13 | ; 000820 / wdc Added the MpermNKL benchmark; revised for new run-benchmark. | |
14 | ||
15 | ; This benchmark is in four parts. Each tests a different aspect of | |
16 | ; the memory system. | |
17 | ; | |
18 | ; perm storage allocation | |
19 | ; 10perm storage allocation and garbage collection | |
20 | ; sumperms traversal of a large, linked, self-sharing structure | |
21 | ; mergesort! side effects and write barrier | |
22 | ; | |
23 | ; The perm9 benchmark generates a list of all 362880 permutations of | |
24 | ; the first 9 integers, allocating 1349288 pairs (typically 10,794,304 | |
25 | ; bytes), all of which goes into the generated list. (That is, the | |
26 | ; perm9 benchmark generates absolutely no garbage.) This represents | |
27 | ; a savings of about 63% over the storage that would be required by | |
28 | ; an unshared list of permutations. The generated permutations are | |
29 | ; in order of a grey code that bears no obvious relationship to a | |
30 | ; lexicographic order. | |
31 | ; | |
32 | ; The 10perm9 benchmark repeats the perm9 benchmark 10 times, so it | |
33 | ; allocates and reclaims 13492880 pairs (typically 107,943,040 bytes). | |
34 | ; The live storage peaks at twice the storage that is allocated by the | |
35 | ; perm9 benchmark. At the end of each iteration, the oldest half of | |
36 | ; the live storage becomes garbage. Object lifetimes are distributed | |
37 | ; uniformly between 10.3 and 20.6 megabytes. | |
38 | ; | |
39 | ; The 10perm9 benchmark is the 10perm9:2:1 special case of the | |
40 | ; MpermNKL benchmark, which allocates a queue of size K and then | |
41 | ; performs M iterations of the following operation: Fill the queue | |
42 | ; with individually computed copies of all permutations of a list of | |
43 | ; size N, and then remove the oldest L copies from the queue. At the | |
44 | ; end of each iteration, the oldest L/K of the live storage becomes | |
45 | ; garbage, and object lifetimes are distributed uniformly between two | |
46 | ; volumes that depend upon N, K, and L. | |
47 | ; | |
48 | ; The sumperms benchmark computes the sum of the permuted integers | |
49 | ; over all permutations. | |
50 | ; | |
51 | ; The mergesort! benchmark destructively sorts the generated permutations | |
52 | ; into lexicographic order, allocating no storage whatsoever. | |
53 | ; | |
54 | ; The benchmarks are run by calling the following procedures: | |
55 | ; | |
56 | ; (perm-benchmark n) | |
57 | ; (tenperm-benchmark n) | |
58 | ; (sumperms-benchmark n) | |
59 | ; (mergesort-benchmark n) | |
60 | ; | |
61 | ; The argument n may be omitted, in which case it defaults to 9. | |
62 | ; | |
63 | ; These benchmarks assume that | |
64 | ; | |
65 | ; (RUN-BENCHMARK <string> <thunk> <count>) | |
66 | ; (RUN-BENCHMARK <string> <count> <thunk> <predicate>) | |
67 | ; | |
68 | ; reports the time required to call <thunk> the number of times | |
69 | ; specified by <count>, and uses <predicate> to test whether the | |
70 | ; result returned by <thunk> is correct. | |
71 | ||
72 | ; Date: Thu, 17 Mar 94 19:43:32 -0800 | |
73 | ; From: luks@sisters.cs.uoregon.edu | |
74 | ; To: will | |
75 | ; Subject: Pancake flips | |
76 | ; | |
77 | ; Procedure P_n generates a grey code of all perms of n elements | |
78 | ; on top of stack ending with reversal of starting sequence | |
79 | ; | |
80 | ; F_n is flip of top n elements. | |
81 | ; | |
82 | ; | |
83 | ; procedure P_n | |
84 | ; | |
85 | ; if n>1 then | |
86 | ; begin | |
87 | ; repeat P_{n-1},F_n n-1 times; | |
88 | ; P_{n-1} | |
89 | ; end | |
90 | ; | |
91 | ||
92 | (define (permutations x) | |
93 | (let ((x x) | |
94 | (perms (list x))) | |
95 | (define (P n) | |
96 | (if (> n 1) | |
97 | (do ((j (- n 1) (- j 1))) | |
98 | ((zero? j) | |
99 | (P (- n 1))) | |
100 | (P (- n 1)) | |
101 | (F n)))) | |
102 | (define (F n) | |
103 | (set! x (revloop x n (list-tail x n))) | |
104 | (set! perms (cons x perms))) | |
105 | (define (revloop x n y) | |
106 | (if (zero? n) | |
107 | y | |
108 | (revloop (cdr x) | |
109 | (- n 1) | |
110 | (cons (car x) y)))) | |
111 | (define (list-tail x n) | |
112 | (if (zero? n) | |
113 | x | |
114 | (list-tail (cdr x) (- n 1)))) | |
115 | (P (length x)) | |
116 | perms)) | |
117 | ||
118 | ; Given a list of lists of numbers, returns the sum of the sums | |
119 | ; of those lists. | |
120 | ; | |
121 | ; for (; x != NULL; x = x->rest) | |
122 | ; for (y = x->first; y != NULL; y = y->rest) | |
123 | ; sum = sum + y->first; | |
124 | ||
125 | (define (sumlists x) | |
126 | (do ((x x (cdr x)) | |
127 | (sum 0 (do ((y (car x) (cdr y)) | |
128 | (sum sum (+ sum (car y)))) | |
129 | ((null? y) sum)))) | |
130 | ((null? x) sum))) | |
131 | ||
132 | ; Destructive merge of two sorted lists. | |
133 | ; From Hansen's MS thesis. | |
134 | ||
135 | (define (merge!! a b less?) | |
136 | ||
137 | (define (loop r a b) | |
138 | (if (less? (car b) (car a)) | |
139 | (begin (set-cdr! r b) | |
140 | (if (null? (cdr b)) | |
141 | (set-cdr! b a) | |
142 | (loop b a (cdr b)) )) | |
143 | ;; (car a) <= (car b) | |
144 | (begin (set-cdr! r a) | |
145 | (if (null? (cdr a)) | |
146 | (set-cdr! a b) | |
147 | (loop a (cdr a) b)) )) ) | |
148 | ||
149 | (cond ((null? a) b) | |
150 | ((null? b) a) | |
151 | ((less? (car b) (car a)) | |
152 | (if (null? (cdr b)) | |
153 | (set-cdr! b a) | |
154 | (loop b a (cdr b))) | |
155 | b) | |
156 | (else ; (car a) <= (car b) | |
157 | (if (null? (cdr a)) | |
158 | (set-cdr! a b) | |
159 | (loop a (cdr a) b)) | |
160 | a))) | |
161 | ||
162 | ||
163 | ;; Stable sort procedure which copies the input list and then sorts | |
164 | ;; the new list imperatively. On the systems we have benchmarked, | |
165 | ;; this generic list sort has been at least as fast and usually much | |
166 | ;; faster than the library's sort routine. | |
167 | ;; Due to Richard O'Keefe; algorithm attributed to D.H.D. Warren. | |
168 | ||
169 | (define (sort!! seq less?) | |
170 | ||
171 | (define (step n) | |
172 | (cond ((> n 2) | |
173 | (let* ((j (quotient n 2)) | |
174 | (a (step j)) | |
175 | (k (- n j)) | |
176 | (b (step k))) | |
177 | (merge!! a b less?))) | |
178 | ((= n 2) | |
179 | (let ((x (car seq)) | |
180 | (y (cadr seq)) | |
181 | (p seq)) | |
182 | (set! seq (cddr seq)) | |
183 | (if (less? y x) | |
184 | (begin | |
185 | (set-car! p y) | |
186 | (set-car! (cdr p) x))) | |
187 | (set-cdr! (cdr p) '()) | |
188 | p)) | |
189 | ((= n 1) | |
190 | (let ((p seq)) | |
191 | (set! seq (cdr seq)) | |
192 | (set-cdr! p '()) | |
193 | p)) | |
194 | (else | |
195 | '()))) | |
196 | ||
197 | (step (length seq))) | |
198 | ||
199 | (define lexicographically-less? | |
200 | (lambda (x y) | |
201 | (define (lexicographically-less? x y) | |
202 | (cond ((null? x) (not (null? y))) | |
203 | ((null? y) #f) | |
204 | ((< (car x) (car y)) #t) | |
205 | ((= (car x) (car y)) | |
206 | (lexicographically-less? (cdr x) (cdr y))) | |
207 | (else #f))) | |
208 | (lexicographically-less? x y))) | |
209 | ||
210 | ; This procedure isn't used by the benchmarks, | |
211 | ; but is provided as a public service. | |
212 | ||
213 | (define (internally-imperative-mergesort list less?) | |
214 | ||
215 | (define (list-copy l) | |
216 | (define (loop l prev) | |
217 | (if (null? l) | |
218 | #t | |
219 | (let ((q (cons (car l) '()))) | |
220 | (set-cdr! prev q) | |
221 | (loop (cdr l) q)))) | |
222 | (if (null? l) | |
223 | l | |
224 | (let ((first (cons (car l) '()))) | |
225 | (loop (cdr l) first) | |
226 | first))) | |
227 | ||
228 | (sort!! (list-copy list) less?)) | |
229 | ||
230 | (define *perms* '()) | |
231 | ||
232 | (define (one..n n) | |
233 | (do ((n n (- n 1)) | |
234 | (p '() (cons n p))) | |
235 | ((zero? n) p))) | |
236 | ||
237 | (define (perm-benchmark . rest) | |
238 | (let ((n (if (null? rest) 9 (car rest)))) | |
239 | (set! *perms* '()) | |
240 | (run-benchmark (string-append "Perm" (number->string n)) | |
241 | 1 | |
242 | (lambda () | |
243 | (set! *perms* (permutations (one..n n))) | |
244 | #t) | |
245 | (lambda (x) #t)))) | |
246 | ||
247 | (define (tenperm-benchmark . rest) | |
248 | (let ((n (if (null? rest) 9 (car rest)))) | |
249 | (set! *perms* '()) | |
250 | (MpermNKL-benchmark 10 n 2 1))) | |
251 | ||
252 | (define (MpermNKL-benchmark m n k ell) | |
253 | (if (and (<= 0 m) | |
254 | (positive? n) | |
255 | (positive? k) | |
256 | (<= 0 ell k)) | |
257 | (let ((id (string-append (number->string m) | |
258 | "perm" | |
259 | (number->string n) | |
260 | ":" | |
261 | (number->string k) | |
262 | ":" | |
263 | (number->string ell))) | |
264 | (queue (make-vector k '()))) | |
265 | ||
266 | ; Fills queue positions [i, j). | |
267 | ||
268 | (define (fill-queue i j) | |
269 | (if (< i j) | |
270 | (begin (vector-set! queue i (permutations (one..n n))) | |
271 | (fill-queue (+ i 1) j)))) | |
272 | ||
273 | ; Removes ell elements from queue. | |
274 | ||
275 | (define (flush-queue) | |
276 | (let loop ((i 0)) | |
277 | (if (< i k) | |
278 | (begin (vector-set! queue | |
279 | i | |
280 | (let ((j (+ i ell))) | |
281 | (if (< j k) | |
282 | (vector-ref queue j) | |
283 | '()))) | |
284 | (loop (+ i 1)))))) | |
285 | ||
286 | (fill-queue 0 (- k ell)) | |
287 | (run-benchmark id | |
288 | m | |
289 | (lambda () | |
290 | (fill-queue (- k ell) k) | |
291 | (flush-queue) | |
292 | queue) | |
293 | (lambda (q) | |
294 | (let ((q0 (vector-ref q 0)) | |
295 | (qi (vector-ref q (max 0 (- k ell 1))))) | |
296 | (or (and (null? q0) (null? qi)) | |
297 | (and (pair? q0) | |
298 | (pair? qi) | |
299 | (equal? (car q0) (car qi)))))))) | |
300 | (begin (display "Incorrect arguments to MpermNKL-benchmark") | |
301 | (newline)))) | |
302 | ||
303 | (define (sumperms-benchmark . rest) | |
304 | (let ((n (if (null? rest) 9 (car rest)))) | |
305 | (if (or (null? *perms*) | |
306 | (not (= n (length (car *perms*))))) | |
307 | (set! *perms* (permutations (one..n n)))) | |
308 | (run-benchmark (string-append "Sumperms" (number->string n)) | |
309 | 1 | |
310 | (lambda () | |
311 | (sumlists *perms*)) | |
312 | (lambda (x) #t)))) | |
313 | ||
314 | (define (mergesort-benchmark . rest) | |
315 | (let ((n (if (null? rest) 9 (car rest)))) | |
316 | (if (or (null? *perms*) | |
317 | (not (= n (length (car *perms*))))) | |
318 | (set! *perms* (permutations (one..n n)))) | |
319 | (run-benchmark (string-append "Mergesort!" (number->string n)) | |
320 | 1 | |
321 | (lambda () | |
322 | (sort!! *perms* lexicographically-less?) | |
323 | #t) | |
324 | (lambda (x) #t)))) |