X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplMonad.lhs;h=4265efb3f070d9fd41e642aeb4c8dce91faa9d06;hb=ec576735c81107dc2947abfd6c9a74b3d0103c4b;hp=1cdbde62c4d5b5e3f2b9d1307f5e106e3e05b6ce;hpb=206b4dec78250efef3cd927d64dc6cbc54a16c3d;p=ghc-hetmet.git

diff --git a/compiler/simplCore/SimplMonad.lhs b/compiler/simplCore/SimplMonad.lhs
index 1cdbde6..4265efb 100644
--- a/compiler/simplCore/SimplMonad.lhs
+++ b/compiler/simplCore/SimplMonad.lhs
@@ -14,12 +14,11 @@
 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(..),
@@ -32,28 +31,22 @@ module SimplMonad (
 	isAmongSimpl, intSwitchSet, switchIsOn
     ) where
 
-#include "HsVersions.h"
-
 import Id		( Id, mkSysLocal )
 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}
 
 %************************************************************************
@@ -114,30 +107,11 @@ thenSmpl_ m k
   = 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}
 
 
@@ -148,20 +122,18 @@ mapAccumLSmpl f acc (x:xs) = f acc x	`thenSmpl` \ (acc', x') ->
 %************************************************************************
 
 \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))
@@ -173,8 +145,8 @@ getFamEnvs :: SimplM (FamInstEnv, FamInstEnv)
 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}
 
 
@@ -280,15 +252,15 @@ plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 })
 plusSimplCount VerySimplZero VerySimplZero = VerySimplZero
 plusSimplCount sc1	     sc2	   = VerySimplNonZero
 
-pprSimplCount VerySimplZero    = ptext SLIT("Total ticks: ZERO!")
-pprSimplCount VerySimplNonZero = ptext SLIT("Total ticks: NON-ZERO!")
+pprSimplCount VerySimplZero    = ptext (sLit "Total ticks: ZERO!")
+pprSimplCount VerySimplNonZero = ptext (sLit "Total ticks: NON-ZERO!")
 pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 })
-  = vcat [ptext SLIT("Total ticks:    ") <+> int tks,
+  = vcat [ptext (sLit "Total ticks:    ") <+> int tks,
 	  text "",
 	  pprTickCounts (fmToList dts),
 	  if verboseSimplStats then
 		vcat [text "",
-		      ptext SLIT("Log (most recent first)"),
+		      ptext (sLit "Log (most recent first)"),
 		      nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))]
 	  else empty
     ]