[make SM monad for simplification
John Meacham <john@repetae.net>**20061129020641] hunk ./E/SSimplify.hs 11
+import Control.Monad.RWS
hunk ./E/SSimplify.hs 18
-import List hiding(delete,union)
+import List hiding(delete,union,insert)
hunk ./E/SSimplify.hs 434
-type SM m = IdNameT m
hunk ./E/SSimplify.hs 435
+
hunk ./E/SSimplify.hs 440
-        (dsOut,_) <- (runIdNameT doit)
+        let ((dsOut,_),stats) = runSM initialB doit
+        mtickStat stats
hunk ./E/SSimplify.hs 450
-        addNamesIdSet (progUsedIds prog)
-        addBoundNamesIdSet (progFreeIds prog)
-        addBoundNamesIdMap (so_boundVars sopts)
+        smAddNamesIdSet (progUsedIds prog)
+        smAddBoundNamesIdSet (progFreeIds prog)
+        smAddBoundNamesIdMap (so_boundVars sopts)
hunk ./E/SSimplify.hs 454
-    go :: E -> Env -> SM m E
+    go :: E -> Env -> SM E
hunk ./E/SSimplify.hs 458
-    f :: InE -> Env -> SM m OutE
+    f :: InE -> Env -> SM OutE
hunk ./E/SSimplify.hs 550
-    doCase :: OutE -> InE -> InTVr -> [Alt InE] -> (Maybe InE) -> Env -> SM m OutE
+    doCase :: OutE -> InE -> InTVr -> [Alt InE] -> (Maybe InE) -> Env -> SM OutE
hunk ./E/SSimplify.hs 675
-    doConstCase :: {- Out -} Lit E E -> InE -> InTVr -> [Alt E] -> Maybe InE -> Env -> SM m OutE
+    doConstCase :: {- Out -} Lit E E -> InE -> InTVr -> [Alt E] -> Maybe InE -> Env -> SM OutE
hunk ./E/SSimplify.hs 706
-    applyRule :: OutTVr -> [OutE] -> Env -> SM m (Maybe (OutE,[OutE]))
+    applyRule :: OutTVr -> [OutE] -> Env -> SM (Maybe (OutE,[OutE]))
hunk ./E/SSimplify.hs 715
-    h :: OutE -> [OutE] -> Env -> SM m OutE
+    h :: OutE -> [OutE] -> Env -> SM OutE
hunk ./E/SSimplify.hs 754
-    didInline :: Env -> OutE -> [OutE] -> SM m OutE
+    didInline :: Env -> OutE -> [OutE] -> SM OutE
hunk ./E/SSimplify.hs 756
-        used <- idNameUsedNames
+        used <- smUsedNames
hunk ./E/SSimplify.hs 758
-        addNamesIdSet nn
+        smAddNamesIdSet nn
hunk ./E/SSimplify.hs 798
-        let z :: (InTVr,InE) -> SM m (Id,UseInfo,OutTVr,InE)
+        let z :: (InTVr,InE) -> SM (Id,UseInfo,OutTVr,InE)
hunk ./E/SSimplify.hs 812
-            w :: [(Id,UseInfo,OutTVr,InE)] -> Env -> [(OutTVr,OutE)] -> SM m ([(OutTVr,OutE)],Env)
+            w :: [(Id,UseInfo,OutTVr,InE)] -> Env -> [(OutTVr,OutE)] -> SM ([(OutTVr,OutE)],Env)
hunk ./E/SSimplify.hs 950
+
+-----------------------
+-- simplification Monad
+-----------------------
+
+data SmState = SmState {
+    idsUsed :: !IdSet,
+    idsBound :: !IdSet
+    }
+
+smState = SmState { idsUsed = mempty, idsBound = mempty }
+
+newtype SM a = SM (RWS Env Stats.Stat SmState a)
+    deriving(Monad,Functor,MonadReader Env)
+
+localEnv f (SM action) = SM $ local (cacheSubst . f) action
+
+
+runSM :: Env -> SM a -> (a,Stat)
+runSM env (SM x) = (r,s) where
+    (r,_,s) = runRWS x (cacheSubst env) smState
+
+instance MonadStats SM where
+   mticks' n k = SM $ tell (Stats.singleStat n k) >> return ()
+
+modifyIds fn = SM $ modify f where
+    f s@SmState { idsUsed = used, idsBound = bound } = case fn (used,bound) of (used',bound') -> s { idsUsed = used', idsBound = bound' }
+getIds = SM $ liftM f get where
+    f s@SmState { idsUsed = used, idsBound = bound } = (used,bound)
+putIds x = SM $ modify (f x) where
+    f (used,bound) = \s -> s { idsUsed = used, idsBound = bound }
+
+instance NameMonad Id SM where
+    addNames ns = do
+        modifyIds (\ (used,bound) -> (fromList ns `union` used, bound) )
+    addBoundNames ns = do
+        let nset = fromList ns
+        modifyIds (\ (used,bound) -> (nset `union` used, nset `union` bound) )
+    uniqueName n = do
+        (used,bound) <- getIds
+        if n `member` bound then newName else putIds (insert n used,insert n bound) >> return n
+    newNameFrom vs = do
+        (used,bound) <- getIds
+        let f (x:xs)
+                | x `member` used = f xs
+                | otherwise = x
+            f [] = error "newNameFrom: finite list!"
+            nn = f vs
+        putIds (insert nn used, insert nn bound)
+        return nn
+    newName  = do
+        (used,bound) <- getIds
+        let genNames i = [st, st + 2 ..]  where
+                st = abs i + 2 + abs i `mod` 2
+        newNameFrom  (genNames (size used + size bound))
+
+
+smUsedNames = SM $ gets idsUsed
+smBoundNames = SM $ gets idsBound
+
+
+
+smAddNamesIdSet nset = do modifyIds (\ (used,bound) -> (nset `union` used, bound) )
+smAddBoundNamesIdSet nset = do modifyIds (\ (used,bound) -> (nset `union` used, nset `union` bound) )
+
+smAddBoundNamesIdMap nmap = do
+    modifyIds (\ (used,bound) -> (nset `union` used, nset `union` bound) ) where
+        nset = idMapToIdSet nmap
+
+