From HaskellWiki

Proposals

Port the Clean entry.

Proposed entry

Unboxes the strict fields

{-# OPTIONS -fbang-patterns -funbox-strict-fields #-} -- -- The Great Computer Language Shootout -- http://shootout.alioth.debian.org/ -- -- Contributed by Don Stewart -- import System import Data.Bits import Text.Printf data Tree = Nil | Node ! Int Tree Tree minN = 4 io s ! n ! t = printf "%s of depth %d \t check: %d

" s n t main = do n <- getArgs >>= readIO . head let maxN = max ( minN + 2 ) n stretchN = maxN + 1 -- stretch memory tree let c = check ( make 0 stretchN ) io "stretch tree" stretchN c -- allocate a long lived tree let long = make 0 maxN -- allocate, walk, and deallocate many bottom-up binary trees let vs = depth minN maxN mapM_ ( \ (( m , d , i )) -> io ( show m ++ " \t trees" ) d i ) vs -- confirm the the long-lived binary tree still exists io "long lived tree" maxN ( check long ) -- generate many trees depth :: Int -> Int -> [( Int , Int , Int )] depth ! d ! m | d <= m = ( 2 * n , d , sumT d n 0 ) : depth ( d + 2 ) m | otherwise = [] where ! n = 1 ` shiftL ` ( m - d + minN ) -- allocate and check lots of trees sumT :: Int -> Int -> Int -> Int sumT ! d 0 t = t sumT d i t = sumT d ( i - 1 ) ( t + a + b ) where a = check ( make i d ) b = check ( make ( - i ) d ) -- traverse the tree, counting up the nodes check :: Tree -> Int check Nil = 0 check ( Node i l r ) = i + check l - check r -- build a tree make :: Int -> Int -> Tree make i 0 = Node i Nil Nil make i d = Node i ( make ( i2 - 1 ) d2 ) ( make i2 d2 ) where i2 = 2 * i ; d2 = d - 1

Newly submitted to shootout

This is a trivial modification of Don Stewart's to add parallelism.

{-# OPTIONS -fbang-patterns -funbox-strict-fields #-} -- -- The Computer Language Shootout -- http://shootout.alioth.debian.org/ -- -- Contributed by Don Stewart -- Modified by Stephen Blackheath to parallelize (a very tiny tweak) -- import System import Data.Bits import Text.Printf import Control.Parallel.Strategies -- -- an artificially strict tree. -- -- normally you would ensure the branches are lazy, but this benchmark -- requires strict allocation. -- data Tree = Nil | Node ! Int ! Tree ! Tree minN = 4 io s n t = printf "%s of depth %d \t check: %d

" s n t main = do n <- getArgs >>= readIO . head let maxN = max ( minN + 2 ) n stretchN = maxN + 1 -- stretch memory tree let c = check ( make 0 stretchN ) io "stretch tree" stretchN c -- allocate a long lived tree let ! long = make 0 maxN -- allocate, walk, and deallocate many bottom-up binary trees let vs = parMap rnf id $ depth minN maxN mapM_ ( \ (( m , d , i )) -> io ( show m ++ " \t trees" ) d i ) vs -- confirm the the long-lived binary tree still exists io "long lived tree" maxN ( check long ) -- generate many trees depth :: Int -> Int -> [( Int , Int , Int )] depth d m | d <= m = ( 2 * n , d , sumT d n 0 ) : depth ( d + 2 ) m | otherwise = [] where n = 1 ` shiftL ` ( m - d + minN ) -- allocate and check lots of trees sumT :: Int -> Int -> Int -> Int sumT d 0 t = t sumT d i t = sumT d ( i - 1 ) ( t + a + b ) where a = check ( make i d ) b = check ( make ( - i ) d ) -- traverse the tree, counting up the nodes check :: Tree -> Int check Nil = 0 check ( Node i l r ) = i + check l - check r -- build a tree make :: Int -> Int -> Tree make i 0 = Node i Nil Nil make i d = Node i ( make ( i2 - 1 ) d2 ) ( make i2 d2 ) where i2 = 2 * i ; d2 = d - 1

(Old) Current entry

Ported to ghc 6.6 Submitted

{-# OPTIONS -fbang-patterns #-} -- -- The Great Computer Language Shootout -- http://shootout.alioth.debian.org/ -- -- Simon Marlow -- Rewritten by Don Stewart -- import System import Data.Bits import Text.Printf data Tree = Nil | Node ! Int Tree Tree minDepth = 4 io s n t = printf "%s of depth %d \t check: %d

" s n t main = do maxDepth <- getArgs >>= return . max ( minDepth + 2 ) . read . head :: IO Int let stretch = make 0 ( maxDepth + 1 ) io "stretch tree" ( maxDepth + 1 ) ( check stretch ) let long = make 0 maxDepth let vs = depth minDepth maxDepth mapM_ ( \ ( P m d i ) -> io ( show m ++ " \t trees" ) d i ) vs io "long lived tree" maxDepth ( check long ) data P = P ! Int ! Int ! Int depth :: Int -> Int -> [ P ] depth ! d ! m | d > m = [] | otherwise = P ( 2 * n ) d ( sumT n d 0 ) : depth ( d + 2 ) m where n = 1 ` shiftL ` ( m - d + minDepth ) sumT :: Int -> Int -> Int -> Int sumT ! 0 ! d ! t = t sumT i d t = sumT ( i - 1 ) d ( t + a + b ) where a = check ( make i d ) b = check ( make ( - i ) d ) make :: Int -> Int -> Tree make ! i ! 0 = Node i Nil Nil make i d = Node i ( make ( i2 - 1 ) d2 ) ( make i2 d2 ) where i2 = 2 * i d2 = d - 1 check :: Tree -> Int check Nil = 0 check ( Node i l r ) = i + check l - check r

Old entry

Shortest entry in any language, and almost twice as fast as old entry on my box.

Was speculatively disqualified.

{-# OPTIONS_GHC -fglasgow-exts -O2 -optc-O3 -funbox-strict-fields #-} -- The Great Computer Language Shootout -- http://shootout.alioth.debian.org/ -- Simon Marlow -- Shortened by Don Stewart import System ; import Text.Printf ; import Monad data Tree = Nil | Node ! Int Tree Tree min' = 4 :: Int main = do max' <- getArgs >>= return . max ( min' + 2 ) . read . head printf "stretch tree of depth %d \t check: %d

" ( max' + 1 ) ( itemCheck $ make 0 ( max' + 1 )) depthLoop min' max' printf "long lived tree of depth %d \t check: %d

" max' ( itemCheck $ make 0 max' ) depthLoop d m = when ( d <= m ) $ do printf "%d \t trees of depth %d \t check: %d

" ( 2 * n ) d ( sumLoop n d 0 ) depthLoop ( d + 2 ) m where n = 2 ^ ( m - d + min' ) sumLoop 0 d acc = acc sumLoop k d acc = c ` seq ` sumLoop ( k - 1 ) d ( acc + c + c' ) where ( c , c' ) = ( itemCheck ( make k d ), itemCheck ( make ( - 1 * k ) d )) make i ( 0 :: Int ) = i ` seq ` Nil make i d = Node i ( make (( 2 * i ) - 1 ) ( d - 1 )) ( make ( 2 * i ) ( d - 1 )) itemCheck Nil = 0 itemCheck ( Node x l r ) = x + itemCheck l - itemCheck r

Old Entry