[project @ 1996-06-05 06:44:31 by partain]

[ghc-hetmet.git] / ghc / compiler / simplStg / SimplStg.lhs

diff --git a/ghc/compiler/simplStg/SimplStg.lhs b/ghc/compiler/simplStg/SimplStg.lhs
index 9b9cbf1..f57744c 100644 (file)
--- 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) }}
 
 ------------------