module SimplMonad (
-- The monad
SimplM,
- initSmpl, returnSmpl, thenSmpl, thenSmpl_,
- mapSmpl, mapAndUnzipSmpl, mapAccumLSmpl,
+ initSmpl,
getDOptsSmpl, getRules, getFamEnvs,
-- Unique supply
- getUniqueSmpl, getUniquesSmpl, getUniqSupplySmpl, newId,
+ MonadUnique(..), newId,
-- Counting
SimplCount, Tick(..),
import Type ( Type )
import FamInstEnv ( FamInstEnv )
import Rules ( RuleBase )
-import UniqSupply ( uniqsFromSupply, uniqFromSupply, splitUniqSupply,
- UniqSupply
- )
+import UniqSupply
import DynFlags ( SimplifierSwitch(..), DynFlags, DynFlag(..), dopt )
import StaticFlags ( opt_PprStyle_Debug, opt_HistorySize )
import Unique ( Unique )
import Maybes ( expectJust )
import FiniteMap ( FiniteMap, emptyFM, isEmptyFM, lookupFM, addToFM, plusFM_C, fmToList )
-import FastString ( FastString )
+import FastString
import Outputable
import FastTypes
import Data.Array
import Data.Array.Base (unsafeAt)
-
-infixr 0 `thenSmpl`, `thenSmpl_`
\end{code}
%************************************************************************
= SM (\st_env us0 sc0 ->
case (unSM m st_env us0 sc0) of
(_, us1, sc1) -> unSM k st_env us1 sc1)
-\end{code}
-
-\begin{code}
-mapSmpl :: (a -> SimplM b) -> [a] -> SimplM [b]
-mapAndUnzipSmpl :: (a -> SimplM (b, c)) -> [a] -> SimplM ([b],[c])
-
-mapSmpl f [] = returnSmpl []
-mapSmpl f (x:xs)
- = f x `thenSmpl` \ x' ->
- mapSmpl f xs `thenSmpl` \ xs' ->
- returnSmpl (x':xs')
-
-mapAndUnzipSmpl f [] = returnSmpl ([],[])
-mapAndUnzipSmpl f (x:xs)
- = f x `thenSmpl` \ (r1, r2) ->
- mapAndUnzipSmpl f xs `thenSmpl` \ (rs1, rs2) ->
- returnSmpl (r1:rs1, r2:rs2)
-
-mapAccumLSmpl :: (acc -> b -> SimplM (acc,c)) -> acc -> [b] -> SimplM (acc, [c])
-mapAccumLSmpl f acc [] = returnSmpl (acc, [])
-mapAccumLSmpl f acc (x:xs) = f acc x `thenSmpl` \ (acc', x') ->
- mapAccumLSmpl f acc' xs `thenSmpl` \ (acc'', xs') ->
- returnSmpl (acc'', x':xs')
+-- 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}
%************************************************************************
\begin{code}
-getUniqSupplySmpl :: SimplM UniqSupply
-getUniqSupplySmpl
- = SM (\st_env us sc -> case splitUniqSupply us of
- (us1, us2) -> (us1, us2, sc))
+instance MonadUnique SimplM where
+ getUniqueSupplyM
+ = SM (\st_env us sc -> case splitUniqSupply us of
+ (us1, us2) -> (us1, us2, sc))
-getUniqueSmpl :: SimplM Unique
-getUniqueSmpl
- = SM (\st_env us sc -> case splitUniqSupply us of
- (us1, us2) -> (uniqFromSupply us1, us2, sc))
+ getUniqueM
+ = SM (\st_env us sc -> case splitUniqSupply us of
+ (us1, us2) -> (uniqFromSupply us1, us2, sc))
-getUniquesSmpl :: SimplM [Unique]
-getUniquesSmpl
- = SM (\st_env us sc -> case splitUniqSupply us of
- (us1, us2) -> (uniqsFromSupply 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))
getFamEnvs = SM (\st_env us sc -> (st_fams st_env, us, sc))
newId :: FastString -> Type -> SimplM Id
-newId fs ty = getUniqueSmpl `thenSmpl` \ uniq ->
- returnSmpl (mkSysLocal fs uniq ty)
+newId fs ty = do uniq <- getUniqueM
+ return (mkSysLocal fs uniq ty)
\end{code}