2 % (c) The AQUA Project, Glasgow University, 1993-1996
4 \section[SimplMonad]{The simplifier Monad}
9 initSmpl, returnSmpl, thenSmpl, thenSmpl_,
10 mapSmpl, mapAndUnzipSmpl, mapAccumLSmpl,
13 getUniqueSmpl, getUniquesSmpl,
16 SimplCount{-abstract-}, TickType(..), tick, tickN, tickUnfold,
17 simplCount, detailedSimplCount,
18 zeroSimplCount, showSimplCount, combineSimplCounts
21 #include "HsVersions.h"
23 import MkId ( mkSysLocal )
24 import Id ( mkIdWithNewUniq, Id )
26 import SrcLoc ( noSrcLoc )
27 import TyVar ( TyVar )
29 import UniqSupply ( getUnique, getUniques, splitUniqSupply,
32 import Unique ( Unique )
33 import Util ( zipWithEqual, Eager, appEager )
37 infixr 9 `thenSmpl`, `thenSmpl_`
40 %************************************************************************
42 \subsection{Monad plumbing}
44 %************************************************************************
46 For the simplifier monad, we want to {\em thread} a unique supply and a counter.
47 (Command-line switches move around through the explicitly-passed SimplEnv.)
52 -> SimplCount -- things being threaded
53 -> (result, SimplCount)
57 initSmpl :: UniqSupply -- no init count; set to 0
61 initSmpl us m = m us zeroSimplCount
63 {-# INLINE thenSmpl #-}
64 {-# INLINE thenSmpl_ #-}
65 {-# INLINE returnSmpl #-}
67 returnSmpl :: a -> SmplM a
68 returnSmpl e us sc = (e, sc)
70 thenSmpl :: SmplM a -> (a -> SmplM b) -> SmplM b
71 thenSmpl_ :: SmplM a -> SmplM b -> SmplM b
74 = case splitUniqSupply us of { (s1, s2) ->
75 case (m s1 sc0) of { (m_result, sc1) ->
79 = case splitUniqSupply us of { (s1, s2) ->
80 case (m s1 sc0) of { (_, sc1) ->
83 mapSmpl :: (a -> SmplM b) -> [a] -> SmplM [b]
84 mapAndUnzipSmpl :: (a -> SmplM (b, c)) -> [a] -> SmplM ([b],[c])
86 mapSmpl f [] = returnSmpl []
88 = f x `thenSmpl` \ x' ->
89 mapSmpl f xs `thenSmpl` \ xs' ->
92 mapAndUnzipSmpl f [] = returnSmpl ([],[])
93 mapAndUnzipSmpl f (x:xs)
94 = f x `thenSmpl` \ (r1, r2) ->
95 mapAndUnzipSmpl f xs `thenSmpl` \ (rs1, rs2) ->
96 returnSmpl (r1:rs1, r2:rs2)
98 mapAccumLSmpl f acc [] = returnSmpl (acc, [])
99 mapAccumLSmpl f acc (x:xs) = f acc x `thenSmpl` \ (acc', x') ->
100 mapAccumLSmpl f acc' xs `thenSmpl` \ (acc'', xs') ->
101 returnSmpl (acc'', x':xs')
103 getUniqueSmpl :: SmplM Unique
104 getUniqueSmpl us sc = (getUnique us, sc)
106 getUniquesSmpl :: Int -> SmplM [Unique]
107 getUniquesSmpl n us sc = (getUniques n us, sc)
111 %************************************************************************
113 \subsection{Counting up what we've done}
115 %************************************************************************
117 The assoc list isn't particularly costly, because we only use
118 the number of ticks in ``real life.''
120 The right thing to do, if you want that to go fast, is thread
121 a mutable array through @SimplM@.
125 = SimplCount FAST_INT -- number of ticks
126 [(TickType, Int)] -- assoc list of all diff kinds of ticks
129 type UnfoldingHistory = (Int, -- N
130 [(Id,Int)], -- Last N unfoldings
131 [(Id,Int)]) -- The MaxUnfoldHistory unfoldings before that
134 = UnfoldingDone | MagicUnfold | ConReused
135 | CaseFloatFromLet | CaseOfCase
136 | LetFloatFromLet | LetFloatFromCase
137 | KnownBranch | Let2Case
138 | CaseMerge | CaseElim
140 | AtomicRhs -- Rhs of a let-expression was an atom
146 {- BEGIN F/B ENTRIES -}
148 | FoldrBuild -- foldr f z (build g) ==>
149 | FoldrAugment -- foldr f z (augment g z) ==>
150 | Foldr_Nil -- foldr f z [] ==>
151 | Foldr_List -- foldr f z (x:...) ==>
153 | FoldlBuild -- foldl f z (build g) ==>
154 | FoldlAugment -- foldl f z (augment g z) ==>
155 | Foldl_Nil -- foldl f z [] ==>
156 | Foldl_List -- foldl f z (x:...) ==>
158 | Foldr_Cons_Nil -- foldr (:) [] => id
159 | Foldr_Cons -- foldr (:) => flip (++)
161 | Str_FoldrStr -- foldr f z "hello" => unpackFoldrPS__ f z "hello"
162 | Str_UnpackCons -- unpackFoldrPS# (:) z "hello" => unpackAppendPS__ z "hello"
163 | Str_UnpackNil -- unpackAppendPS__ [] "hello" => "hello"
164 {- END F/B ENTRIES -}
165 deriving (Eq, Ord, Ix)
167 instance Text TickType where
168 showsPrec p UnfoldingDone = showString "UnfoldingDone "
169 showsPrec p MagicUnfold = showString "MagicUnfold "
170 showsPrec p ConReused = showString "ConReused "
171 showsPrec p CaseFloatFromLet= showString "CaseFloatFromLet "
172 showsPrec p CaseOfCase = showString "CaseOfCase "
173 showsPrec p LetFloatFromLet = showString "LetFloatFromLet "
174 showsPrec p LetFloatFromCase= showString "LetFloatFromCase "
175 showsPrec p KnownBranch = showString "KnownBranch "
176 showsPrec p Let2Case = showString "Let2Case "
177 showsPrec p CaseMerge = showString "CaseMerge "
178 showsPrec p CaseElim = showString "CaseElim "
179 showsPrec p CaseIdentity = showString "CaseIdentity "
180 showsPrec p AtomicRhs = showString "AtomicRhs "
181 showsPrec p EtaExpansion = showString "EtaExpansion "
182 showsPrec p CaseOfError = showString "CaseOfError "
183 showsPrec p TyBetaReduction = showString "TyBetaReduction "
184 showsPrec p BetaReduction = showString "BetaReduction "
185 showsPrec p SpecialisationDone
186 = showString "Specialisation "
188 -- Foldr/Build Stuff:
189 showsPrec p FoldrBuild = showString "FoldrBuild "
190 showsPrec p FoldrAugment = showString "FoldrAugment "
191 showsPrec p Foldr_Nil = showString "Foldr_Nil "
192 showsPrec p Foldr_List = showString "Foldr_List "
194 showsPrec p FoldlBuild = showString "FoldlBuild "
195 showsPrec p FoldlAugment = showString "FoldlAugment "
196 showsPrec p Foldl_Nil = showString "Foldl_Nil "
197 showsPrec p Foldl_List = showString "Foldl_List "
199 showsPrec p Foldr_Cons_Nil = showString "Foldr_Cons_Nil "
200 showsPrec p Foldr_Cons = showString "Foldr_Cons "
202 showsPrec p Str_FoldrStr = showString "Str_FoldrStr "
203 showsPrec p Str_UnpackCons = showString "Str_UnpackCons "
204 showsPrec p Str_UnpackNil = showString "Str_UnpackNil "
206 showSimplCount :: SimplCount -> String
208 showSimplCount (SimplCount _ stuff (_, unf1, unf2))
209 = shw stuff ++ "\nMost recent unfoldings: " ++ showSDoc (ppr (reverse unf2 ++ reverse unf1))
212 shw ((t,n):tns) | n /= 0 = show t ++ ('\t' : show n) ++ ('\n' : shw tns)
213 | otherwise = shw tns
215 zeroSimplCount :: SimplCount
217 = SimplCount ILIT(0) stuff (0, [], [])
220 [ (UnfoldingDone, 0),
223 (CaseFloatFromLet, 0),
225 (LetFloatFromLet, 0),
226 (LetFloatFromCase, 0),
237 (SpecialisationDone,0),
238 -- Foldr/Build Stuff:
254 --= array (con2tag_TickType UnfoldingDone, con2tag_TickType FoldrInline)
255 -- [ i := 0 | i <- indices zeroSimplCount ]
258 Counting-related monad functions:
260 tick :: TickType -> SmplM ()
262 tick tick_type us (SimplCount n stuff unf)
263 = -- pprTrace "Tick: " (text (show tick_type)) $
264 #ifdef OMIT_SIMPL_COUNTS
265 ((), SimplCount (n _ADD_ ILIT(1) stuff unf)) stuff -- don't change anything
268 ((), SimplCount (n _ADD_ ILIT(1)) new_stuff unf)
270 new_stuff = inc_tick tick_type ILIT(1) stuff
273 maxUnfoldHistory :: Int
274 maxUnfoldHistory = 20
276 tickUnfold :: Id -> SmplM ()
277 tickUnfold id us (SimplCount n stuff (n_unf, unf1, unf2))
278 = -- pprTrace "Unfolding: " (ppr id) $
281 ((), SimplCount (n _ADD_ ILIT(1)) new_stuff new_unf)
283 new_stuff = inc_tick UnfoldingDone ILIT(1) stuff
285 new_unf | n_unf >= maxUnfoldHistory = (1, [unf_item], unf1)
286 | otherwise = (n_unf+1, unf_item:unf1, unf2)
288 unf_item = (id, IBOX(n))
291 -- force list to avoid getting a chain of @inc_tick@ applications
292 -- building up on the heap. (Only true when not dumping stats).
296 seqTriple (_,_,_) y = y
298 tickN :: TickType -> Int -> SmplM ()
300 tickN tick_type 0 us counts
302 tickN tick_type IBOX(increment) us (SimplCount n stuff unf)
303 = -- pprTrace "Tick: " (text (show tick_type)) $
304 #ifdef OMIT_SIMPL_COUNTS
305 ((), SimplCount (n _ADD_ increment) stuff) -- don't change anything
308 ((), SimplCount (n _ADD_ increment) new_stuff unf)
310 new_stuff = inc_tick tick_type increment stuff
313 inc_tick tick_type n [] = panic "couldn't inc_tick!"
315 inc_tick tick_type n (x@(ttype, I# cnt#) : xs)
316 | ttype == tick_type = case cnt# +# n of
317 incd -> (ttype,IBOX(incd)) : xs
319 | otherwise = case inc_tick tick_type n xs of { [] -> [x]; ls -> x:ls }
322 simplCount :: SmplM Int
323 simplCount us sc@(SimplCount n _ _) = (IBOX(n), sc)
325 detailedSimplCount :: SmplM SimplCount
326 detailedSimplCount us sc = (sc, sc)
328 combineSimplCounts :: SimplCount -> SimplCount -> SimplCount
330 #ifdef OMIT_SIMPL_COUNTS
331 combineSimplCounts (SimplCount n1 stuff1 unf1) (SimplCount n2 stuff2 unf2)
332 = SimplCount (n1 _ADD_ n2)
333 stuff2 -- just pick one
336 combineSimplCounts (SimplCount n1 stuff1 unf1) (SimplCount n2 stuff2 unf2)
338 SimplCount (n1 _ADD_ n2) new_stuff unf2 -- Just pick the second for unfold history
340 new_stuff = zipWithEqual "combineSimplCounts" (\ (t1,c1) (t2,c2) -> (t1,c1+c2)) stuff1 stuff2