gc-benchmarks/larceny/perm.sch

   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))))