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
22 -- and to make the interface self-sufficient...
27 import SmplLoop -- well, cheating sort of
29 import Id ( mkSysLocal, mkIdWithNewUniq )
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
130 {- BEGIN F/B ENTRIES -}
132 | FoldrBuild -- foldr f z (build g) ==>
133 | FoldrAugment -- foldr f z (augment g z) ==>
134 | Foldr_Nil -- foldr f z [] ==>
135 | Foldr_List -- foldr f z (x:...) ==>
137 | FoldlBuild -- foldl f z (build g) ==>
138 | FoldlAugment -- foldl f z (augment g z) ==>
139 | Foldl_Nil -- foldl f z [] ==>
140 | Foldl_List -- foldl f z (x:...) ==>
142 | Foldr_Cons_Nil -- foldr (:) [] => id
143 | Foldr_Cons -- foldr (:) => flip (++)
145 | Str_FoldrStr -- foldr f z "hello" => unpackFoldrPS# f z "hello"
146 | Str_UnpackCons -- unpackFoldrPS# (:) z "hello" => unpackAppendPS# z "hello"
147 | Str_UnpackNil -- unpackAppendPS# [] "hello" => "hello"
148 {- END F/B ENTRIES -}
149 deriving (Eq, Ord, Ix)
151 instance Text TickType where
152 showsPrec p UnfoldingDone = showString "UnfoldingDone "
153 showsPrec p MagicUnfold = showString "MagicUnfold "
154 showsPrec p ConReused = showString "ConReused "
155 showsPrec p CaseFloatFromLet= showString "CaseFloatFromLet "
156 showsPrec p CaseOfCase = showString "CaseOfCase "
157 showsPrec p LetFloatFromLet = showString "LetFloatFromLet "
158 showsPrec p LetFloatFromCase= showString "LetFloatFromCase "
159 showsPrec p KnownBranch = showString "KnownBranch "
160 showsPrec p Let2Case = showString "Let2Case "
161 showsPrec p CaseMerge = showString "CaseMerge "
162 showsPrec p CaseElim = showString "CaseElim "
163 showsPrec p CaseIdentity = showString "CaseIdentity "
164 showsPrec p AtomicRhs = showString "AtomicRhs "
165 showsPrec p EtaExpansion = showString "EtaExpansion "
166 showsPrec p CaseOfError = showString "CaseOfError "
167 showsPrec p TyBetaReduction = showString "TyBetaReduction "
168 showsPrec p BetaReduction = showString "BetaReduction "
169 -- Foldr/Build Stuff:
170 showsPrec p FoldrBuild = showString "FoldrBuild "
171 showsPrec p FoldrAugment = showString "FoldrAugment "
172 showsPrec p Foldr_Nil = showString "Foldr_Nil "
173 showsPrec p Foldr_List = showString "Foldr_List "
175 showsPrec p FoldlBuild = showString "FoldlBuild "
176 showsPrec p FoldlAugment = showString "FoldlAugment "
177 showsPrec p Foldl_Nil = showString "Foldl_Nil "
178 showsPrec p Foldl_List = showString "Foldl_List "
180 showsPrec p Foldr_Cons_Nil = showString "Foldr_Cons_Nil "
181 showsPrec p Foldr_Cons = showString "Foldr_Cons "
183 showsPrec p Str_FoldrStr = showString "Str_FoldrStr "
184 showsPrec p Str_UnpackCons = showString "Str_UnpackCons "
185 showsPrec p Str_UnpackNil = showString "Str_UnpackNil "
187 showSimplCount :: SimplCount -> String
189 showSimplCount (SimplCount _ stuff)
193 shw ((t,n):tns) | n /= 0 = show t ++ ('\t' : show n) ++ ('\n' : shw tns)
194 | otherwise = shw tns
196 zeroSimplCount :: SimplCount
199 [ (UnfoldingDone, 0),
202 (CaseFloatFromLet, 0),
204 (LetFloatFromLet, 0),
205 (LetFloatFromCase, 0),
216 -- Foldr/Build Stuff:
232 --= array (con2tag_TickType UnfoldingDone, con2tag_TickType FoldrInline)
233 -- [ i := 0 | i <- indices zeroSimplCount ]
236 Counting-related monad functions:
238 tick :: TickType -> SmplM ()
240 tick tick_type us (SimplCount n stuff)
241 = ((), SimplCount (n _ADD_ ILIT(1))
242 #ifdef OMIT_SIMPL_COUNTS
243 stuff -- don't change anything
249 inc_tick [] = panic "couldn't inc_tick!"
250 inc_tick (x@(ttype, cnt) : xs)
251 = if ttype == tick_type then
259 tickN :: TickType -> Int -> SmplM ()
261 tickN tick_type IBOX(increment) us (SimplCount n stuff)
262 = ((), SimplCount (n _ADD_ increment)
263 #ifdef OMIT_SIMPL_COUNTS
264 stuff -- don't change anything
270 inc_tick [] = panic "couldn't inc_tick!"
271 inc_tick (x@(ttype, cnt) : xs)
272 = if ttype == tick_type then
274 incd = cnt + IBOX(increment)
280 simplCount :: SmplM Int
281 simplCount us sc@(SimplCount n _) = (IBOX(n), sc)
283 detailedSimplCount :: SmplM SimplCount
284 detailedSimplCount us sc = (sc, sc)
286 combineSimplCounts :: SimplCount -> SimplCount -> SimplCount
288 #ifdef OMIT_SIMPL_COUNTS
289 combineSimplCounts (SimplCount n1 stuff1) (SimplCount n2 stuff2)
290 = SimplCount (n1 _ADD_ n2)
291 stuff1 -- just pick one
293 combineSimplCounts (SimplCount n1 stuff1) (SimplCount n2 stuff2)
294 = SimplCount (n1 _ADD_ n2)
295 (zipWithEqual "combineSimplCounts" (\ (t1,c1) (t2,c2) -> (t1,c1+c2)) stuff1 stuff2)
299 %************************************************************************
301 \subsection{Monad primitives}
303 %************************************************************************
306 newId :: Type -> SmplM Id
308 = (mkSysLocal SLIT("s") uniq ty mkUnknownSrcLoc, sc)
312 newIds :: [Type] -> SmplM [Id]
314 = (zipWithEqual "newIds" mk_id tys uniqs, sc)
316 uniqs = getUniques (length tys) us
317 mk_id ty uniq = mkSysLocal SLIT("s") uniq ty mkUnknownSrcLoc
319 cloneTyVarSmpl :: TyVar -> SmplM TyVar
321 cloneTyVarSmpl tyvar us sc
325 new_tyvar = cloneTyVar tyvar uniq
327 cloneId :: SimplEnv -> InBinder -> SmplM OutId
328 cloneId env (id,_) us sc
329 = (mkIdWithNewUniq id_with_new_ty uniq, sc)
331 id_with_new_ty = simplTyInId env id
334 cloneIds :: SimplEnv -> [InBinder] -> SmplM [OutId]
335 cloneIds env binders = mapSmpl (cloneId env) binders