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 )
30 import SrcLoc ( mkUnknownSrcLoc )
31 import TyVar ( cloneTyVar )
32 import UniqSupply ( getUnique, getUniques, splitUniqSupply,
35 import Util ( zipWithEqual, panic )
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)
100 %************************************************************************
102 \subsection{Counting up what we've done}
104 %************************************************************************
106 The assoc list isn't particularly costly, because we only use
107 the number of ticks in ``real life.''
109 The right thing to do, if you want that to go fast, is thread
110 a mutable array through @SimplM@.
114 = SimplCount FAST_INT -- number of ticks
115 [(TickType, Int)] -- assoc list of all diff kinds of ticks
118 = UnfoldingDone | MagicUnfold | ConReused
119 | CaseFloatFromLet | CaseOfCase
120 | LetFloatFromLet | LetFloatFromCase
121 | KnownBranch | Let2Case
122 | CaseMerge | CaseElim
124 | AtomicRhs -- Rhs of a let-expression was an atom
129 {- BEGIN F/B ENTRIES -}
131 | FoldrBuild -- foldr f z (build g) ==>
132 | FoldrAugment -- foldr f z (augment g z) ==>
133 | Foldr_Nil -- foldr f z [] ==>
134 | Foldr_List -- foldr f z (x:...) ==>
136 | FoldlBuild -- foldl f z (build g) ==>
137 | FoldlAugment -- foldl f z (augment g z) ==>
138 | Foldl_Nil -- foldl f z [] ==>
139 | Foldl_List -- foldl f z (x:...) ==>
141 | Foldr_Cons_Nil -- foldr (:) [] => id
142 | Foldr_Cons -- foldr (:) => flip (++)
144 | Str_FoldrStr -- foldr f z "hello" => unpackFoldrPS__ f z "hello"
145 | Str_UnpackCons -- unpackFoldrPS# (:) z "hello" => unpackAppendPS__ z "hello"
146 | Str_UnpackNil -- unpackAppendPS__ [] "hello" => "hello"
147 {- END F/B ENTRIES -}
148 deriving (Eq, Ord, Ix)
150 instance Text TickType where
151 showsPrec p UnfoldingDone = showString "UnfoldingDone "
152 showsPrec p MagicUnfold = showString "MagicUnfold "
153 showsPrec p ConReused = showString "ConReused "
154 showsPrec p CaseFloatFromLet= showString "CaseFloatFromLet "
155 showsPrec p CaseOfCase = showString "CaseOfCase "
156 showsPrec p LetFloatFromLet = showString "LetFloatFromLet "
157 showsPrec p LetFloatFromCase= showString "LetFloatFromCase "
158 showsPrec p KnownBranch = showString "KnownBranch "
159 showsPrec p Let2Case = showString "Let2Case "
160 showsPrec p CaseMerge = showString "CaseMerge "
161 showsPrec p CaseElim = showString "CaseElim "
162 showsPrec p CaseIdentity = showString "CaseIdentity "
163 showsPrec p AtomicRhs = showString "AtomicRhs "
164 showsPrec p EtaExpansion = showString "EtaExpansion "
165 showsPrec p CaseOfError = showString "CaseOfError "
166 showsPrec p TyBetaReduction = showString "TyBetaReduction "
167 showsPrec p BetaReduction = showString "BetaReduction "
168 -- Foldr/Build Stuff:
169 showsPrec p FoldrBuild = showString "FoldrBuild "
170 showsPrec p FoldrAugment = showString "FoldrAugment "
171 showsPrec p Foldr_Nil = showString "Foldr_Nil "
172 showsPrec p Foldr_List = showString "Foldr_List "
174 showsPrec p FoldlBuild = showString "FoldlBuild "
175 showsPrec p FoldlAugment = showString "FoldlAugment "
176 showsPrec p Foldl_Nil = showString "Foldl_Nil "
177 showsPrec p Foldl_List = showString "Foldl_List "
179 showsPrec p Foldr_Cons_Nil = showString "Foldr_Cons_Nil "
180 showsPrec p Foldr_Cons = showString "Foldr_Cons "
182 showsPrec p Str_FoldrStr = showString "Str_FoldrStr "
183 showsPrec p Str_UnpackCons = showString "Str_UnpackCons "
184 showsPrec p Str_UnpackNil = showString "Str_UnpackNil "
186 showSimplCount :: SimplCount -> String
188 showSimplCount (SimplCount _ stuff)
192 shw ((t,n):tns) | n /= 0 = show t ++ ('\t' : show n) ++ ('\n' : shw tns)
193 | otherwise = shw tns
195 zeroSimplCount :: SimplCount
198 [ (UnfoldingDone, 0),
201 (CaseFloatFromLet, 0),
203 (LetFloatFromLet, 0),
204 (LetFloatFromCase, 0),
215 -- Foldr/Build Stuff:
231 --= array (con2tag_TickType UnfoldingDone, con2tag_TickType FoldrInline)
232 -- [ i := 0 | i <- indices zeroSimplCount ]
235 Counting-related monad functions:
237 tick :: TickType -> SmplM ()
239 tick tick_type us (SimplCount n stuff)
240 = ((), SimplCount (n _ADD_ ILIT(1))
241 #ifdef OMIT_SIMPL_COUNTS
242 stuff -- don't change anything
248 inc_tick [] = panic "couldn't inc_tick!"
249 inc_tick (x@(ttype, cnt) : xs)
250 = if ttype == tick_type then
258 tickN :: TickType -> Int -> SmplM ()
260 tickN tick_type IBOX(increment) us (SimplCount n stuff)
261 = ((), SimplCount (n _ADD_ increment)
262 #ifdef OMIT_SIMPL_COUNTS
263 stuff -- don't change anything
269 inc_tick [] = panic "couldn't inc_tick!"
270 inc_tick (x@(ttype, cnt) : xs)
271 = if ttype == tick_type then
273 incd = cnt + IBOX(increment)
279 simplCount :: SmplM Int
280 simplCount us sc@(SimplCount n _) = (IBOX(n), sc)
282 detailedSimplCount :: SmplM SimplCount
283 detailedSimplCount us sc = (sc, sc)
285 combineSimplCounts :: SimplCount -> SimplCount -> SimplCount
287 #ifdef OMIT_SIMPL_COUNTS
288 combineSimplCounts (SimplCount n1 stuff1) (SimplCount n2 stuff2)
289 = SimplCount (n1 _ADD_ n2)
290 stuff1 -- just pick one
292 combineSimplCounts (SimplCount n1 stuff1) (SimplCount n2 stuff2)
293 = SimplCount (n1 _ADD_ n2)
294 (zipWithEqual "combineSimplCounts" (\ (t1,c1) (t2,c2) -> (t1,c1+c2)) stuff1 stuff2)
298 %************************************************************************
300 \subsection{Monad primitives}
302 %************************************************************************
305 newId :: Type -> SmplM Id
307 = (mkSysLocal SLIT("s") uniq ty mkUnknownSrcLoc, sc)
311 newIds :: [Type] -> SmplM [Id]
313 = (zipWithEqual "newIds" mk_id tys uniqs, sc)
315 uniqs = getUniques (length tys) us
316 mk_id ty uniq = mkSysLocal SLIT("s") uniq ty mkUnknownSrcLoc
318 cloneTyVarSmpl :: TyVar -> SmplM TyVar
320 cloneTyVarSmpl tyvar us sc
324 new_tyvar = cloneTyVar tyvar uniq
326 cloneId :: SimplEnv -> InBinder -> SmplM OutId
327 cloneId env (id,_) us sc
328 = (mkIdWithNewUniq id_with_new_ty uniq, sc)
330 id_with_new_ty = simplTyInId env id
333 cloneIds :: SimplEnv -> [InBinder] -> SmplM [OutId]
334 cloneIds env binders = mapSmpl (cloneId env) binders