You really should use criterion for benchmarking.
benchmarking stweird
time 3.116 s (3.109 s .. 3.119 s)
1.000 R² (1.000 R² .. 1.000 R²)
mean 3.112 s (3.110 s .. 3.113 s)
std dev 2.220 ms (953.8 μs .. 2.807 ms)
variance introduced by outliers: 19% (moderately inflated)
benchmarking marrayweird
time 3.170 s (2.684 s .. 3.602 s)
0.997 R² (0.989 R² .. 1.000 R²)
mean 3.204 s (3.148 s .. 3.280 s)
std dev 72.66 ms (1.810 ms .. 88.94 ms)
variance introduced by outliers: 19% (moderately inflated)
My system is noisy, but it does appear that the standard deviations don't overlap. I don't actually care much about figuring out why, though, because the code is exceptionally slow. 3 seconds for memoizing 5000 operations? Something has gone horribly wrong.
The code as written is a super-exponential algorithm - there's no sharing of memoized functions in the memoization code. Each sub-evaluation could create an entirely new array and populate it. You're being saved from that situation by two things. First is laziness - most values are never evaluated. The upshot here is that the algorithm will actually terminate, instead of eagerly evaluating array entries forever. Second, and more importantly, GHC does some constant-lifting, lifting the expression (memoST r f) (or the arrayST version) out of the loop body. This creates sharing within each loop body so that the two sub-calls actually share memoization. It's not great, but it's actually doing some speedup. But it's mostly accidental.
The traditional approach to this sort of memoization is to just let laziness do the necessary mutation:
memoArray
:: forall a b. (Ix a)
=> (a, a)
-> ((a -> b) -> a -> b)
-> a -> b
memoArray r f = fetch
where
fetch n = arr ! n
arr = listArray r $ map (f fetch) (range r)
Note the knot-tying between fetch and arr internally. This ensures that the same array is used in every calculation. It benchmarks a bit better:
benchmarking arrayweird
time 212.0 μs (211.5 μs .. 212.6 μs)
1.000 R² (0.999 R² .. 1.000 R²)
mean 213.3 μs (212.4 μs .. 215.0 μs)
std dev 4.104 μs (2.469 μs .. 6.194 μs)
variance introduced by outliers: 12% (moderately inflated)
213 microseconds is much more what I'd expect from only 5000 iterations. Still, one might be curious whether doing explicit sharing could work with the other variants. And it can:
memoST'
:: forall a b. (Ix a)
=> (a, a)
-> ((a -> b) -> a -> b)
-> a -> b
memoST' r f = fetch
where
fetch n = arr ! n
arr = runSTArray compute
compute :: ST s (STArray s a b)
compute = do
a <- newArray_ r
forM_ (range r) $ \i -> do
writeArray a i $ f fetch i
return a
memoMArray'
:: forall a b. (Ix a)
=> (a, a)
-> ((a -> b) -> a -> b)
-> a -> b
memoMArray' r f = fetch
where
fetch n = arr ! n
arr = unsafePerformIO compute
compute :: IO (Array a b)
compute = do
a <- newArray_ r :: IO (IOArray a b)
forM_ (range r) $ \i -> do
writeArray a i $ f fetch i
freeze a
Those use explicit sharing to introduce the same sort of knot-tying, though significantly more indirectly.
benchmarking stweird'
time 168.1 μs (167.1 μs .. 169.9 μs)
1.000 R² (0.999 R² .. 1.000 R²)
mean 167.1 μs (166.7 μs .. 167.8 μs)
std dev 1.636 μs (832.3 ns .. 3.007 μs)
benchmarking marrayweird'
time 171.1 μs (170.7 μs .. 171.7 μs)
1.000 R² (1.000 R² .. 1.000 R²)
mean 170.9 μs (170.5 μs .. 171.4 μs)
std dev 1.554 μs (1.076 μs .. 2.224 μs)
And those actually seem to beat the listArray variant. I really don't know what's up with that. listArray must be doing some surprising extra amount of work. Oh well.
In the end, I don't actually know what's leading to these small performance differences. But none of them are significant in comparison to actually using an efficient algorithm.
Full code, for your perusal:
{-# LANGUAGE ScopedTypeVariables #-}
module Main where
import Data.Array
import Data.Array.ST
import Data.Array.Unsafe
import Control.Monad.ST
import Data.Array.IO
import GHC.IO.Unsafe
import Control.Monad
import Criterion.Main
memoST
:: forall a b. (Ix a)
=> (a, a)
-> ((a -> b) -> a -> b)
-> a -> b
memoST r f = (runSTArray compute !)
where
compute :: ST s (STArray s a b)
compute = do
arr <- newArray_ r
forM_ (range r) $ \i -> do
writeArray arr i $ f (memoST r f) i
return arr
memoMArray
:: forall a b. (Ix a)
=> (a, a)
-> ((a -> b) -> a -> b)
-> a -> b
memoMArray r f = (unsafePerformIO compute !)
where
compute :: IO (Array a b)
compute = do
arr <- newArray_ r :: IO (IOArray a b)
forM_ (range r) $ \i -> do
writeArray arr i $ f (memoMArray r f) i
freeze arr
memoArray
:: forall a b. (Ix a)
=> (a, a)
-> ((a -> b) -> a -> b)
-> a -> b
memoArray r f = fetch
where
fetch n = arr ! n
arr = listArray r $ map (f fetch) (range r)
memoST'
:: forall a b. (Ix a)
=> (a, a)
-> ((a -> b) -> a -> b)
-> a -> b
memoST' r f = fetch
where
fetch n = arr ! n
arr = runSTArray compute
compute :: ST s (STArray s a b)
compute = do
a <- newArray_ r
forM_ (range r) $ \i -> do
writeArray a i $ f fetch i
return a
memoMArray'
:: forall a b. (Ix a)
=> (a, a)
-> ((a -> b) -> a -> b)
-> a -> b
memoMArray' r f = fetch
where
fetch n = arr ! n
arr = unsafePerformIO compute
compute :: IO (Array a b)
compute = do
a <- newArray_ r :: IO (IOArray a b)
forM_ (range r) $ \i -> do
writeArray a i $ f fetch i
freeze a
weird :: (Int -> Int) -> Int -> Int
weird _ 0 = 0
weird _ 1 = 0
weird f i = f (i `div` 2) + f (i - 1) + 1
stweird :: Int -> Int
stweird n = memoST (0, n) weird n
marrayweird :: Int -> Int
marrayweird n = memoMArray (0, n) weird n
arrayweird :: Int -> Int
arrayweird n = memoArray (0, n) weird n
stweird' :: Int -> Int
stweird' n = memoST' (0, n) weird n
marrayweird' :: Int -> Int
marrayweird' n = memoMArray' (0, n) weird n
main :: IO()
main = do
let rounds = 5000
print $ stweird rounds
print $ marrayweird rounds
print $ arrayweird rounds
print $ stweird' rounds
print $ marrayweird' rounds
putStrLn ""
defaultMain
[ bench "stweird" $ whnf stweird rounds
, bench "marrayweird" $ whnf marrayweird rounds
, bench "arrayweird" $ whnf arrayweird rounds
, bench "stweird'" $ whnf stweird' rounds
, bench "marrayweird'" $ whnf marrayweird' rounds
]
