source: project/benchmarks-shootout/fannkuch.scm @ 15433

Last change on this file since 15433 was 10486, checked in by elf, 13 years ago

realised i never added this

File size: 6.3 KB
Line 
1;; fannkuch benchmark for the computer language shootout
2;; written by elf, mar 2008
3;; compile with chicken: csc -Ob fannkuch_chicken.scm -o fannkuch_chicken
4
5(eval-when (compile)
6    (declare
7        (uses srfi-1 srfi-4)
8        (fixnum-arithmetic)
9        (usual-integrations)
10        (block)
11        (number-type fixnum)
12        (disable-interrupts)
13        (lambda-lift)
14        (unsafe)
15        (inline)
16        (bound-to-procedure
17            vector-swap!
18            make-swap!
19            vector-reverse!
20            flips
21            circular-append
22            make-pclos
23            make-plist-even
24            make-plist-odd
25            make-plist1
26            make-plist2
27            run-permute2
28            run-permute
29            errinvoke
30            main
31        )
32    ))
33
34
35(define-inline (vector-swap! v x y xval)
36    (u8vector-set! v x (u8vector-ref v y))
37    (u8vector-set! v y xval)
38    v)
39
40(define-inline (make-swap! x y)
41    (lambda (v)
42        (vector-swap! v x y (u8vector-ref v x))))
43
44(define-inline (vector-reverse! v i)
45    (let loop ((j   0)
46               (i   i))
47        (cond ((fx>= j i)
48                  v)
49              (else
50                  (vector-swap! v j i (u8vector-ref v j))
51                  (loop (fx+ 1 j) (fx- i 1))))))
52
53(define-inline (flips ov vl)
54    (let loop ((c   1)
55               (v   (vector-reverse! vl (u8vector-ref vl 0))))
56        (if (fx= 0 (u8vector-ref v 0))
57            (fxmax ov c)
58            (loop (fx+ 1 c) (vector-reverse! v (u8vector-ref v 0))))))
59
60(define-inline (circular-append l1 l2)
61    (let ((r   (append l1 l2)))
62        (set-cdr! (last-pair r) r)
63        r))
64
65(define-inline (make-pclos l)
66    (lambda (v)
67        (let ((t   ((car l) v)))
68            (set! l (cdr l))
69            t)))
70
71(define-inline (make-plist-even i1 i2 l)
72    (append l
73            (append-map
74                (lambda (x)
75                    (cons (make-swap! i1 x) l))
76                (cons i2 (iota i2)))))
77
78(define-inline (make-plist-odd i1 i2 l)
79    (append l
80            (append-map
81                (lambda (x)
82                    (cons (make-swap! i1 i2) l))
83                (iota i1))))
84
85(define-inline (make-plist1 n)
86    (if (fx< n 4)
87        (case n
88            ((1)
89                '())
90            ((2)
91                (list (make-swap! 0 1)))
92            ((3)
93                (list
94                    (make-swap! 0 1)
95                    (make-swap! 1 2)
96                    (make-swap! 0 1)
97                    (make-swap! 1 2)
98                    (make-swap! 0 1))))
99        (let loop ((l   (list (make-swap! 0 1)
100                              (make-swap! 1 2)
101                              (make-swap! 0 1)
102                              (make-swap! 1 2)
103                              (make-swap! 0 1)))
104                   (i   4))
105            (cond ((fx> i n)
106                      l)
107                  ((even? i)
108                      (loop (make-plist-even (fx- i 1) (fx- i 2) l)
109                            (fx+ 1 i)))
110                  (else
111                      (loop (make-plist-odd (fx- i 1) (fx- i 2) l)
112                            (fx+ 1 i)))))))
113
114(define-inline (make-plist2 i n p)
115    (let loop ((i   i)
116               (l   '()))
117        (cond ((fx> i n)
118                  (make-pclos
119                      (circular-append
120                          p
121                          (list
122                              (make-pclos
123                                  (append
124                                      l
125                                      (list (lambda (v) #f))))))))
126              ((even? i)
127                  (loop (fx+ 1 i)
128                        (make-plist-even (fx- i 1) (fx- i 2) l)))
129              (else
130                  (loop (fx+ 1 i)
131                        (make-plist-odd (fx- i 1) (fx- i 2) l))))))
132
133(define-inline (run-permute2 n n1 pl v c)
134    (let loop ((v   (pl v))
135               (c   (if (or (fx= 0 (u8vector-ref v 0))
136                            (fx= 0 (u8vector-ref v (u8vector-ref v 0)))
137                            (fx= n1 (u8vector-ref v n1)))
138                        c
139                        (flips c (subu8vector v 0 n)))))
140        (if v
141            (loop
142                (pl v)
143                (if (or (fx= 0 (u8vector-ref v 0))
144                        (fx= 0 (u8vector-ref v (u8vector-ref v 0)))
145                        (fx= n1 (u8vector-ref v n1)))
146                    c
147                    (flips c (subu8vector v 0 n))))
148            c)))
149
150(define-inline (run-permute n n1 pl)
151    (let loop ((v   (let ((v   (make-u8vector n 0 #t)))
152                        (for-each
153                            (lambda (x)
154                                (u8vector-set! v x x))
155                            (iota n))
156                        v))
157               (c   1)
158               (t   30))
159        (cond (v
160                  (for-each
161                      (lambda (x)
162                          (display (fx+ 1 x)))
163                      (u8vector->list v))
164                  (newline)
165                  (if (fx= 0 t)
166                      (run-permute2 n n1 pl v c)
167                      (loop
168                          (pl v)
169                          (if (or (fx= 0 (u8vector-ref v 0))
170                                  (fx= 0 (u8vector-ref v (u8vector-ref v 0)))
171                                  (fx= n1 (u8vector-ref v n1)))
172                              c
173                              (flips c (subu8vector v 0 n)))
174                          (fx- t 1))))
175              (else
176                  c))))
177
178(define-inline (errinvoke)
179    (display "syntax: ")
180    (display (program-name))
181    (display " [positive integer]")
182    (newline)
183    (exit 1))
184
185(define (main args)
186    (or (fx= 1 (length args))
187        (errinvoke))
188    (let ((n   (string->number (car args))))
189        (or (and (integer? n) (fx> n 0))
190            (errinvoke))
191        (let ((r   (run-permute
192                       n
193                       (fx- n 1)
194                       (if (fx< n 6)
195                           (make-pclos
196                               (append (make-plist1 n)
197                                       (list (lambda (v) #f))))
198                           (make-plist2 (fx+ 1 (fxshr n 1)) n
199                                        (make-plist1 (fxshr n 1)))))))
200            (display "Pfannkuchen(")
201            (display n)
202            (display ") = ")
203            (display r)
204            (newline)
205            (exit 0))))
206
207(main (command-line-arguments))
Note: See TracBrowser for help on using the repository browser.