[project @ 2000-10-24 10:12:16 by sewardj]

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

diff --git a/ghc/compiler/simplStg/SimplStg.lhs b/ghc/compiler/simplStg/SimplStg.lhs
index abde371..a06915c 100644 (file)
--- a/ghc/compiler/simplStg/SimplStg.lhs
+++ b/ghc/compiler/simplStg/SimplStg.lhs
@@ -16,25 +16,23 @@ import SCCfinal             ( stgMassageForProfiling )
 import StgLint         ( lintStgBindings )
 import StgStats                ( showStgStats )
 import StgVarInfo      ( setStgVarInfo )
-import UpdAnal         ( updateAnalyse )
 import SRT             ( computeSRTs )
 
-import CmdLineOpts     ( opt_SccGroup,
-                         opt_StgDoLetNoEscapes, opt_D_verbose_stg2stg,
-                         opt_DoStgLinting,
+import CmdLineOpts     ( DynFlags, DynFlag(..), dopt, 
+                         opt_StgDoLetNoEscapes,
                          StgToDo(..)
                        )
 import Id              ( Id )
-import OccName         ( Module, moduleString )
-import VarEnv
-import ErrUtils                ( doIfSet )
+import Module          ( Module, moduleString )
+import ErrUtils                ( doIfSet_dyn, dumpIfSet_dyn )
 import UniqSupply      ( splitUniqSupply, UniqSupply )
-import IO              ( hPutStr, stderr )
+import IO              ( hPutStr, stdout )
 import Outputable
 \end{code}
 
 \begin{code}
-stg2stg :: [StgToDo]           -- spec of what stg-to-stg passes to do
+stg2stg :: DynFlags
+       -> [StgToDo]            -- spec of what stg-to-stg passes to do
        -> Module               -- module name (profiling only)
        -> UniqSupply           -- a name supply
        -> [StgBinding]         -- input...
@@ -44,16 +42,16 @@ stg2stg :: [StgToDo]                -- spec of what stg-to-stg passes to do
              [CostCentre],        -- "extern" cost-centres
              [CostCentreStack]))  -- pre-defined "singleton" cost centre stacks
 
-stg2stg stg_todos module_name us binds
+stg2stg dflags stg_todos module_name us binds
   = case (splitUniqSupply us)  of { (us4now, us4later) ->
 
-    doIfSet do_verbose_stg2stg
-       (printErrs (text "VERBOSE STG-TO-STG:" $$
-                   text "*** Core2Stg:" $$
-                   vcat (map ppr (setStgVarInfo False binds)))) >>
+    doIfSet_dyn dflags Opt_D_verbose_stg2stg (printErrs (text "VERBOSE STG-TO-STG:")) >>
+
+    end_pass us4now "Core2Stg" ([],[],[]) binds
+               >>= \ (binds', us, ccs) ->
 
        -- Do the main business!
-    foldl_mn do_stg_pass (binds, us4now, ([],[],[])) stg_todos
+    foldl_mn do_stg_pass (binds', us, ccs) stg_todos
                >>= \ (processed_binds, _, cost_centres) ->
 
        --      Do essential wind-up
@@ -70,22 +68,18 @@ stg2stg stg_todos module_name us binds
        --
 
     let
-       annotated_binds = setStgVarInfo do_let_no_escapes processed_binds
+       annotated_binds = setStgVarInfo opt_StgDoLetNoEscapes processed_binds
        srt_binds       = computeSRTs annotated_binds
     in
 
+    dumpIfSet_dyn dflags Opt_D_dump_stg "STG syntax:" 
+             (pprStgBindingsWithSRTs srt_binds)        >>
+
     return (srt_binds, cost_centres)
    }
-  where
-    do_let_no_escapes  = opt_StgDoLetNoEscapes
-    do_verbose_stg2stg = opt_D_verbose_stg2stg
 
-    grp_name  = case (opt_SccGroup) of
-                 Just xx -> _PK_ xx
-                 Nothing -> _PK_ (moduleString module_name) -- default: module name
-
-    -------------
-    stg_linter = if opt_DoStgLinting
+  where
+    stg_linter = if dopt Opt_DoStgLinting dflags
                 then lintStgBindings
                 else ( \ whodunnit binds -> binds )
 
@@ -97,13 +91,6 @@ stg2stg stg_todos module_name us binds
        case to_do of
          StgDoStaticArgs ->  panic "STG static argument transformation deleted"
 
-         StgDoUpdateAnalysis ->
-            _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))
-
          D_stg_stats ->
             trace (showStgStats binds)
             end_pass us2 "StgStats" ccs binds
@@ -112,7 +99,7 @@ stg2stg stg_todos module_name us binds
             _scc_ "StgLambdaLift"
                -- NB We have to do setStgVarInfo first!
             let
-               binds3 = liftProgram module_name us1 (setStgVarInfo do_let_no_escapes binds)
+               binds3 = liftProgram module_name us1 (setStgVarInfo opt_StgDoLetNoEscapes binds)
             in
             end_pass us2 "LambdaLift" ccs binds3
 
@@ -120,14 +107,14 @@ stg2stg stg_todos module_name us binds
             _scc_ "ProfMassage"
             let
                 (collected_CCs, binds3)
-                  = stgMassageForProfiling module_name grp_name us1 binds
+                  = stgMassageForProfiling module_name us1 binds
             in
             end_pass us2 "ProfMassage" collected_CCs binds3
 
     end_pass us2 what ccs binds2
       = -- report verbosely, if required
-       (if do_verbose_stg2stg then
-           hPutStr stderr (show
+       (if dopt Opt_D_verbose_stg2stg dflags then
+           hPutStr stdout (showSDoc
              (text ("*** "++what++":") $$ vcat (map ppr binds2)
            ))
         else return ()) >>