ghc-dup: 8f1a700c37804de370e554526034f5e2e64066b9
1: {-# LANGUAGE Rank2Types, ExistentialQuantification, RecordWildCards #-}
2:
3: -- compile me with
4: -- > ghc -with-rtsopts=-T -O
5:
6: import Data.Word
7: import Data.List
8: --import Data.List.Split
9: import Data.Bits
10: import Data.Function
11: import System.Environment
12: import System.Mem
13: import System.IO
14: import GHC.Stats
15: import Control.Monad
16: import System.Process
17: import Data.Maybe
18: --import GHC.HeapView hiding (Box, value)
19: import Text.Printf
20: import Data.Ord
21: import GHC.Dup
22:
23: -- Specification
24:
25: type S = Word32
26: data Tree = Node Word32 [Tree]
27: firstChild (Node _ (t:_)) = t
28: value n = popCount n
29:
30: countDown :: Word32 -> Bool
31: countDown 0 = True
32: countDown n = countDown (n-1)
33: {-# NOINLINE countDown #-}
34:
35: succs n = [n * 3, n * 5, n * 7, n * 9]
36: succsSlow n = if countDown (min (2^23) n) then [n * 3, n * 5, n * 7, n * 9] else []
37:
38: -- CTree stuff
39: newtype CTree = CTree { unCTree :: forall a. (S -> [a] -> a) -> a }
40: toCTree :: Tree -> CTree
41: toCTree (Node s ts) = CTree $ \f -> f s $ map (\t -> unCTree (toCTree t) f) ts
42: fromCTree :: CTree -> Tree
43: fromCTree ct = unCTree ct Node
44:
45: ctree :: S -> CTree
46: ctree s = CTree $ \f -> f s $ map (\s' -> unCTree (ctree s') f) (succs s)
47:
48: ctreeSlow :: S -> CTree
49: ctreeSlow s = CTree $ \f -> f s $ map (\s' -> unCTree (ctreeSlow s') f) (succsSlow s)
50:
51:
52: crate :: Int -> CTree -> Int
53: crate d t = unCTree t crate' d
54: where
55: crate' :: S -> [Int -> Int] -> (Int -> Int)
56: crate' n st 0 = value n
57: crate' n st d = maximum (map ($ d-1) st)
58:
59:
60: csolve :: CTree -> [S]
61: csolve t = fst (unCTree t csolve')
62: where
63: csolve' :: S -> [([S],Int -> Int)] -> ([S],Int -> Int)
64: csolve' n rc =
65: ( n : pickedChild
66: , \d -> if d == 0
67: then value n
68: else maximum (map (($ d-1) . snd) rc))
69: where
70: pickedChild = fst (maximumBy (comparing (($ depth) . snd)) rc)
71:
72:
73: -- UTree stuff
74: data UTree' = UNode S [UTree]
75: type UTree = () -> UTree'
76: utree n = \_ -> UNode n (map utree (succs n))
77: utreeSlow n = \_ -> UNode n (map utreeSlow (succsSlow n))
78:
79: usolve :: UTree -> [S]
80: usolve t = usolve' (t ())
81: where
82: usolve' (UNode n ts) = n : usolve pickedChild
83: where
84: ratedChilds = [ (t, urate depth t) | t <- ts ]
85: pickedChild = fst (maximumBy (comparing snd) ratedChilds)
86:
87: urate :: Int -> UTree -> Int
88: urate 0 t = case t () of (UNode n _) -> value n
89: urate d t = case t () of (UNode _ ts) -> maximum (map (urate (d-1)) ts)
90:
91:
92: -- Regular tree stuff
93:
94: t1 = tree 1
95: tree n = Node n (map tree (succs n))
96: treeSlow n = Node n (map treeSlow (succsSlow n))
97:
98: depth = 4
99:
100: solve :: Tree -> [S]
101: solve (Node n ts) = n : solve pickedChild
102: where
103: ratedChilds = [ (t, rate depth t) | t <- ts ]
104: pickedChild = fst (maximumBy (comparing snd) ratedChilds)
105:
106: rate 0 (Node n _) = value n
107: rate d (Node _ ts) = maximum (map (rate (d-1)) ts)
108:
109: solveDup t = case dup t of Box t -> solve t
110:
111: solveDeepDup t = case deepDup t of Box t -> solve t
112:
113: solveRateDup (Node n ts) = n :
114: solveRateDup (fst (maximumBy (comparing snd) [ (t, rateDup depth t) | t <- ts ]))
115:
116: solveRateRecDup (Node n ts) = n :
117: solveRateRecDup (fst (maximumBy (comparing snd) [ (t, rateRecDup depth t) | t <- ts ]))
118:
119: solveDeepDupRateDup t = case deepDup t of Box t -> go t
120: where go (Node n ts) = n :
121: go (fst (maximumBy (comparing snd) [ (t, rateDup depth t) | t <- ts ]))
122:
123: rateDup d t = case dup t of Box t2 -> rate d t2
124: {-# NOINLINE rateDup #-}
125:
126: rateRecDup 0 t = case dup t of Box (Node n _) -> value n
127: rateRecDup d t = case dup t of Box (Node _ ts) -> maximum (map (rate (d-1)) ts)
128: {-# NOINLINE rateRecDup #-}
129:
130: dosomethingwith :: Tree -> IO S
131: dosomethingwith t = return $! solve t !! 1
132: {-# NOINLINE dosomethingwith #-}
133:
134: runSize = 10000
135: --runSize = 10
136:
137: data Run = forall t . Run {
138: gTree :: S -> t,
139: gSolve :: t -> IO S,
140: gDosomethingwith :: t -> IO S,
141: gFirstChild :: t -> t,
142: gEvalAll :: t -> IO S}
143:
144:
145: regularSolver :: (Tree -> [S]) -> Run
146: regularSolver s = Run
147: tree
148: (\t -> return $! s t !! 10000)
149: (\t -> return $! solve t !! 1)
150: firstChild
151: (\t -> return $! solve t !! 10000)
152:
153: regularSolverSlow :: (Tree -> [S]) -> Run
154: regularSolverSlow s = Run
155: treeSlow
156: (\t -> return $! s t !! 10000)
157: (\t -> return $! solve t !! 1)
158: firstChild
159: (\t -> return $! solve t !! 10000)
160:
161: data RunDesc = Original
162: | SolveDup
163: | RateDup
164: | RateRecDup
165: | SolveDeepDup
166: | SolveDeepDupRateDup
167: | Unit
168: | Church
169: deriving (Show, Read, Eq)
170:
171: runDescDesc Original = "original"
172: runDescDesc SolveDup = "\\textsf{solveDup}"
173: runDescDesc SolveDeepDup = "\\textsf{solveDeepDup}"
174: runDescDesc RateDup = "\\textsf{rateDup}"
175: runDescDesc RateRecDup = "\\textsf{rateRecDup}"
176: runDescDesc Unit = "unit lifting"
177: runDescDesc Church = "church encoding"
178:
179:
180: runs :: [((Bool,RunDesc), Run)]
181: runs = [
182: ((False,Original), regularSolver solve),
183: ((False,SolveDup), regularSolver solveDup),
184: ((False,RateDup), regularSolver solveRateDup),
185: -- ((False,RateRecDup), regularSolver solveRateRecDup),
186: ((False,SolveDeepDup), regularSolver solveDeepDup),
187: -- ((False,SolveDeepDupRateDup), regularSolver solveDeepDupRateDup),
188: ((False,Unit), Run
189: utree
190: (\t -> return $! usolve t !! 10000)
191: (\t -> return $! usolve t !! 1)
192: id
193: (\t -> return $! usolve t !! 10000)
194: ),
195: ((False,Church), Run
196: ctree
197: (\t -> return $! csolve t !! 10000)
198: (\t -> return $! csolve t !! 1)
199: id
200: (\t -> return $! csolve t !! 10000)
201: ),
202: ((True,Original), regularSolverSlow solve),
203: ((True,SolveDup), regularSolverSlow solveDup),
204: ((True,RateDup), regularSolverSlow solveRateDup),
205: -- ((True,RateRecDup), regularSolver solveRateRecDup),
206: ((True,SolveDeepDup), regularSolverSlow solveDeepDup),
207: ((True,Unit), Run
208: utreeSlow
209: (\t -> return $! usolve t !! 10000)
210: (\t -> return $! usolve t !! 1)
211: id
212: (\t -> return $! usolve t !! 10000)
213: ),
214: ((True,Church), Run
215: ctreeSlow
216: (\t -> return $! csolve t !! 10000)
217: (\t -> return $! csolve t !! 1)
218: id
219: (\t -> return $! csolve t !! 10000)
220: )
221: ]
222:
223: data Variant = Unshared | Shared | SharedThunk | SharedEvaled | SharedFull | RunTwice deriving (Eq, Read, Show, Enum, Bounded)
224:
225: vardesc Unshared = "no sharing"
226: vardesc Shared = "shared tree"
227: vardesc SharedThunk = "add. thunk"
228: vardesc SharedEvaled = "partly eval'ed"
229: vardesc SharedFull = "fully eval'ed"
230: vardesc RunTwice = "run twice"
231:
232: skipped = [(SharedEvaled, Unit), (SharedEvaled, Church),
233: (SharedFull, Unit), (SharedFull, Church)]
234:
235: mainStats slow = do
236: let slowT = if slow then "slow:" else ""
237: printf "\\makeatletter\n"
238: printf "\\begin{tabular}{l"
239: forM_ [minBound..maxBound::Variant] $ \variant -> do
240: printf "rr"
241: printf "}\n"
242: printf " \\\\\n"
243: forM_ [minBound..maxBound::Variant] $ \variant -> do
244: printf "& \\multicolumn{2}{c}{%s}" (vardesc variant)
245: printf " \\\\\n"
246: forM_ [minBound..maxBound::Variant] $ \variant -> do
247: printf "& MB & sec."
248: printf " \\\\ \\midrule \n"
249: hSetBuffering stdout NoBuffering
250: forM_ (map fst runs) $ \run -> when (fst run == slow) $ do
251: printf "%s%%\n" (runDescDesc (snd run))
252: forM_ [minBound..maxBound::Variant] $ \variant ->
253: if (variant, snd run) `elem` skipped
254: then putStr "&\n&\n"
255: else do
256: out <- readProcess "./PaperStats" [show run, show variant] ""
257: let (_, _, alloc, time) = read out :: (String, Variant, Integer, Double)
258: -- print (run, variant, alloc, time)
259: printf "&\n {\\def\\@currentlabel{%s}\\label{stats:%s%s:%s:mem}%s}" (showLargeNum alloc) slowT (show (snd run)) (show variant) (showLargeNum alloc)
260: printf " &\n {\\def\\@currentlabel{%.2f}\\label{stats:%s%s:%s:time}%.2f}" time slowT (show (snd run)) (show variant) time
261: return ()
262: printf " \\\\\n"
263: printf "\\end{tabular}\n"
264: printf "\\makeatother\n"
265:
266: showLargeNum = intercalate "\\," . map reverse . reverse . splitEvery 3 . reverse . show
267:
268: splitEvery _ [] = []
269: splitEvery n l = take n l : splitEvery n (drop n l)
270:
271:
272: mainRun :: (Bool, RunDesc) -> Variant -> S -> IO ()
273: mainRun n variant k = do
274: case fromJust $ lookup n runs of
275: Run{..} -> do
276: case variant of
277: Unshared -> do
278: let t = gTree k
279: gSolve t
280: Shared -> do
281: let t = gTree k
282: gSolve t
283: performGC
284: gDosomethingwith t
285: SharedThunk -> do
286: let t = gTree k
287: let t' = gFirstChild t
288: gSolve t'
289: performGC
290: gDosomethingwith t
291: SharedEvaled -> do
292: let t = gTree k
293: gFirstChild t `seq` return ()
294: performGC
295: gSolve t
296: performGC
297: gDosomethingwith t
298: SharedFull -> do
299: let t = gTree k
300: gEvalAll t
301: performGC
302: gSolve t
303: performGC
304: gDosomethingwith t
305: RunTwice -> do
306: let t = gTree k
307: gSolve t
308: performGC
309: gSolve t
310: performGC
311: gDosomethingwith t
312: performGC
313: stats <- getGCStats
314: print (show n, variant, peakMegabytesAllocated stats, cpuSeconds stats)
315:
316: main = do
317: args <- getArgs
318: case args of
319: [] -> mainStats False
320: ["slow"] -> mainStats True
321: [n,s] -> mainRun (read n) (read s) (fromIntegral (length args))
322: {-
323: main = do
324: [n] <- getArgs
325: let k = read n
326: print k
327: performGC
328: let t = tree k
329:
330: --t `seq` return ()
331: --print $ rate 1 t
332:
333: print $ solve t !! runSize
334: print $ solve t !! runSize
335: hFlush stdout
336: print $ solve t !! 1
337:
338: -}
Generated by git2html.