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,
16 simplCount, detailedSimplCount,
17 zeroSimplCount, showSimplCount, combineSimplCounts,
20 cloneId, cloneIds, cloneTyVarSmpl, newIds, newId
26 IMPORT_DELOOPER(SmplLoop) -- well, cheating sort of
28 import Id ( mkSysLocal, mkIdWithNewUniq )
29 import CoreUnfold ( SimpleUnfolding )
31 import SrcLoc ( mkUnknownSrcLoc )
32 import TyVar ( cloneTyVar )
33 import UniqSupply ( getUnique, getUniques, splitUniqSupply,
36 import Util ( zipWithEqual, panic )
38 infixr 9 `thenSmpl`, `thenSmpl_`
41 %************************************************************************
43 \subsection{Monad plumbing}
45 %************************************************************************
47 For the simplifier monad, we want to {\em thread} a unique supply and a counter.
48 (Command-line switches move around through the explicitly-passed SimplEnv.)
53 -> SimplCount -- things being threaded
54 -> (result, SimplCount)
58 initSmpl :: UniqSupply -- no init count; set to 0
62 initSmpl us m = m us zeroSimplCount
64 {-# INLINE thenSmpl #-}
65 {-# INLINE thenSmpl_ #-}
66 {-# INLINE returnSmpl #-}
68 returnSmpl :: a -> SmplM a
69 returnSmpl e us sc = (e, sc)
71 thenSmpl :: SmplM a -> (a -> SmplM b) -> SmplM b
72 thenSmpl_ :: SmplM a -> SmplM b -> SmplM b
75 = case splitUniqSupply us of { (s1, s2) ->
76 case (m s1 sc0) of { (m_result, sc1) ->
80 = case splitUniqSupply us of { (s1, s2) ->
81 case (m s1 sc0) of { (_, sc1) ->
84 mapSmpl :: (a -> SmplM b) -> [a] -> SmplM [b]
85 mapAndUnzipSmpl :: (a -> SmplM (b, c)) -> [a] -> SmplM ([b],[c])
87 mapSmpl f [] = returnSmpl []
89 = f x `thenSmpl` \ x' ->
90 mapSmpl f xs `thenSmpl` \ xs' ->
93 mapAndUnzipSmpl f [] = returnSmpl ([],[])
94 mapAndUnzipSmpl f (x:xs)
95 = f x `thenSmpl` \ (r1, r2) ->
96 mapAndUnzipSmpl f xs `thenSmpl` \ (rs1, rs2) ->
97 returnSmpl (r1:rs1, r2:rs2)
101 %************************************************************************
103 \subsection{Counting up what we've done}
105 %************************************************************************
107 The assoc list isn't particularly costly, because we only use
108 the number of ticks in ``real life.''
110 The right thing to do, if you want that to go fast, is thread
111 a mutable array through @SimplM@.
115 = SimplCount FAST_INT -- number of ticks
116 [(TickType, Int)] -- assoc list of all diff kinds of ticks
119 = UnfoldingDone | MagicUnfold | ConReused
120 | CaseFloatFromLet | CaseOfCase
121 | LetFloatFromLet | LetFloatFromCase
122 | KnownBranch | Let2Case
123 | CaseMerge | CaseElim
125 | AtomicRhs -- Rhs of a let-expression was an atom
131 {- BEGIN F/B ENTRIES -}
133 | FoldrBuild -- foldr f z (build g) ==>
134 | FoldrAugment -- foldr f z (augment g z) ==>
135 | Foldr_Nil -- foldr f z [] ==>
136 | Foldr_List -- foldr f z (x:...) ==>
138 | FoldlBuild -- foldl f z (build g) ==>
139 | FoldlAugment -- foldl f z (augment g z) ==>
140 | Foldl_Nil -- foldl f z [] ==>
141 | Foldl_List -- foldl f z (x:...) ==>
143 | Foldr_Cons_Nil -- foldr (:) [] => id
144 | Foldr_Cons -- foldr (:) => flip (++)
146 | Str_FoldrStr -- foldr f z "hello" => unpackFoldrPS__ f z "hello"
147 | Str_UnpackCons -- unpackFoldrPS# (:) z "hello" => unpackAppendPS__ z "hello"
148 | Str_UnpackNil -- unpackAppendPS__ [] "hello" => "hello"
149 {- END F/B ENTRIES -}
150 deriving (Eq, Ord, Ix)
152 instance Text TickType where
153 showsPrec p UnfoldingDone = showString "UnfoldingDone "
154 showsPrec p MagicUnfold = showString "MagicUnfold "
155 showsPrec p ConReused = showString "ConReused "
156 showsPrec p CaseFloatFromLet= showString "CaseFloatFromLet "
157 showsPrec p CaseOfCase = showString "CaseOfCase "
158 showsPrec p LetFloatFromLet = showString "LetFloatFromLet "
159 showsPrec p LetFloatFromCase= showString "LetFloatFromCase "
160 showsPrec p KnownBranch = showString "KnownBranch "
161 showsPrec p Let2Case = showString "Let2Case "
162 showsPrec p CaseMerge = showString "CaseMerge "
163 showsPrec p CaseElim = showString "CaseElim "
164 showsPrec p CaseIdentity = showString "CaseIdentity "
165 showsPrec p AtomicRhs = showString "AtomicRhs "
166 showsPrec p EtaExpansion = showString "EtaExpansion "
167 showsPrec p CaseOfError = showString "CaseOfError "
168 showsPrec p TyBetaReduction = showString "TyBetaReduction "
169 showsPrec p BetaReduction = showString "BetaReduction "
170 showsPrec p SpecialisationDone
171 = showString "Specialisation "
173 -- Foldr/Build Stuff:
174 showsPrec p FoldrBuild = showString "FoldrBuild "
175 showsPrec p FoldrAugment = showString "FoldrAugment "
176 showsPrec p Foldr_Nil = showString "Foldr_Nil "
177 showsPrec p Foldr_List = showString "Foldr_List "
179 showsPrec p FoldlBuild = showString "FoldlBuild "
180 showsPrec p FoldlAugment = showString "FoldlAugment "
181 showsPrec p Foldl_Nil = showString "Foldl_Nil "
182 showsPrec p Foldl_List = showString "Foldl_List "
184 showsPrec p Foldr_Cons_Nil = showString "Foldr_Cons_Nil "
185 showsPrec p Foldr_Cons = showString "Foldr_Cons "
187 showsPrec p Str_FoldrStr = showString "Str_FoldrStr "
188 showsPrec p Str_UnpackCons = showString "Str_UnpackCons "
189 showsPrec p Str_UnpackNil = showString "Str_UnpackNil "
191 showSimplCount :: SimplCount -> String
193 showSimplCount (SimplCount _ stuff)
197 shw ((t,n):tns) | n /= 0 = show t ++ ('\t' : show n) ++ ('\n' : shw tns)
198 | otherwise = shw tns
200 zeroSimplCount :: SimplCount
203 [ (UnfoldingDone, 0),
206 (CaseFloatFromLet, 0),
208 (LetFloatFromLet, 0),
209 (LetFloatFromCase, 0),
220 (SpecialisationDone,0),
221 -- Foldr/Build Stuff:
237 --= array (con2tag_TickType UnfoldingDone, con2tag_TickType FoldrInline)
238 -- [ i := 0 | i <- indices zeroSimplCount ]
241 Counting-related monad functions:
243 tick :: TickType -> SmplM ()
245 tick tick_type us (SimplCount n stuff)
246 = ((), SimplCount (n _ADD_ ILIT(1))
247 #ifdef OMIT_SIMPL_COUNTS
248 stuff -- don't change anything
254 inc_tick [] = panic "couldn't inc_tick!"
255 inc_tick (x@(ttype, cnt) : xs)
256 = if ttype == tick_type then
264 tickN :: TickType -> Int -> SmplM ()
266 tickN tick_type 0 us counts
268 tickN tick_type IBOX(increment) us (SimplCount n stuff)
269 = ((), SimplCount (n _ADD_ increment)
270 #ifdef OMIT_SIMPL_COUNTS
271 stuff -- don't change anything
277 inc_tick [] = panic "couldn't inc_tick!"
278 inc_tick (x@(ttype, cnt) : xs)
279 = if ttype == tick_type then
281 incd = cnt + IBOX(increment)
287 simplCount :: SmplM Int
288 simplCount us sc@(SimplCount n _) = (IBOX(n), sc)
290 detailedSimplCount :: SmplM SimplCount
291 detailedSimplCount us sc = (sc, sc)
293 combineSimplCounts :: SimplCount -> SimplCount -> SimplCount
295 #ifdef OMIT_SIMPL_COUNTS
296 combineSimplCounts (SimplCount n1 stuff1) (SimplCount n2 stuff2)
297 = SimplCount (n1 _ADD_ n2)
298 stuff1 -- just pick one
300 combineSimplCounts (SimplCount n1 stuff1) (SimplCount n2 stuff2)
301 = SimplCount (n1 _ADD_ n2)
302 (zipWithEqual "combineSimplCounts" (\ (t1,c1) (t2,c2) -> (t1,c1+c2)) stuff1 stuff2)
306 %************************************************************************
308 \subsection{Monad primitives}
310 %************************************************************************
313 newId :: Type -> SmplM Id
315 = (mkSysLocal SLIT("s") uniq ty mkUnknownSrcLoc, sc)
319 newIds :: [Type] -> SmplM [Id]
321 = (zipWithEqual "newIds" mk_id tys uniqs, sc)
323 uniqs = getUniques (length tys) us
324 mk_id ty uniq = mkSysLocal SLIT("s") uniq ty mkUnknownSrcLoc
326 cloneTyVarSmpl :: TyVar -> SmplM TyVar
328 cloneTyVarSmpl tyvar us sc
332 new_tyvar = cloneTyVar tyvar uniq
334 cloneId :: SimplEnv -> InBinder -> SmplM OutId
335 cloneId env (id,_) us sc
336 = (mkIdWithNewUniq id_with_new_ty uniq, sc)
338 id_with_new_ty = simplTyInId env id
341 cloneIds :: SimplEnv -> [InBinder] -> SmplM [OutId]
342 cloneIds env binders = mapSmpl (cloneId env) binders