[project @ 1996-01-08 20:28:12 by partain]
[ghc.git] / ghc / compiler / simplCore / SimplMonad.lhs
1 %
2 % (c) The AQUA Project, Glasgow University, 1993-1995
3 %
4 \section[SimplMonad]{The simplifier Monad}
5
6 \begin{code}
7 #include "HsVersions.h"
8
9 module SimplMonad (
10         SmplM(..),
11         initSmpl, returnSmpl, thenSmpl, thenSmpl_,
12         mapSmpl, mapAndUnzipSmpl,
13         
14         -- Counting
15         SimplCount{-abstract-}, TickType(..), tick, tickN,
16         simplCount, detailedSimplCount,
17         zeroSimplCount, showSimplCount, combineSimplCounts,
18
19         -- Cloning
20         cloneId, cloneIds, cloneTyVarSmpl, newIds, newId,
21
22         -- and to make the interface self-sufficient...
23         BinderInfo, CoreExpr, Id, PrimOp, TyVar, UniType,
24         SplitUniqSupply
25
26         IF_ATTACK_PRAGMAS(COMMA splitUniqSupply)
27     ) where
28
29 IMPORT_Trace            -- ToDo: rm (debugging)
30
31 import TaggedCore
32 import PlainCore
33
34 import AbsUniType       ( cloneTyVar )
35 import CmdLineOpts
36 import Id               ( mkIdWithNewUniq, mkSysLocal )
37 import IdInfo
38 import SimplEnv
39 import SrcLoc           ( mkUnknownSrcLoc, SrcLoc )
40 import SplitUniq
41 import Unique
42 import Util
43
44 infixr 9  `thenSmpl`, `thenSmpl_`
45 \end{code}
46
47 %************************************************************************
48 %*                                                                      *
49 \subsection[Monad]{Monad plumbing}
50 %*                                                                      *
51 %************************************************************************
52
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.)
55
56 \begin{code}
57 type SmplM result
58   = SplitUniqSupply
59   -> SimplCount    -- things being threaded
60   -> (result, SimplCount)
61 \end{code}
62
63 \begin{code}
64 initSmpl :: SplitUniqSupply -- no init count; set to 0
65           -> SmplM a
66           -> (a, SimplCount)
67
68 initSmpl us m = m us zeroSimplCount
69
70 #ifdef __GLASGOW_HASKELL__
71 {-# INLINE thenSmpl #-}
72 {-# INLINE thenSmpl_ #-}
73 {-# INLINE returnSmpl #-}
74 #endif
75
76 returnSmpl :: a -> SmplM a
77 returnSmpl e us sc = (e, sc)
78
79 thenSmpl  :: SmplM a -> (a -> SmplM b) -> SmplM b
80 thenSmpl_ :: SmplM a -> SmplM b -> SmplM b
81
82 thenSmpl m k us sc0
83   = case splitUniqSupply us of { (s1, s2) ->
84     case (m s1 sc0)         of { (m_result, sc1) ->
85     k m_result s2 sc1 }}
86
87 thenSmpl_ m k us sc0
88   = case splitUniqSupply us of { (s1, s2) ->
89     case (m s1 sc0)         of { (_, sc1) ->
90     k s2 sc1 }}
91
92 mapSmpl         :: (a -> SmplM b) -> [a] -> SmplM [b]
93 mapAndUnzipSmpl :: (a -> SmplM (b, c)) -> [a] -> SmplM ([b],[c])
94
95 mapSmpl f [] = returnSmpl []
96 mapSmpl f (x:xs)
97   = f x             `thenSmpl` \ x'  ->
98     mapSmpl f xs    `thenSmpl` \ xs' ->
99     returnSmpl (x':xs')
100
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)
106 \end{code}
107
108
109 %************************************************************************
110 %*                                                                      *
111 \subsection[SimplCount]{Counting up what we've done}
112 %*                                                                      *
113 %************************************************************************
114
115 The assoc list isn't particularly costly, because we only use
116 the number of ticks in ``real life.''
117
118 The right thing to do, if you want that to go fast, is thread
119 a mutable array through @SimplM@.
120
121 \begin{code}
122 data SimplCount
123   = SimplCount  FAST_INT            -- number of ticks
124                 [(TickType, Int)]   -- assoc list of all diff kinds of ticks
125
126 data TickType
127   = UnfoldingDone    {-UNUSED: | Unused -}
128   | FoldrBuild       | MagicUnfold      | ConReused
129   | CaseFloatFromLet | CaseOfCase       {-UNUSED: | CaseFloatFromApp -}
130   | LetFloatFromLet  | LetFloatFromCase {-UNUSED: | LetFloatFromApp -}
131   | KnownBranch      | Let2Case         {-UNUSED: | UnboxingLet2Case -}
132   | CaseMerge        {-UNUSED: | CaseToLet-}    | CaseElim
133   | CaseIdentity
134   | AtomicRhs   -- Rhs of a let-expression was an atom
135   | EtaExpansion     {-UNUSED: | ArityExpand-}
136   {-UNUSED: | ConstantFolding-}  | CaseOfError  {-UNUSED: | InlineRemoved -}
137   | FoldrConsNil
138   | Foldr_Nil
139   | FoldrFoldr
140   | Foldr_List
141   | FoldrCons
142   | FoldrInline
143   | TyBetaReduction
144   | BetaReduction
145   deriving (Eq, Ord, Ix)
146
147 instance Text TickType where
148     showsPrec p UnfoldingDone   = showString "UnfoldingDone    "
149 --UNUSED:    showsPrec p Unused         = showString "Unused           "
150     showsPrec p FoldrBuild      = showString "FoldrBuild       "
151     showsPrec p MagicUnfold     = showString "MagicUnfold      "
152     showsPrec p ConReused       = showString "ConReused        "
153     showsPrec p CaseFloatFromLet= showString "CaseFloatFromLet "
154     showsPrec p CaseOfCase      = showString "CaseOfCase       "
155 --UNUSED:    showsPrec p CaseFloatFromApp= showString "CaseFloatFromApp "
156     showsPrec p LetFloatFromLet = showString "LetFloatFromLet  "
157     showsPrec p LetFloatFromCase= showString "LetFloatFromCase "
158 --UNUSED:    showsPrec p LetFloatFromApp        = showString "LetFloatFromApp  "
159     showsPrec p KnownBranch     = showString "KnownBranch      "
160     showsPrec p Let2Case        = showString "Let2Case         "
161 --UNUSED:    showsPrec p UnboxingLet2Case= showString "UnboxingLet2Case "
162     showsPrec p CaseMerge       = showString "CaseMerge        "
163 --UNUSED:    showsPrec p CaseToLet      = showString "CaseToLet        "
164     showsPrec p CaseElim        = showString "CaseElim         "
165     showsPrec p CaseIdentity    = showString "CaseIdentity     "
166     showsPrec p AtomicRhs       = showString "AtomicRhs        "
167     showsPrec p EtaExpansion    = showString "EtaExpansion     "
168 --UNUSED:    showsPrec p ArityExpand    = showString "ArityExpand      "
169 --UNUSED:    showsPrec p ConstantFolding        = showString "ConstantFolding  "
170     showsPrec p CaseOfError     = showString "CaseOfError      "
171 --UNUSED:    showsPrec p InlineRemoved  = showString "InlineRemoved    "
172     showsPrec p FoldrConsNil    = showString "FoldrConsNil     "
173     showsPrec p Foldr_Nil       = showString "Foldr_Nil        "
174     showsPrec p FoldrFoldr      = showString "FoldrFoldr       "
175     showsPrec p Foldr_List      = showString "Foldr_List       "
176     showsPrec p FoldrCons       = showString "FoldrCons        "
177     showsPrec p FoldrInline     = showString "FoldrInline      "
178     showsPrec p TyBetaReduction = showString "TyBetaReduction  "
179     showsPrec p BetaReduction   = showString "BetaReduction    "
180
181 showSimplCount :: SimplCount -> String
182
183 showSimplCount (SimplCount _ stuff)
184   = shw stuff
185   where
186     shw []          = ""
187     shw ((t,n):tns) | n /= 0    = show t ++ ('\t' : show n) ++ ('\n' : shw tns)
188                     | otherwise = shw tns
189
190 zeroSimplCount :: SimplCount
191 zeroSimplCount
192   = SimplCount ILIT(0)
193         [(UnfoldingDone, 0),
194 --UNUSED:        (Unused, 0),
195          (FoldrBuild, 0),
196          (MagicUnfold, 0),
197          (ConReused, 0),
198          (CaseFloatFromLet, 0),
199          (CaseOfCase, 0),
200 --UNUSED:        (CaseFloatFromApp, 0),
201          (LetFloatFromLet, 0),
202          (LetFloatFromCase, 0),
203 --UNUSED:        (LetFloatFromApp, 0),
204          (KnownBranch, 0),
205          (Let2Case, 0),
206 --UNUSED:        (UnboxingLet2Case, 0),
207          (CaseMerge, 0),
208 --UNUSED:        (CaseToLet, 0),
209          (CaseElim, 0),
210          (CaseIdentity, 0),
211          (AtomicRhs, 0),
212          (EtaExpansion, 0),
213 --UNUSED:        (ArityExpand,0),
214 --UNUSED:        (ConstantFolding, 0),
215          (CaseOfError, 0),
216 --UNUSED:        (InlineRemoved,0),
217          (FoldrConsNil,0),
218          (Foldr_Nil,0),
219          (FoldrFoldr,0),
220          (Foldr_List,0),
221          (FoldrCons,0),
222          (FoldrInline,0),
223          (TyBetaReduction,0),
224          (BetaReduction,0) ]
225 --
226 --= array (con2tag_TickType UnfoldingDone, con2tag_TickType FoldrInline) 
227 --        [ i := 0 | i <- indices zeroSimplCount ]
228 \end{code}
229
230 Counting-related monad functions:
231 \begin{code}
232 tick :: TickType -> SmplM ()
233
234 tick tick_type us (SimplCount n stuff)
235   = ((), SimplCount (n _ADD_ ILIT(1))
236 #ifdef OMIT_SIMPL_COUNTS
237                     stuff -- don't change anything
238 #else
239                     (inc_tick stuff)
240 #endif
241     )
242   where
243     inc_tick [] = panic "couldn't inc_tick!"
244     inc_tick (x@(ttype, cnt) : xs)
245       = if ttype == tick_type then
246             let
247                 incd = cnt + 1
248             in
249             (ttype, incd) : xs
250         else
251             x : inc_tick xs
252
253 tickN :: TickType -> Int -> SmplM ()
254
255 tickN tick_type IBOX(increment) us (SimplCount n stuff)
256   = ((), SimplCount (n _ADD_ increment)
257 #ifdef OMIT_SIMPL_COUNTS
258                     stuff -- don't change anything
259 #else
260                     (inc_tick stuff)
261 #endif
262     )
263   where
264     inc_tick [] = panic "couldn't inc_tick!"
265     inc_tick (x@(ttype, cnt) : xs)
266       = if ttype == tick_type then
267             let
268                 incd = cnt + IBOX(increment)
269             in
270             (ttype, incd) : xs
271         else
272             x : inc_tick xs
273
274 simplCount :: SmplM Int
275 simplCount us sc@(SimplCount n _) = (IBOX(n), sc)
276
277 detailedSimplCount :: SmplM SimplCount
278 detailedSimplCount us sc = (sc, sc)
279
280 combineSimplCounts :: SimplCount -> SimplCount -> SimplCount
281
282 #ifdef OMIT_SIMPL_COUNTS
283 combineSimplCounts (SimplCount n1 stuff1) (SimplCount n2 stuff2)
284   = SimplCount (n1 _ADD_ n2)
285                stuff1 -- just pick one
286 #else
287 combineSimplCounts (SimplCount n1 stuff1) (SimplCount n2 stuff2)
288   = SimplCount (n1 _ADD_ n2)
289                (zipWith (\ (t1,c1) (t2,c2) -> (t1,c1+c2)) stuff1 stuff2)
290 #endif
291 \end{code}
292
293 %************************************************************************
294 %*                                                                      *
295 \subsection{Monad primitives}
296 %*                                                                      *
297 %************************************************************************
298
299 \begin{code}
300 newId :: UniType -> SmplM Id
301 newId ty us sc
302   = (mkSysLocal SLIT("s") uniq ty mkUnknownSrcLoc, sc)
303   where
304     uniq = getSUnique us
305
306 newIds :: [UniType] -> SmplM [Id]
307 newIds tys us sc
308   = (zipWith mk_id tys uniqs, sc)
309   where
310     uniqs  = getSUniques (length tys) us
311     mk_id ty uniq = mkSysLocal SLIT("s") uniq ty mkUnknownSrcLoc
312
313 cloneTyVarSmpl :: TyVar -> SmplM TyVar
314
315 cloneTyVarSmpl tyvar us sc
316   = (new_tyvar, sc)
317   where
318    uniq = getSUnique us
319    new_tyvar = cloneTyVar tyvar uniq
320
321 cloneId :: SimplEnv -> InBinder -> SmplM OutId
322 cloneId env (id,_) us sc
323   = (mkIdWithNewUniq id_with_new_ty uniq, sc)
324   where
325     id_with_new_ty = simplTyInId env id
326     uniq = getSUnique us
327
328 cloneIds :: SimplEnv -> [InBinder] -> SmplM [OutId]
329 cloneIds env binders = mapSmpl (cloneId env) binders
330 \end{code}