2 % (c) The AQUA Project, Glasgow University, 1993-1995
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,
22 -- and to make the interface self-sufficient...
23 BinderInfo, CoreExpr, Id, PrimOp, TyVar, UniType,
26 IF_ATTACK_PRAGMAS(COMMA splitUniqSupply)
29 IMPORT_Trace -- ToDo: rm (debugging)
34 import AbsUniType ( cloneTyVar )
36 import Id ( mkIdWithNewUniq, mkSysLocal )
39 import SrcLoc ( mkUnknownSrcLoc, SrcLoc )
44 infixr 9 `thenSmpl`, `thenSmpl_`
47 %************************************************************************
49 \subsection[Monad]{Monad plumbing}
51 %************************************************************************
53 For the simplifier monad, we want to {\em thread} a unique supply and a counter.
54 (Command-line switches move around through the explicitly-passed SimplEnv.)
59 -> SimplCount -- things being threaded
60 -> (result, SimplCount)
64 initSmpl :: SplitUniqSupply -- no init count; set to 0
68 initSmpl us m = m us zeroSimplCount
70 #ifdef __GLASGOW_HASKELL__
71 {-# INLINE thenSmpl #-}
72 {-# INLINE thenSmpl_ #-}
73 {-# 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[SimplCount]{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 = UnfoldingDone | MagicUnfold | ConReused
128 | CaseFloatFromLet | CaseOfCase
129 | LetFloatFromLet | LetFloatFromCase
130 | KnownBranch | Let2Case
131 | CaseMerge | CaseElim
133 | AtomicRhs -- Rhs of a let-expression was an atom
138 {- BEGIN F/B ENTRIES -}
140 | FoldrBuild -- foldr f z (build g) ==>
141 | FoldrAugment -- foldr f z (augment g z) ==>
142 | Foldr_Nil -- foldr f z [] ==>
143 | Foldr_List -- foldr f z (x:...) ==>
145 | FoldlBuild -- foldl f z (build g) ==>
146 | FoldlAugment -- foldl f z (augment g z) ==>
147 | Foldl_Nil -- foldl f z [] ==>
148 | Foldl_List -- foldl f z (x:...) ==>
150 | Foldr_Cons_Nil -- foldr (:) [] => id
151 | Foldr_Cons -- foldr (:) => flip (++)
153 | Str_FoldrStr -- foldr f z "hello" => unpackFoldrPS# f z "hello"
154 | Str_UnpackCons -- unpackFoldrPS# (:) z "hello" => unpackAppendPS# z "hello"
155 | Str_UnpackNil -- unpackAppendPS# [] "hello" => "hello"
156 {- END F/B ENTRIES -}
157 deriving (Eq, Ord, Ix)
159 instance Text TickType where
160 showsPrec p UnfoldingDone = showString "UnfoldingDone "
161 showsPrec p MagicUnfold = showString "MagicUnfold "
162 showsPrec p ConReused = showString "ConReused "
163 showsPrec p CaseFloatFromLet= showString "CaseFloatFromLet "
164 showsPrec p CaseOfCase = showString "CaseOfCase "
165 showsPrec p LetFloatFromLet = showString "LetFloatFromLet "
166 showsPrec p LetFloatFromCase= showString "LetFloatFromCase "
167 showsPrec p KnownBranch = showString "KnownBranch "
168 showsPrec p Let2Case = showString "Let2Case "
169 showsPrec p CaseMerge = showString "CaseMerge "
170 showsPrec p CaseElim = showString "CaseElim "
171 showsPrec p CaseIdentity = showString "CaseIdentity "
172 showsPrec p AtomicRhs = showString "AtomicRhs "
173 showsPrec p EtaExpansion = showString "EtaExpansion "
174 showsPrec p CaseOfError = showString "CaseOfError "
175 showsPrec p TyBetaReduction = showString "TyBetaReduction "
176 showsPrec p BetaReduction = showString "BetaReduction "
177 -- Foldr/Build Stuff:
178 showsPrec p FoldrBuild = showString "FoldrBuild "
179 showsPrec p FoldrAugment = showString "FoldrAugment "
180 showsPrec p Foldr_Nil = showString "Foldr_Nil "
181 showsPrec p Foldr_List = showString "Foldr_List "
183 showsPrec p FoldlBuild = showString "FoldlBuild "
184 showsPrec p FoldlAugment = showString "FoldlAugment "
185 showsPrec p Foldl_Nil = showString "Foldl_Nil "
186 showsPrec p Foldl_List = showString "Foldl_List "
188 showsPrec p Foldr_Cons_Nil = showString "Foldr_Cons_Nil "
189 showsPrec p Foldr_Cons = showString "Foldr_Cons "
191 showsPrec p Str_FoldrStr = showString "Str_FoldrStr "
192 showsPrec p Str_UnpackCons = showString "Str_UnpackCons "
193 showsPrec p Str_UnpackNil = showString "Str_UnpackNil "
195 showSimplCount :: SimplCount -> String
197 showSimplCount (SimplCount _ stuff)
201 shw ((t,n):tns) | n /= 0 = show t ++ ('\t' : show n) ++ ('\n' : shw tns)
202 | otherwise = shw tns
204 zeroSimplCount :: SimplCount
207 [ (UnfoldingDone, 0),
210 (CaseFloatFromLet, 0),
212 (LetFloatFromLet, 0),
213 (LetFloatFromCase, 0),
224 -- Foldr/Build Stuff:
240 --= array (con2tag_TickType UnfoldingDone, con2tag_TickType FoldrInline)
241 -- [ i := 0 | i <- indices zeroSimplCount ]
244 Counting-related monad functions:
246 tick :: TickType -> SmplM ()
248 tick tick_type us (SimplCount n stuff)
249 = ((), SimplCount (n _ADD_ ILIT(1))
250 #ifdef OMIT_SIMPL_COUNTS
251 stuff -- don't change anything
257 inc_tick [] = panic "couldn't inc_tick!"
258 inc_tick (x@(ttype, cnt) : xs)
259 = if ttype == tick_type then
267 tickN :: TickType -> Int -> SmplM ()
269 tickN tick_type IBOX(increment) us (SimplCount n stuff)
270 = ((), SimplCount (n _ADD_ increment)
271 #ifdef OMIT_SIMPL_COUNTS
272 stuff -- don't change anything
278 inc_tick [] = panic "couldn't inc_tick!"
279 inc_tick (x@(ttype, cnt) : xs)
280 = if ttype == tick_type then
282 incd = cnt + IBOX(increment)
288 simplCount :: SmplM Int
289 simplCount us sc@(SimplCount n _) = (IBOX(n), sc)
291 detailedSimplCount :: SmplM SimplCount
292 detailedSimplCount us sc = (sc, sc)
294 combineSimplCounts :: SimplCount -> SimplCount -> SimplCount
296 #ifdef OMIT_SIMPL_COUNTS
297 combineSimplCounts (SimplCount n1 stuff1) (SimplCount n2 stuff2)
298 = SimplCount (n1 _ADD_ n2)
299 stuff1 -- just pick one
301 combineSimplCounts (SimplCount n1 stuff1) (SimplCount n2 stuff2)
302 = SimplCount (n1 _ADD_ n2)
303 (zipWith (\ (t1,c1) (t2,c2) -> (t1,c1+c2)) stuff1 stuff2)
307 %************************************************************************
309 \subsection{Monad primitives}
311 %************************************************************************
314 newId :: UniType -> SmplM Id
316 = (mkSysLocal SLIT("s") uniq ty mkUnknownSrcLoc, sc)
320 newIds :: [UniType] -> SmplM [Id]
322 = (zipWith mk_id tys uniqs, sc)
324 uniqs = getSUniques (length tys) us
325 mk_id ty uniq = mkSysLocal SLIT("s") uniq ty mkUnknownSrcLoc
327 cloneTyVarSmpl :: TyVar -> SmplM TyVar
329 cloneTyVarSmpl tyvar us sc
333 new_tyvar = cloneTyVar tyvar uniq
335 cloneId :: SimplEnv -> InBinder -> SmplM OutId
336 cloneId env (id,_) us sc
337 = (mkIdWithNewUniq id_with_new_ty uniq, sc)
339 id_with_new_ty = simplTyInId env id
342 cloneIds :: SimplEnv -> [InBinder] -> SmplM [OutId]
343 cloneIds env binders = mapSmpl (cloneId env) binders