2 % (c) The AQUA Project, Glasgow University, 1993-1996
4 \section[SimplMonad]{The simplifier Monad}
7 #include "HsVersions.h"
11 initSmpl, returnSmpl, thenSmpl, thenSmpl_,
12 mapSmpl, mapAndUnzipSmpl,
15 SimplCount{-abstract-}, TickType(..), tick, tickN, tickUnfold,
16 simplCount, detailedSimplCount,
17 zeroSimplCount, showSimplCount, combineSimplCounts,
20 cloneId, cloneIds, cloneTyVarSmpl, newIds, newId
26 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
27 IMPORT_DELOOPER(SmplLoop) -- well, cheating sort of
29 import {-# SOURCE #-} Simplify
30 import {-# SOURCE #-} MagicUFs
33 import Id ( GenId, mkSysLocal, mkIdWithNewUniq, SYN_IE(Id) )
34 import CoreUnfold ( SimpleUnfolding )
36 import SrcLoc ( noSrcLoc )
37 import TyVar ( cloneTyVar, SYN_IE(TyVar) )
38 import Type ( SYN_IE(Type) )
39 import UniqSupply ( getUnique, getUniques, splitUniqSupply,
42 import Util ( zipWithEqual, panic, SYN_IE(Eager), appEager, pprTrace )
44 import Outputable ( PprStyle(..), Outputable(..) )
46 infixr 9 `thenSmpl`, `thenSmpl_`
49 %************************************************************************
51 \subsection{Monad plumbing}
53 %************************************************************************
55 For the simplifier monad, we want to {\em thread} a unique supply and a counter.
56 (Command-line switches move around through the explicitly-passed SimplEnv.)
61 -> SimplCount -- things being threaded
62 -> (result, SimplCount)
66 initSmpl :: UniqSupply -- no init count; set to 0
70 initSmpl us m = m us zeroSimplCount
72 {-# INLINE thenSmpl #-}
73 {-# INLINE thenSmpl_ #-}
74 {-# INLINE returnSmpl #-}
76 returnSmpl :: a -> SmplM a
77 returnSmpl e us sc = (e, sc)
79 thenSmpl :: SmplM a -> (a -> SmplM b) -> SmplM b
80 thenSmpl_ :: SmplM a -> SmplM b -> SmplM b
83 = case splitUniqSupply us of { (s1, s2) ->
84 case (m s1 sc0) of { (m_result, sc1) ->
88 = case splitUniqSupply us of { (s1, s2) ->
89 case (m s1 sc0) of { (_, sc1) ->
92 mapSmpl :: (a -> SmplM b) -> [a] -> SmplM [b]
93 mapAndUnzipSmpl :: (a -> SmplM (b, c)) -> [a] -> SmplM ([b],[c])
95 mapSmpl f [] = returnSmpl []
97 = f x `thenSmpl` \ x' ->
98 mapSmpl f xs `thenSmpl` \ xs' ->
101 mapAndUnzipSmpl f [] = returnSmpl ([],[])
102 mapAndUnzipSmpl f (x:xs)
103 = f x `thenSmpl` \ (r1, r2) ->
104 mapAndUnzipSmpl f xs `thenSmpl` \ (rs1, rs2) ->
105 returnSmpl (r1:rs1, r2:rs2)
109 %************************************************************************
111 \subsection{Counting up what we've done}
113 %************************************************************************
115 The assoc list isn't particularly costly, because we only use
116 the number of ticks in ``real life.''
118 The right thing to do, if you want that to go fast, is thread
119 a mutable array through @SimplM@.
123 = SimplCount FAST_INT -- number of ticks
124 [(TickType, Int)] -- assoc list of all diff kinds of ticks
127 type UnfoldingHistory = (Int, -- N
128 [(Id,Int)], -- Last N unfoldings
129 [(Id,Int)]) -- The MaxUnfoldHistory unfoldings before that
132 = UnfoldingDone | MagicUnfold | ConReused
133 | CaseFloatFromLet | CaseOfCase
134 | LetFloatFromLet | LetFloatFromCase
135 | KnownBranch | Let2Case
136 | CaseMerge | CaseElim
138 | AtomicRhs -- Rhs of a let-expression was an atom
144 {- BEGIN F/B ENTRIES -}
146 | FoldrBuild -- foldr f z (build g) ==>
147 | FoldrAugment -- foldr f z (augment g z) ==>
148 | Foldr_Nil -- foldr f z [] ==>
149 | Foldr_List -- foldr f z (x:...) ==>
151 | FoldlBuild -- foldl f z (build g) ==>
152 | FoldlAugment -- foldl f z (augment g z) ==>
153 | Foldl_Nil -- foldl f z [] ==>
154 | Foldl_List -- foldl f z (x:...) ==>
156 | Foldr_Cons_Nil -- foldr (:) [] => id
157 | Foldr_Cons -- foldr (:) => flip (++)
159 | Str_FoldrStr -- foldr f z "hello" => unpackFoldrPS__ f z "hello"
160 | Str_UnpackCons -- unpackFoldrPS# (:) z "hello" => unpackAppendPS__ z "hello"
161 | Str_UnpackNil -- unpackAppendPS__ [] "hello" => "hello"
162 {- END F/B ENTRIES -}
163 deriving (Eq, Ord, Ix)
165 instance Text TickType where
166 showsPrec p UnfoldingDone = showString "UnfoldingDone "
167 showsPrec p MagicUnfold = showString "MagicUnfold "
168 showsPrec p ConReused = showString "ConReused "
169 showsPrec p CaseFloatFromLet= showString "CaseFloatFromLet "
170 showsPrec p CaseOfCase = showString "CaseOfCase "
171 showsPrec p LetFloatFromLet = showString "LetFloatFromLet "
172 showsPrec p LetFloatFromCase= showString "LetFloatFromCase "
173 showsPrec p KnownBranch = showString "KnownBranch "
174 showsPrec p Let2Case = showString "Let2Case "
175 showsPrec p CaseMerge = showString "CaseMerge "
176 showsPrec p CaseElim = showString "CaseElim "
177 showsPrec p CaseIdentity = showString "CaseIdentity "
178 showsPrec p AtomicRhs = showString "AtomicRhs "
179 showsPrec p EtaExpansion = showString "EtaExpansion "
180 showsPrec p CaseOfError = showString "CaseOfError "
181 showsPrec p TyBetaReduction = showString "TyBetaReduction "
182 showsPrec p BetaReduction = showString "BetaReduction "
183 showsPrec p SpecialisationDone
184 = showString "Specialisation "
186 -- Foldr/Build Stuff:
187 showsPrec p FoldrBuild = showString "FoldrBuild "
188 showsPrec p FoldrAugment = showString "FoldrAugment "
189 showsPrec p Foldr_Nil = showString "Foldr_Nil "
190 showsPrec p Foldr_List = showString "Foldr_List "
192 showsPrec p FoldlBuild = showString "FoldlBuild "
193 showsPrec p FoldlAugment = showString "FoldlAugment "
194 showsPrec p Foldl_Nil = showString "Foldl_Nil "
195 showsPrec p Foldl_List = showString "Foldl_List "
197 showsPrec p Foldr_Cons_Nil = showString "Foldr_Cons_Nil "
198 showsPrec p Foldr_Cons = showString "Foldr_Cons "
200 showsPrec p Str_FoldrStr = showString "Str_FoldrStr "
201 showsPrec p Str_UnpackCons = showString "Str_UnpackCons "
202 showsPrec p Str_UnpackNil = showString "Str_UnpackNil "
204 showSimplCount :: SimplCount -> String
206 showSimplCount (SimplCount _ stuff (_, unf1, unf2))
207 = shw stuff ++ "\nMost recent unfoldings: " ++ show (ppr PprDebug (reverse unf2 ++ reverse unf1))
210 shw ((t,n):tns) | n /= 0 = show t ++ ('\t' : show n) ++ ('\n' : shw tns)
211 | otherwise = shw tns
213 -- ToDo: move to Outputable
214 instance Outputable Int where
217 zeroSimplCount :: SimplCount
219 = SimplCount ILIT(0) stuff (0, [], [])
222 [ (UnfoldingDone, 0),
225 (CaseFloatFromLet, 0),
227 (LetFloatFromLet, 0),
228 (LetFloatFromCase, 0),
239 (SpecialisationDone,0),
240 -- Foldr/Build Stuff:
256 --= array (con2tag_TickType UnfoldingDone, con2tag_TickType FoldrInline)
257 -- [ i := 0 | i <- indices zeroSimplCount ]
260 Counting-related monad functions:
262 tick :: TickType -> SmplM ()
264 tick tick_type us (SimplCount n stuff unf)
265 = -- pprTrace "Tick: " (text (show tick_type)) $
266 #ifdef OMIT_SIMPL_COUNTS
267 ((), SimplCount (n _ADD_ ILIT(1) stuff unf)) stuff -- don't change anything
270 ((), SimplCount (n _ADD_ ILIT(1)) new_stuff unf)
272 new_stuff = inc_tick tick_type ILIT(1) stuff
275 maxUnfoldHistory :: Int
276 maxUnfoldHistory = 20
278 tickUnfold :: Id -> SmplM ()
279 tickUnfold id us (SimplCount n stuff (n_unf, unf1, unf2))
280 = -- pprTrace "Unfolding: " (ppr PprDebug id) $
283 ((), SimplCount (n _ADD_ ILIT(1)) new_stuff new_unf)
285 new_stuff = inc_tick UnfoldingDone ILIT(1) stuff
287 new_unf | n_unf >= maxUnfoldHistory = (1, [unf_item], unf1)
288 | otherwise = (n_unf+1, unf_item:unf1, unf2)
290 unf_item = (id, IBOX(n))
293 -- force list to avoid getting a chain of @inc_tick@ applications
294 -- building up on the heap. (Only true when not dumping stats).
298 seqTriple (_,_,_) y = y
300 tickN :: TickType -> Int -> SmplM ()
302 tickN tick_type 0 us counts
304 tickN tick_type IBOX(increment) us (SimplCount n stuff unf)
305 = -- pprTrace "Tick: " (text (show tick_type)) $
306 #ifdef OMIT_SIMPL_COUNTS
307 ((), SimplCount (n _ADD_ increment) stuff) -- don't change anything
310 ((), SimplCount (n _ADD_ increment) new_stuff unf)
312 new_stuff = inc_tick tick_type increment stuff
315 inc_tick tick_type n [] = panic "couldn't inc_tick!"
317 inc_tick tick_type n (x@(ttype, I# cnt#) : xs)
318 | ttype == tick_type = case cnt# +# n of
319 incd -> (ttype,IBOX(incd)) : xs
321 | otherwise = case inc_tick tick_type n xs of { [] -> [x]; ls -> x:ls }
324 simplCount :: SmplM Int
325 simplCount us sc@(SimplCount n _ _) = (IBOX(n), sc)
327 detailedSimplCount :: SmplM SimplCount
328 detailedSimplCount us sc = (sc, sc)
330 combineSimplCounts :: SimplCount -> SimplCount -> SimplCount
332 #ifdef OMIT_SIMPL_COUNTS
333 combineSimplCounts (SimplCount n1 stuff1 unf1) (SimplCount n2 stuff2 unf2)
334 = SimplCount (n1 _ADD_ n2)
335 stuff2 -- just pick one
338 combineSimplCounts (SimplCount n1 stuff1 unf1) (SimplCount n2 stuff2 unf2)
340 SimplCount (n1 _ADD_ n2) new_stuff unf2 -- Just pick the second for unfold history
342 new_stuff = zipWithEqual "combineSimplCounts" (\ (t1,c1) (t2,c2) -> (t1,c1+c2)) stuff1 stuff2
346 %************************************************************************
348 \subsection{Monad primitives}
350 %************************************************************************
353 newId :: Type -> SmplM Id
355 = (mkSysLocal SLIT("s") uniq ty noSrcLoc, sc)
359 newIds :: [Type] -> SmplM [Id]
361 = (zipWithEqual "newIds" mk_id tys uniqs, sc)
363 uniqs = getUniques (length tys) us
364 mk_id ty uniq = mkSysLocal SLIT("s") uniq ty noSrcLoc
366 cloneTyVarSmpl :: TyVar -> SmplM TyVar
368 cloneTyVarSmpl tyvar us sc
372 new_tyvar = cloneTyVar tyvar uniq
374 cloneId :: SimplEnv -> InBinder -> SmplM OutId
375 cloneId env (id,_) us sc
376 = simplTyInId env id `appEager` \ id_with_new_ty ->
377 (mkIdWithNewUniq id_with_new_ty uniq, sc)
381 cloneIds :: SimplEnv -> [InBinder] -> SmplM [OutId]
382 cloneIds env binders = mapSmpl (cloneId env) binders