Actions

Programming language shootout: nsieve-bits

From Gambit wiki

Revision as of 22:00, 22 February 2008 by Bjlucier (talk | contribs) (correct link to alioth)

This is a Gambit implementation of the nsieve-bits benchmark of the Computer Language Benchmarks Game.

The program

#!gsi-script
;; $Id: nsieve-bits.scm,v 1.2 2008/02/17 23:44:02 lucier Exp lucier $
;; The Great Computer Language Shootout
;; http://shootout.alioth.debian.org/
;;
;; nsieve benchmark for The Computer Language Shootout
;; Written by Dima Dorfman, 2004
;; Converted to MzScheme by Brent Fulgham
;; Converted to Gambit by Bradley Lucier

(declare (standard-bindings)(extended-bindings)(block)(fixnum)(not safe))

(define (nsieve m)
  
  (define (make-bvector n val)
    (make-u8vector (quotient (+ n 7) 8)
		   (if val 255 0)))
  
  (define (bvector-true? a i)
    (not (zero? (fxand (u8vector-ref a (quotient i 8))
		       (fxarithmetic-shift-left 1 (remainder i 8))))))
  
  (define (bvector-clear! a i)
    (let* ((index (quotient i 8))
	   (byte (u8vector-ref a index))
	   (mask (fxarithmetic-shift-left 1 (remainder i 8))))
      (u8vector-set! a index (fxand byte (fxnot mask)))))
  
  (define (bvector-set! a i)
    (let* ((index (quotient i 8))
	   (byte (u8vector-ref a index))
	   (mask (fxarithmetic-shift-left 1 (remainder i 8))))
      (u8vector-set! a index (fxior byte mask))))
  
  (let ((a (make-bvector m #t)))
    (let loop ((i 2)
	       (n 0))
      (declare (not interrupts-enabled))
      (if (< i m)
	  (if (bvector-true? a i)
	      (let clear ((j (+ i i)))
		(if (< j m)
		    (begin
		      (bvector-clear! a j)
		      (clear (+ j i)))
		    (loop (+ 1 i)
			  (+ 1 n))))
	      (loop (+ 1 i) n))
	  n))))

(define (test n)
  
  (define (string-pad s n)
    (string-append (make-string (- n (string-length s)) #\space)
		   s))
  
  (let* ((m (* (expt 2 n) 10000))
	 (count (nsieve m)))
    (display (list "Primes up to "
		   (string-pad (number->string m) 8)
		   " "
		   (string-pad (number->string count) 8)
		   #\newline))))


(define (main arg)
  
  (let ((n (string->number arg)))
    (if (not n)
	(begin
	  (display "An integer is required") (newline) 2)
	(begin
	  (if (>= n 0) (test n))
	  (if (>= n 1) (test (- n 1)))
	  (if (>= n 2) (test (- n 2)))
	  0))))

Compiling

gsc nsieve-bits

Running

gsi nsieve 11