1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
|
%
% (c) The AQUA Project, Glasgow University, 1993-1998
%
\section[SimplMonad]{The simplifier Monad}
\begin{code}
module SimplMonad (
-- The monad
SimplM,
initSmpl,
getDOptsSmpl, getSimplRules, getFamEnvs,
-- Unique supply
MonadUnique(..), newId,
-- Counting
SimplCount, tick, freeTick,
getSimplCount, zeroSimplCount, pprSimplCount,
plusSimplCount, isZeroSimplCount
) where
import Id ( Id, mkSysLocal )
import Type ( Type )
import FamInstEnv ( FamInstEnv )
import Rules ( RuleBase )
import UniqSupply
import DynFlags ( DynFlags )
import CoreMonad
import FastString
\end{code}
%************************************************************************
%* *
\subsection{Monad plumbing}
%* *
%************************************************************************
For the simplifier monad, we want to {\em thread} a unique supply and a counter.
(Command-line switches move around through the explicitly-passed SimplEnv.)
\begin{code}
newtype SimplM result
= SM { unSM :: SimplTopEnv -- Envt that does not change much
-> UniqSupply -- We thread the unique supply because
-- constantly splitting it is rather expensive
-> SimplCount
-> (result, UniqSupply, SimplCount)}
data SimplTopEnv = STE { st_flags :: DynFlags
, st_rules :: RuleBase
, st_fams :: (FamInstEnv, FamInstEnv) }
\end{code}
\begin{code}
initSmpl :: DynFlags -> RuleBase -> (FamInstEnv, FamInstEnv)
-> UniqSupply -- No init count; set to 0
-> SimplM a
-> (a, SimplCount)
initSmpl dflags rules fam_envs us m
= case unSM m env us (zeroSimplCount dflags) of
(result, _, count) -> (result, count)
where
env = STE { st_flags = dflags, st_rules = rules, st_fams = fam_envs }
{-# INLINE thenSmpl #-}
{-# INLINE thenSmpl_ #-}
{-# INLINE returnSmpl #-}
instance Monad SimplM where
(>>) = thenSmpl_
(>>=) = thenSmpl
return = returnSmpl
returnSmpl :: a -> SimplM a
returnSmpl e = SM (\_st_env us sc -> (e, us, sc))
thenSmpl :: SimplM a -> (a -> SimplM b) -> SimplM b
thenSmpl_ :: SimplM a -> SimplM b -> SimplM b
thenSmpl m k
= SM (\ st_env us0 sc0 ->
case (unSM m st_env us0 sc0) of
(m_result, us1, sc1) -> unSM (k m_result) st_env us1 sc1 )
thenSmpl_ m k
= SM (\st_env us0 sc0 ->
case (unSM m st_env us0 sc0) of
(_, us1, sc1) -> unSM k st_env us1 sc1)
-- TODO: this specializing is not allowed
-- {-# SPECIALIZE mapM :: (a -> SimplM b) -> [a] -> SimplM [b] #-}
-- {-# SPECIALIZE mapAndUnzipM :: (a -> SimplM (b, c)) -> [a] -> SimplM ([b],[c]) #-}
-- {-# SPECIALIZE mapAccumLM :: (acc -> b -> SimplM (acc,c)) -> acc -> [b] -> SimplM (acc, [c]) #-}
\end{code}
%************************************************************************
%* *
\subsection{The unique supply}
%* *
%************************************************************************
\begin{code}
instance MonadUnique SimplM where
getUniqueSupplyM
= SM (\_st_env us sc -> case splitUniqSupply us of
(us1, us2) -> (us1, us2, sc))
getUniqueM
= SM (\_st_env us sc -> case splitUniqSupply us of
(us1, us2) -> (uniqFromSupply us1, us2, sc))
getUniquesM
= SM (\_st_env us sc -> case splitUniqSupply us of
(us1, us2) -> (uniqsFromSupply us1, us2, sc))
getDOptsSmpl :: SimplM DynFlags
getDOptsSmpl = SM (\st_env us sc -> (st_flags st_env, us, sc))
getSimplRules :: SimplM RuleBase
getSimplRules = SM (\st_env us sc -> (st_rules st_env, us, sc))
getFamEnvs :: SimplM (FamInstEnv, FamInstEnv)
getFamEnvs = SM (\st_env us sc -> (st_fams st_env, us, sc))
newId :: FastString -> Type -> SimplM Id
newId fs ty = do uniq <- getUniqueM
return (mkSysLocal fs uniq ty)
\end{code}
%************************************************************************
%* *
\subsection{Counting up what we've done}
%* *
%************************************************************************
\begin{code}
getSimplCount :: SimplM SimplCount
getSimplCount = SM (\_st_env us sc -> (sc, us, sc))
tick :: Tick -> SimplM ()
tick t
= SM (\_st_env us sc -> let sc' = doSimplTick t sc
in sc' `seq` ((), us, sc'))
freeTick :: Tick -> SimplM ()
-- Record a tick, but don't add to the total tick count, which is
-- used to decide when nothing further has happened
freeTick t
= SM (\_st_env us sc -> let sc' = doFreeSimplTick t sc
in sc' `seq` ((), us, sc'))
\end{code}
|
