[project @ 1998-05-12 12:45:00 by simonm]

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

diff --git a/ghc/compiler/simplStg/SimplStg.lhs b/ghc/compiler/simplStg/SimplStg.lhs
index efa5679..fb626f3 100644 (file)
--- a/ghc/compiler/simplStg/SimplStg.lhs
+++ b/ghc/compiler/simplStg/SimplStg.lhs
@@ -4,43 +4,43 @@
 \section[SimplStg]{Driver for simplifying @STG@ programs}
 
 \begin{code}
-#include "HsVersions.h"
-
 module SimplStg ( stg2stg ) where
 
-IMP_Ubiq(){-uitous-}
-IMPORT_1_3(IO(hPutStr,stderr))
+#include "HsVersions.h"
 
 import StgSyn
 
 import LambdaLift      ( liftProgram )
 import Name            ( isLocallyDefined )
+import UniqSet          ( UniqSet, mapUniqSet )
+import CostCentre       ( CostCentre )
 import SCCfinal                ( stgMassageForProfiling )
 import StgLint         ( lintStgBindings )
 import StgStats                ( showStgStats )
 import StgVarInfo      ( setStgVarInfo )
 import UpdAnal         ( updateAnalyse )
 
-import CmdLineOpts     ( opt_EnsureSplittableC, opt_SccGroup,
+import CmdLineOpts     ( opt_SccGroup, --Not used:opt_EnsureSplittableC,
                          opt_StgDoLetNoEscapes, opt_D_verbose_stg2stg,
+                         opt_DoStgLinting,
                          StgToDo(..)
                        )
 import Id              ( nullIdEnv, lookupIdEnv, addOneToIdEnv,
-                         growIdEnvList, isNullIdEnv, SYN_IE(IdEnv),
-                         GenId{-instance Eq/Outputable -}
+                         growIdEnvList, isNullIdEnv, IdEnv,
+                         GenId{-instance Eq/Outputable -}, Id
                        )
 import Maybes          ( maybeToBool )
-import PprType         ( GenType{-instance Outputable-} )
-import Pretty          ( ppShow, ppAbove, ppAboves, ppStr )
-import UniqSupply      ( splitUniqSupply )
+import ErrUtils                ( doIfSet )
+import UniqSupply      ( splitUniqSupply, UniqSupply )
 import Util            ( mapAccumL, panic, assertPanic )
-
+import IO              ( hPutStr, stderr )
+import Outputable
+import GlaExts         ( trace )
 \end{code}
 
 \begin{code}
 stg2stg :: [StgToDo]           -- spec of what stg-to-stg passes to do
        -> FAST_STRING          -- module name (profiling only)
-       -> PprStyle             -- printing style (for debugging only)
        -> UniqSupply           -- a name supply
        -> [StgBinding]         -- input...
        -> IO
@@ -48,16 +48,13 @@ stg2stg :: [StgToDo]                -- spec of what stg-to-stg passes to do
             ([CostCentre],     -- local cost-centres that need to be decl'd
              [CostCentre]))    -- "extern" cost-centres
 
-stg2stg stg_todos module_name ppr_style us binds
+stg2stg stg_todos module_name us binds
   = case (splitUniqSupply us)  of { (us4now, us4later) ->
 
-    (if do_verbose_stg2stg then
-       hPutStr stderr "VERBOSE STG-TO-STG:\n" >>
-       hPutStr stderr (ppShow 1000
-       (ppAbove (ppStr ("*** Core2Stg:"))
-                (ppAboves (map (ppr ppr_style) (setStgVarInfo False binds)))
-       ))
-     else return ()) >>
+    doIfSet do_verbose_stg2stg
+       (printErrs (text "VERBOSE STG-TO-STG:" $$
+                   text "*** Core2Stg:" $$
+                   vcat (map ppr (setStgVarInfo False binds)))) >>
 
        -- Do the main business!
     foldl_mn do_stg_pass (binds, us4now, ([],[])) stg_todos
@@ -66,6 +63,7 @@ stg2stg stg_todos module_name ppr_style us binds
        --      Do essential wind-up
 
 {- Nuked for now       SLPJ Dec 96
+
        -- Essential wind-up: part (a), saturate RHSs
        -- This must occur *after* elimIndirections, because elimIndirections
        -- can change things' arities.  Consider:
@@ -74,7 +72,6 @@ stg2stg stg_todos module_name ppr_style us binds
        -- Then elimIndirections will change the program to
        --      x_global = f x
        -- and lo and behold x_global's arity has changed!
-
     case (satStgRhs processed_binds us4later) of { saturated_binds ->
 -}
 
@@ -89,29 +86,25 @@ stg2stg stg_todos module_name ppr_style us binds
        -- correct, which is done by satStgRhs.
        --
 
-{-     Done in Core now.  Nuke soon. SLPJ Nov 96
-    let
-               -- ToDo: provide proper flag control!
-       binds_to_mangle
-         = if not do_unlocalising
-           then saturated_binds
-           else snd (unlocaliseStgBinds unlocal_tag nullIdEnv no_ind_binds)
-    in
--}
-
     return (setStgVarInfo do_let_no_escapes processed_binds, cost_centres)
    }
   where
     do_let_no_escapes  = opt_StgDoLetNoEscapes
     do_verbose_stg2stg = opt_D_verbose_stg2stg
 
+{-
+    (do_unlocalising, unlocal_tag) 
+     = case opt_EnsureSplittableC of
+         Just tag -> (True, _PK_ tag)
+         Nothing  -> (False, panic "tag")
+-}
     grp_name  = case (opt_SccGroup) of
                  Just xx -> _PK_ xx
                  Nothing -> module_name -- default: module name
 
     -------------
-    stg_linter = if False -- LATER: switch_is_on DoCoreLinting -- ToDo: DoStgLinting flag
-                then lintStgBindings ppr_style
+    stg_linter = if False --LATER: opt_DoStgLinting (ToDo)
+                then lintStgBindings
                 else ( \ whodunnit binds -> binds )
 
     -------------------------------------------
@@ -138,7 +131,7 @@ stg2stg stg_todos module_name ppr_style us binds
             _scc_ "StgLambdaLift"
                -- NB We have to do setStgVarInfo first!
             let
-               binds3 = liftProgram us1 (setStgVarInfo do_let_no_escapes binds)
+               binds3 = liftProgram module_name us1 (setStgVarInfo do_let_no_escapes binds)
             in
             end_pass us2 "LambdaLift" ccs binds3
 
@@ -153,9 +146,8 @@ stg2stg stg_todos module_name ppr_style us binds
     end_pass us2 what ccs binds2
       = -- report verbosely, if required
        (if do_verbose_stg2stg then
-           hPutStr stderr (ppShow 1000
-           (ppAbove (ppStr ("*** "++what++":"))
-                    (ppAboves (map (ppr ppr_style) binds2))
+           hPutStr stderr (showSDoc
+             (text ("*** "++what++":") $$ vcat (map ppr binds2)
            ))
         else return ()) >>
        let
@@ -172,5 +164,3 @@ foldl_mn f z []     = return z
 foldl_mn f z (x:xs) = f z x    >>= \ zz ->
                     foldl_mn f zz xs
 \end{code}
-
-