X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplStg%2FSimplStg.lhs;h=f57744c94d8c0ec1dab4c3a28896bced9bf2f586;hb=e7498a3ee1d0484d02a9e86633cc179c76ebf36e;hp=9b9cbf1f4fd2c4c2598ff9803a0de198abafa7bf;hpb=c49d51f812da9b1c2ceca7e0dad8f2a3626041a9;p=ghc-hetmet.git

diff --git a/ghc/compiler/simplStg/SimplStg.lhs b/ghc/compiler/simplStg/SimplStg.lhs
index 9b9cbf1..f57744c 100644
--- a/ghc/compiler/simplStg/SimplStg.lhs
+++ b/ghc/compiler/simplStg/SimplStg.lhs
@@ -8,7 +8,7 @@
 
 module SimplStg ( stg2stg ) where
 
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
 
 import StgSyn
 import StgUtils
@@ -31,7 +31,6 @@ import Id		( nullIdEnv, lookupIdEnv, addOneToIdEnv,
 			  growIdEnvList, isNullIdEnv, IdEnv(..),
 			  GenId{-instance Eq/Outputable -}
 			)
-import MainMonad	( writeMn, thenMn_, thenMn, returnMn, MainIO(..) )
 import Maybes		( maybeToBool )
 import Name		( isExported )
 import PprType		( GenType{-instance Outputable-} )
@@ -48,26 +47,25 @@ stg2stg :: [StgToDo]		-- spec of what stg-to-stg passes to do
 	-> PprStyle		-- printing style (for debugging only)
 	-> UniqSupply		-- a name supply
 	-> [StgBinding]		-- input...
-	-> MainIO
+	-> IO
 	    ([StgBinding],	-- output program...
 	     ([CostCentre],	-- local cost-centres that need to be decl'd
 	      [CostCentre]))	-- "extern" cost-centres
 
 stg2stg stg_todos module_name ppr_style us binds
-  = BSCC("Stg2Stg")
-    case (splitUniqSupply us)	of { (us4now, us4later) ->
+  = case (splitUniqSupply us)	of { (us4now, us4later) ->
 
     (if do_verbose_stg2stg then
-	writeMn stderr "VERBOSE STG-TO-STG:\n" `thenMn_`
-	writeMn stderr (ppShow 1000
+	hPutStr stderr "VERBOSE STG-TO-STG:\n" >>
+	hPutStr stderr (ppShow 1000
 	(ppAbove (ppStr ("*** Core2Stg:"))
 		 (ppAboves (map (ppr ppr_style) (setStgVarInfo False binds)))
 	))
-     else returnMn ()) `thenMn_`
+     else return ()) >>
 
 	-- Do the main business!
     foldl_mn do_stg_pass (binds, us4now, ([],[])) stg_todos
-		`thenMn` \ (processed_binds, _, cost_centres) ->
+		>>= \ (processed_binds, _, cost_centres) ->
 	-- Do essential wind-up: part (a) is SatStgRhs
 
 	-- Not optional, because correct arity information is used by
@@ -102,9 +100,8 @@ stg2stg stg_todos module_name ppr_style us binds
 	    then no_ind_binds
 	    else snd (unlocaliseStgBinds unlocal_tag nullIdEnv no_ind_binds)
     in
-    returnMn (setStgVarInfo do_let_no_escapes binds_to_mangle, cost_centres)
+    return (setStgVarInfo do_let_no_escapes binds_to_mangle, cost_centres)
     }}
-    ESCC
   where
     do_let_no_escapes  = opt_StgDoLetNoEscapes
     do_verbose_stg2stg = opt_D_verbose_stg2stg
@@ -131,64 +128,60 @@ stg2stg stg_todos module_name ppr_style us binds
 	case to_do of
 	  StgDoStaticArgs ->
 	     ASSERT(null (fst ccs) && null (snd ccs))
-	     BSCC("StgStaticArgs")
+	     _scc_ "StgStaticArgs"
 	     let
 		 binds3 = doStaticArgs binds us1
 	     in
 	     end_pass us2 "StgStaticArgs" ccs binds3
-	     ESCC
 
 	  StgDoUpdateAnalysis ->
 	     ASSERT(null (fst ccs) && null (snd ccs))
-	     BSCC("StgUpdAnal")
+	     _scc_ "StgUpdAnal"
 		-- NB We have to do setStgVarInfo first!  (There's one
 		-- place free-var info is used) But no let-no-escapes,
 		-- because update analysis doesn't care.
 	     end_pass us2 "UpdAnal" ccs (updateAnalyse (setStgVarInfo False binds))
-	     ESCC
 
 	  D_stg_stats ->
 	     trace (showStgStats binds)
 	     end_pass us2 "StgStats" ccs binds
 
 	  StgDoLambdaLift ->
-	     BSCC("StgLambdaLift")
+	     _scc_ "StgLambdaLift"
 		-- NB We have to do setStgVarInfo first!
 	     let
 		binds3 = liftProgram us1 (setStgVarInfo do_let_no_escapes binds)
 	     in
 	     end_pass us2 "LambdaLift" ccs binds3
-	     ESCC
 
 	  StgDoMassageForProfiling ->
-	     BSCC("ProfMassage")
+	     _scc_ "ProfMassage"
 	     let
 		 (collected_CCs, binds3)
 		   = stgMassageForProfiling module_name grp_name us1 binds
 	     in
 	     end_pass us2 "ProfMassage" collected_CCs binds3
-	     ESCC
 
     end_pass us2 what ccs binds2
       = -- report verbosely, if required
 	(if do_verbose_stg2stg then
-	    writeMn stderr (ppShow 1000
+	    hPutStr stderr (ppShow 1000
 	    (ppAbove (ppStr ("*** "++what++":"))
 		     (ppAboves (map (ppr ppr_style) binds2))
 	    ))
-	 else returnMn ()) `thenMn_`
+	 else return ()) >>
 	let
 	    linted_binds = stg_linter what binds2
 	in
-	returnMn (linted_binds, us2, ccs)
+	return (linted_binds, us2, ccs)
 	    -- return: processed binds
 	    -- 	       UniqueSupply for the next guy to use
 	    --	       cost-centres to be declared/registered (specialised)
 	    --	       add to description of what's happened (reverse order)
 
 -- here so it can be inlined...
-foldl_mn f z []     = returnMn z
-foldl_mn f z (x:xs) = f z x	`thenMn` \ zz ->
+foldl_mn f z []     = return z
+foldl_mn f z (x:xs) = f z x	>>= \ zz ->
 		     foldl_mn f zz xs
 \end{code}
 
@@ -226,10 +219,9 @@ unlocaliseStgBinds :: FAST_STRING -> UnlocalEnv -> [StgBinding] -> (UnlocalEnv,
 unlocaliseStgBinds mod uenv [] = (uenv, [])
 
 unlocaliseStgBinds mod uenv (b : bs)
-  = BIND unlocal_top_bind mod uenv b	    _TO_ (new_uenv, new_b) ->
-    BIND unlocaliseStgBinds mod new_uenv bs _TO_ (uenv3, new_bs) ->
-    (uenv3, new_b : new_bs)
-    BEND BEND
+  = case (unlocal_top_bind mod uenv b)	      of { (new_uenv, new_b) ->
+    case (unlocaliseStgBinds mod new_uenv bs) of { (uenv3, new_bs) ->
+    (uenv3, new_b : new_bs) }}
 
 ------------------