X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplStg%2FSimplStg.lhs;h=dc945f52bef43ce7ed3cce2023b6f6b67a0b4d9d;hb=9bb32dd2adae0a71b558b366bb73c4d4771ef80a;hp=abde3712bd27bc06e734fa77f36a125ed8826b6e;hpb=7e602b0a11e567fcb035d1afd34015aebcf9a577;p=ghc-hetmet.git

diff --git a/ghc/compiler/simplStg/SimplStg.lhs b/ghc/compiler/simplStg/SimplStg.lhs
index abde371..dc945f5 100644
--- a/ghc/compiler/simplStg/SimplStg.lhs
+++ b/ghc/compiler/simplStg/SimplStg.lhs
@@ -10,82 +10,53 @@ module SimplStg ( stg2stg ) where
 
 import StgSyn
 
-import LambdaLift	( liftProgram )
-import CostCentre       ( CostCentre, CostCentreStack )
+import CostCentre       ( CollectedCCs )
 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,
-			  StgToDo(..)
+import CmdLineOpts	( DynFlags, DynFlag(..), dopt, 
+			  StgToDo(..), dopt_StgToDo
 			)
 import Id		( Id )
-import OccName		( Module, moduleString )
-import VarEnv
-import ErrUtils		( doIfSet )
-import UniqSupply	( splitUniqSupply, UniqSupply )
-import IO		( hPutStr, stderr )
+import Module		( Module )
+import ErrUtils		( doIfSet_dyn, dumpIfSet_dyn, showPass )
+import UniqSupply	( mkSplitUniqSupply, splitUniqSupply )
 import Outputable
 \end{code}
 
 \begin{code}
-stg2stg :: [StgToDo]		-- spec of what stg-to-stg passes to do
-	-> Module		-- module name (profiling only)
-	-> UniqSupply		-- a name supply
-	-> [StgBinding]		-- input...
-	-> IO
-	    ([(StgBinding,[Id])],  -- output program...
-	     ([CostCentre],	   -- local cost-centres that need to be decl'd
-	      [CostCentre],	   -- "extern" cost-centres
-	      [CostCentreStack]))  -- pre-defined "singleton" cost centre stacks
-
-stg2stg 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)))) >>
-
-	-- Do the main business!
-    foldl_mn do_stg_pass (binds, us4now, ([],[],[])) stg_todos
-		>>= \ (processed_binds, _, cost_centres) ->
-
-	-- 	Do essential wind-up
-
-	-- Essential wind-up: part (b), do setStgVarInfo. It has to
-	-- happen regardless, because the code generator uses its
-	-- decorations.
-	--
-	-- Why does it have to happen last?  Because earlier passes
-	-- may move things around, which would change the live-var
-	-- info.  Also, setStgVarInfo decides about let-no-escape
-	-- things, which in turn do a better job if arities are
-	-- correct, which is done by satStgRhs.
-	--
-
-    let
-	annotated_binds = setStgVarInfo do_let_no_escapes processed_binds
-	srt_binds       = computeSRTs annotated_binds
-    in
-
-    return (srt_binds, cost_centres)
-   }
-  where
-    do_let_no_escapes  = opt_StgDoLetNoEscapes
-    do_verbose_stg2stg = opt_D_verbose_stg2stg
+stg2stg :: DynFlags		     -- includes spec of what stg-to-stg passes to do
+	-> Module		     -- module name (profiling only)
+	-> [StgBinding]		     -- input...
+	-> IO ( [(StgBinding,[(Id,[Id])])]  -- output program...
+	      , CollectedCCs)        -- cost centre information (declared and used)
+
+stg2stg dflags module_name binds
+  = do	{ showPass dflags "Stg2Stg"
+	; us <- mkSplitUniqSupply 'g'
+
+	; doIfSet_dyn dflags Opt_D_verbose_stg2stg 
+		      (printDump (text "VERBOSE STG-TO-STG:"))
+
+	; (binds', us', ccs) <- end_pass us "Stg2Stg" ([],[],[]) binds
+
+		-- Do the main business!
+	; (processed_binds, _, cost_centres) 
+		<- foldl_mn do_stg_pass (binds', us', ccs)
+			    (dopt_StgToDo dflags)
+
+	; let srt_binds = computeSRTs processed_binds
+
+	; dumpIfSet_dyn dflags Opt_D_dump_stg "STG syntax:" 
+	     		(pprStgBindingsWithSRTs srt_binds)
 
-    grp_name  = case (opt_SccGroup) of
-		  Just xx -> _PK_ xx
-		  Nothing -> _PK_ (moduleString module_name) -- default: module name
+	; return (srt_binds, cost_centres)
+   }
 
-    -------------
-    stg_linter = if opt_DoStgLinting
+  where
+    stg_linter = if dopt Opt_DoStgLinting dflags
 		 then lintStgBindings
 		 else ( \ whodunnit binds -> binds )
 
@@ -95,46 +66,24 @@ stg2stg stg_todos module_name us binds
 	    (us1, us2) = splitUniqSupply us
 	in
 	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
 
-	  StgDoLambdaLift ->
-	     _scc_ "StgLambdaLift"
-		-- NB We have to do setStgVarInfo first!
-	     let
-		binds3 = liftProgram module_name us1 (setStgVarInfo do_let_no_escapes binds)
-	     in
-	     end_pass us2 "LambdaLift" ccs binds3
-
 	  StgDoMassageForProfiling ->
 	     _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
-	      (text ("*** "++what++":") $$ vcat (map ppr binds2)
-	    ))
-	 else return ()) >>
-	let
-	    linted_binds = stg_linter what binds2
-	in
-	return (linted_binds, us2, ccs)
+      = do -- report verbosely, if required
+	   dumpIfSet_dyn dflags Opt_D_verbose_stg2stg what
+	      (vcat (map ppr binds2))
+	   let linted_binds = stg_linter what binds2
+	   return (linted_binds, us2, ccs)
 	    -- return: processed binds
 	    -- 	       UniqueSupply for the next guy to use
 	    --	       cost-centres to be declared/registered (specialised)