ApplyStats.hs (7290B)
1 {-# LANGUAGE BangPatterns #-} 2 3 module ApplyStats 4 ( ApplyStats(..) 5 , emptyApplyStats 6 , emptyApplyStatsSampled 7 , applyCounted 8 , runApplyCounted 9 , runApplySampledWithProgress 10 , runApplyGlobalCounted 11 , printApplyStats 12 ) where 13 14 import Research 15 import qualified Data.Map.Strict as M 16 import qualified Data.List as L 17 import Data.Ord (comparing) 18 import Data.Text (Text) 19 import qualified Data.Text as T 20 import Debug.Trace (trace) 21 import System.IO.Unsafe (unsafePerformIO, unsafeDupablePerformIO) 22 import Data.IORef 23 24 -- --------------------------------------------------------------------------- 25 -- Threaded stats (slow but pure) 26 -- --------------------------------------------------------------------------- 27 28 type Hash = Text 29 type AppKey = (Hash, Hash) 30 31 data ApplyStats = ApplyStats 32 { totalApplyCalls :: !Int 33 , uniqueApps :: !(M.Map AppKey Int) 34 , sampleInterval :: !Int 35 , sampleCounter :: !Int 36 , progressEvery :: !Int 37 } 38 deriving (Show) 39 40 emptyApplyStats :: ApplyStats 41 emptyApplyStats = emptyApplyStatsSampled 1 42 43 emptyApplyStatsSampled :: Int -> ApplyStats 44 emptyApplyStatsSampled n = ApplyStats 45 { totalApplyCalls = 0 46 , uniqueApps = M.empty 47 , sampleInterval = max 1 n 48 , sampleCounter = 0 49 , progressEvery = 0 50 } 51 52 bump :: T -> T -> ApplyStats -> ApplyStats 53 bump !f !x !st = 54 let !counter' = sampleCounter st + 1 55 !total' = totalApplyCalls st + 1 56 !stBase = st { totalApplyCalls = total' 57 , sampleCounter = counter' 58 } 59 !st' = if counter' `mod` sampleInterval st /= 0 60 then stBase 61 else let !hf = termHash f 62 !hx = termHash x 63 !k = (hf, hx) 64 !m = M.insertWith (+) k 1 (uniqueApps st) 65 in stBase { uniqueApps = m } 66 in case progressEvery st of 67 0 -> st' 68 n | total' `mod` n == 0 -> 69 trace ("apply calls so far: " ++ show total') st' 70 _ -> st' 71 72 termHash :: T -> Hash 73 termHash Leaf = 74 nodeHash NLeaf 75 termHash (Stem t) = 76 nodeHash (NStem (termHash t)) 77 termHash (Fork l r) = 78 nodeHash (NFork (termHash l) (termHash r)) 79 80 applyCounted :: T -> T -> ApplyStats -> (T, ApplyStats) 81 applyCounted !f !x !st0 = 82 let !st1 = bump f x st0 83 in applyStepCounted f x st1 84 85 applyStepCounted :: T -> T -> ApplyStats -> (T, ApplyStats) 86 applyStepCounted (Fork Leaf a) _ st = 87 (a, st) 88 applyStepCounted (Fork (Stem a) b) c st = 89 let (!ac, !st1) = applyCounted a c st 90 (!bc, !st2) = applyCounted b c st1 91 in applyCounted ac bc st2 92 applyStepCounted (Fork (Fork a _b) _c) Leaf st = 93 (a, st) 94 applyStepCounted (Fork (Fork _a b) _c) (Stem u) st = 95 applyCounted b u st 96 applyStepCounted (Fork (Fork _a _b) c) (Fork u v) st = 97 let (!cu, !st1) = applyCounted c u st 98 in applyCounted cu v st1 99 applyStepCounted Leaf b st = 100 (Stem b, st) 101 applyStepCounted (Stem a) b st = 102 (Fork a b, st) 103 104 runApplyCounted :: T -> T -> (T, ApplyStats) 105 runApplyCounted !f !x = 106 applyCounted f x emptyApplyStats 107 108 runApplySampled :: Int -> T -> T -> (T, ApplyStats) 109 runApplySampled !n !f !x = 110 applyCounted f x (emptyApplyStatsSampled n) 111 112 runApplySampledWithProgress :: Int -> Int -> T -> T -> (T, ApplyStats) 113 runApplySampledWithProgress !interval !progress !f !x = 114 let st = (emptyApplyStatsSampled interval) { progressEvery = progress } 115 in applyCounted f x st 116 117 -- --------------------------------------------------------------------------- 118 -- Global mutable stats (fast, unsafe, single-threaded only) 119 -- --------------------------------------------------------------------------- 120 121 {-# NOINLINE globalTotalCount #-} 122 globalTotalCount :: IORef Int 123 globalTotalCount = unsafePerformIO (newIORef 0) 124 125 {-# NOINLINE globalInterval #-} 126 globalInterval :: IORef Int 127 globalInterval = unsafePerformIO (newIORef 1) 128 129 {-# NOINLINE globalMap #-} 130 globalMap :: IORef (M.Map AppKey Int) 131 globalMap = unsafePerformIO (newIORef M.empty) 132 133 {-# NOINLINE globalProgress #-} 134 globalProgress :: IORef Int 135 globalProgress = unsafePerformIO (newIORef 0) 136 137 resetGlobalStats :: Int -> Int -> IO () 138 resetGlobalStats !interval !progress = do 139 writeIORef globalTotalCount 0 140 writeIORef globalInterval (max 1 interval) 141 writeIORef globalMap M.empty 142 writeIORef globalProgress progress 143 144 readGlobalStats :: IO ApplyStats 145 readGlobalStats = do 146 total <- readIORef globalTotalCount 147 m <- readIORef globalMap 148 pure ApplyStats 149 { totalApplyCalls = total 150 , uniqueApps = m 151 , sampleInterval = 0 152 , sampleCounter = 0 153 , progressEvery = 0 154 } 155 156 {-# INLINE globalBump #-} 157 globalBump :: T -> T -> () 158 globalBump !f !x = unsafeDupablePerformIO $ do 159 !total <- readIORef globalTotalCount 160 let !total' = total + 1 161 writeIORef globalTotalCount total' 162 !interval <- readIORef globalInterval 163 !progress <- readIORef globalProgress 164 let !_ = if progress > 0 && total' `mod` progress == 0 165 then trace ("apply calls so far: " ++ show total') () 166 else () 167 if total' `mod` interval /= 0 168 then pure () 169 else do 170 let !hf = termHash f 171 !hx = termHash x 172 !k = (hf, hx) 173 !m <- readIORef globalMap 174 writeIORef globalMap (M.insertWith (+) k 1 m) 175 pure () 176 177 applyGlobalCounted :: T -> T -> T 178 applyGlobalCounted !f !x = 179 let !_ = globalBump f x 180 in applyGlobalStep f x 181 182 applyGlobalStep :: T -> T -> T 183 applyGlobalStep (Fork Leaf a) _ = a 184 applyGlobalStep (Fork (Stem a) b) c = 185 applyGlobalCounted (applyGlobalCounted a c) (applyGlobalCounted b c) 186 applyGlobalStep (Fork (Fork a _b) _c) Leaf = a 187 applyGlobalStep (Fork (Fork _a b) _c) (Stem u) = applyGlobalCounted b u 188 applyGlobalStep (Fork (Fork _a _b) c) (Fork u v) = 189 applyGlobalCounted (applyGlobalCounted c u) v 190 applyGlobalStep Leaf b = Stem b 191 applyGlobalStep (Stem a) b = Fork a b 192 193 runApplyGlobalCounted :: Int -> Int -> T -> T -> IO (T, ApplyStats) 194 runApplyGlobalCounted !interval !progress !f !x = do 195 resetGlobalStats interval progress 196 let !result = applyGlobalCounted f x 197 !stats <- readGlobalStats 198 pure (result, stats) 199 200 -- --------------------------------------------------------------------------- 201 -- Printing 202 -- --------------------------------------------------------------------------- 203 204 printApplyStats :: ApplyStats -> IO () 205 printApplyStats st = do 206 let !total = totalApplyCalls st 207 !uniq = M.size (uniqueApps st) 208 !ratio = 209 if uniq == 0 210 then 0 :: Double 211 else fromIntegral total / fromIntegral uniq 212 213 counts = 214 reverse 215 . L.sortBy (comparing snd) 216 . M.toList 217 $ uniqueApps st 218 219 repeated = 220 filter ((> 1) . snd) counts 221 222 top20 = take 20 repeated 223 224 putStrLn $ "total apply calls: " ++ show total 225 putStrLn $ "unique application patterns: " ++ show uniq 226 putStrLn $ "duplication ratio total/unique: " ++ show ratio 227 putStrLn $ "repeated application patterns: " ++ show (length repeated) 228 229 putStrLn "top repeated application counts:" 230 mapM_ printTop top20 231 where 232 short h = T.unpack (T.take 12 h) 233 234 printTop ((hf, hx), n) = 235 putStrLn $ 236 " " ++ show n 237 ++ "x apply " 238 ++ short hf 239 ++ " " 240 ++ short hx