Personal tools

Shootout/Binary trees

From HaskellWiki

< Shootout(Difference between revisions)
Jump to: navigation, search
m (category)
(d)
 
(6 intermediate revisions by 2 users not shown)
Line 3: Line 3:
 
Port the Clean entry.
 
Port the Clean entry.
   
== Current ==
+
== Proposed entry ==
  +
  +
Unboxes the strict fields
  +
  +
<haskell>
  +
{-# 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\n" 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
  +
</haskell>
  +
  +
== Newly submitted to shootout ==
  +
  +
This is a trivial modification of Don Stewart's to add parallelism.
  +
  +
<haskell>
  +
{-# 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\n" 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
  +
</haskell>
  +
  +
== (Old) Current entry ==
  +
  +
Ported to ghc 6.6
  +
[http://alioth.debian.org/tracker/index.php?func=detail&aid=304418&group_id=30402&atid=411646 Submitted]
  +
  +
<haskell>
  +
{-# 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\n" 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
  +
</haskell>
  +
  +
== Old entry ==
   
 
Shortest entry in any language, and almost twice as fast as old entry on my box.
 
Shortest entry in any language, and almost twice as fast as old entry on my box.
  +
  +
Was speculatively disqualified.
   
 
<haskell>
 
<haskell>

Latest revision as of 22:33, 22 February 2011

Contents

[edit] 1 Proposals

Port the Clean entry.

[edit] 2 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\n" 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

[edit] 3 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\n" 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

[edit] 4 (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\n" 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

[edit] 5 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\n" (max'+1) (itemCheck $ make 0 (max'+1))
          depthLoop min' max'
          printf "long lived tree of depth %d\t check: %d\n" max' (itemCheck $ make 0 max')
 
depthLoop d m = when (d <= m) $ do
    printf "%d\t trees of depth %d\t check: %d\n" (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

[edit] 6 Old Entry

{-# OPTIONS -O3 -optc-O3 #-}
-- The Great Computer Language Shootout
-- http://shootout.alioth.debian.org/
-- contributed by Einar Karttunen
 
import System
 
data Tree = Node  Int Tree Tree | Nil
 
main = do [n] <- getArgs
          let max' = max (min'+2) (read n)
          showItemCheck (max'+1) (make 0 (max'+1)) "stretch tree of depth "
          let longlived = make 0 max'
          depthLoop min' max'
          showItemCheck max' longlived "long lived tree of depth "
 
min' :: Int
min' = 4
 
showItemCheck d a s = putStrLn (s++show d++"\t check: "++show (itemCheck a))
 
showCheck i d check = putStrLn (show (2*i)++"\t trees of depth "++show d++"\t check: "++show check)
 
 
depthLoop d m | d > m = return ()
depthLoop d m         = showCheck n d (sumLoop n d 0) >> depthLoop (d+2) m
              where n = 2^(m - d + min')
 
 
 
sumLoop :: Int -> Int -> Int -> Int
sumLoop 0 d acc = acc
sumLoop k d acc = c `seq` sumLoop (k-1) d (acc + c + c')
    where c  = itemCheck (make k d)
          c' = itemCheck (make (-1*k) d)
 
make :: Int -> Int -> Tree
make i 0 = 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