Benchmark 3-level deep record inside a 12-level deep tree

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
{-# OPTIONS -Wall -O2 #-}
{-# LANGUAGE TemplateHaskell, BangPatterns #-}
import Control.Lens
import Control.Monad
import Criterion.Main
import Data.IORef

data RecC = RecC
  { _c0, _c1, _c2, _c3, _c4 :: {-# UNPACK #-}!Int }
  deriving (Show)
makeLenses ''RecC

data RecB = RecB
  { _b0, _b1, _b2, _b3, _b4 :: !RecC }
  deriving (Show)
makeLenses ''RecB

data RecA = RecA
  { _a0, _a1, _a2, _a3, _a4 :: !RecB }
  deriving (Show)
makeLenses ''RecA

data Tree a = Nil | Node !a !(Tree a) !(Tree a)

-- Show only left-most spine to avoid flood
instance Show a => Show (Tree a) where
  show Nil = "Nil"
  show (Node x left right) = "Node " ++ show x ++ show left ++ " .."

inTree :: Int -> (a -> a) -> Tree a -> Tree a
inTree 0 f (Node x left right) = Node (f x) left right
inTree n f (Node x left right) = Node x (inTree (n-1) f left) right

updateRec :: Int -> IORef (Tree RecA) -> IO ()
updateRec depth ref = replicateM_ 10000 $ do
  modifyIORef' ref $ inTree depth updateRecord
  return ()
  where
    updateRecord record =
      record
      & a0.b0.c0 +~ record^.a1.b2.c0
      & a0.b0.c1 +~ record^.a1.b2.c1
      & a0.b0.c2 +~ record^.a1.b2.c2
      & a0.b0.c3 +~ record^.a1.b2.c3
      & a0.b0.c4 +~ record^.a1.b2.c4
      & a0.b0.c3 +~ 1
      & a0.b1.c0 +~ 1
      & a0.b1.c1 +~ 2
      & a0.b1.c2 +~ 3
      & a0.b1.c3 +~ 4
      & a0.b1.c4 +~ 5
      & a0.b1.c3 +~ 1
      & a1.b2.c0 +~ 1
      & a1.b2.c1 +~ 2
      & a1.b2.c2 +~ 3
      & a1.b2.c3 +~ 4
      & a1.b2.c4 +~ 5
      & a1.b2.c3 +~ 1

mkTree :: Int -> a -> Tree a
mkTree 0 x = Nil
mkTree n x = Node x (mkTree (n-1) x) (mkTree (n-1) x)

main :: IO ()
main = do
  let c = RecC 0 1 2 3 4
      b = RecB c c c c c
      a = RecA b b b b b
      depth = 15
  ref <- newIORef $ mkTree (1+depth) a
  defaultMain [
    bench "Update fields" $ updateRec depth ref
    ]
  readIORef ref >>= print