ghc/compiler/simplStg/SimplStg.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
   3 %
   4 \section[SimplStg]{Driver for simplifying @STG@ programs}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module SimplStg ( stg2stg ) where
  10
  11 IMP_Ubiq(){-uitous-}
  12 IMPORT_1_3(IO(hPutStr,stderr))
  13
  14 import StgSyn
  15
  16 import LambdaLift       ( liftProgram )
  17 import Name             ( isLocallyDefined )
  18 import UniqSet          ( UniqSet(..), mapUniqSet )
  19 import CostCentre       ( CostCentre )
  20 import SCCfinal         ( stgMassageForProfiling )
  21 import StgLint          ( lintStgBindings )
  22 import StgStats         ( showStgStats )
  23 import StgVarInfo       ( setStgVarInfo )
  24 import UpdAnal          ( updateAnalyse )
  25
  26 import CmdLineOpts      ( opt_SccGroup, --Not used:opt_EnsureSplittableC,
  27                           opt_StgDoLetNoEscapes, opt_D_verbose_stg2stg,
  28                           opt_DoStgLinting,
  29                           StgToDo(..)
  30                         )
  31 import Id               ( nullIdEnv, lookupIdEnv, addOneToIdEnv,
  32                           growIdEnvList, isNullIdEnv, SYN_IE(IdEnv),
  33                           GenId{-instance Eq/Outputable -}, SYN_IE(Id)
  34                         )
  35 import Maybes           ( maybeToBool )
  36 import PprType          ( GenType{-instance Outputable-} )
  37 import ErrUtils         ( doIfSet )
  38 import Outputable       ( PprStyle, Outputable(..), printErrs, pprDumpStyle )
  39 import Pretty           ( Doc, ($$), vcat, text, ptext )
  40 import UniqSupply       ( splitUniqSupply, UniqSupply )
  41 import Util             ( mapAccumL, panic, assertPanic )
  42 \end{code}
  43
  44 \begin{code}
  45 stg2stg :: [StgToDo]            -- spec of what stg-to-stg passes to do
  46         -> FAST_STRING          -- module name (profiling only)
  47         -> UniqSupply           -- a name supply
  48         -> [StgBinding]         -- input...
  49         -> IO
  50             ([StgBinding],      -- output program...
  51              ([CostCentre],     -- local cost-centres that need to be decl'd
  52               [CostCentre]))    -- "extern" cost-centres
  53
  54 stg2stg stg_todos module_name us binds
  55   = case (splitUniqSupply us)   of { (us4now, us4later) ->
  56
  57     doIfSet do_verbose_stg2stg
  58         (printErrs (text "VERBOSE STG-TO-STG:" $$
  59                     text "*** Core2Stg:" $$
  60                     vcat (map (ppr pprDumpStyle) (setStgVarInfo False binds)))) >>
  61
  62         -- Do the main business!
  63     foldl_mn do_stg_pass (binds, us4now, ([],[])) stg_todos
  64                 >>= \ (processed_binds, _, cost_centres) ->
  65
  66         --      Do essential wind-up
  67
  68 {- Nuked for now        SLPJ Dec 96
  69
  70         -- Essential wind-up: part (a), saturate RHSs
  71         -- This must occur *after* elimIndirections, because elimIndirections
  72         -- can change things' arities.  Consider:
  73         --      x_local = f x
  74         --      x_global = \a -> x_local a
  75         -- Then elimIndirections will change the program to
  76         --      x_global = f x
  77         -- and lo and behold x_global's arity has changed!
  78     case (satStgRhs processed_binds us4later) of { saturated_binds ->
  79 -}
  80
  81         -- Essential wind-up: part (b), do setStgVarInfo. It has to
  82         -- happen regardless, because the code generator uses its
  83         -- decorations.
  84         --
  85         -- Why does it have to happen last?  Because earlier passes
  86         -- may move things around, which would change the live-var
  87         -- info.  Also, setStgVarInfo decides about let-no-escape
  88         -- things, which in turn do a better job if arities are
  89         -- correct, which is done by satStgRhs.
  90         --
  91
  92     return (setStgVarInfo do_let_no_escapes processed_binds, cost_centres)
  93    }
  94   where
  95     do_let_no_escapes  = opt_StgDoLetNoEscapes
  96     do_verbose_stg2stg = opt_D_verbose_stg2stg
  97
  98 {-
  99     (do_unlocalising, unlocal_tag)
 100      = case opt_EnsureSplittableC of
 101          Just tag -> (True, _PK_ tag)
 102          Nothing  -> (False, panic "tag")
 103 -}
 104     grp_name  = case (opt_SccGroup) of
 105                   Just xx -> _PK_ xx
 106                   Nothing -> module_name -- default: module name
 107
 108     -------------
 109     stg_linter = if False --LATER: opt_DoStgLinting (ToDo)
 110                  then lintStgBindings pprDumpStyle
 111                  else ( \ whodunnit binds -> binds )
 112
 113     -------------------------------------------
 114     do_stg_pass (binds, us, ccs) to_do
 115       = let
 116             (us1, us2) = splitUniqSupply us
 117         in
 118         case to_do of
 119           StgDoStaticArgs ->  panic "STG static argument transformation deleted"
 120
 121           StgDoUpdateAnalysis ->
 122              ASSERT(null (fst ccs) && null (snd ccs))
 123              _scc_ "StgUpdAnal"
 124                 -- NB We have to do setStgVarInfo first!  (There's one
 125                 -- place free-var info is used) But no let-no-escapes,
 126                 -- because update analysis doesn't care.
 127              end_pass us2 "UpdAnal" ccs (updateAnalyse (setStgVarInfo False binds))
 128
 129           D_stg_stats ->
 130              trace (showStgStats binds)
 131              end_pass us2 "StgStats" ccs binds
 132
 133           StgDoLambdaLift ->
 134              _scc_ "StgLambdaLift"
 135                 -- NB We have to do setStgVarInfo first!
 136              let
 137                 binds3 = liftProgram module_name us1 (setStgVarInfo do_let_no_escapes binds)
 138              in
 139              end_pass us2 "LambdaLift" ccs binds3
 140
 141           StgDoMassageForProfiling ->
 142              _scc_ "ProfMassage"
 143              let
 144                  (collected_CCs, binds3)
 145                    = stgMassageForProfiling module_name grp_name us1 binds
 146              in
 147              end_pass us2 "ProfMassage" collected_CCs binds3
 148
 149     end_pass us2 what ccs binds2
 150       = -- report verbosely, if required
 151         (if do_verbose_stg2stg then
 152             hPutStr stderr (show
 153             (($$) (text ("*** "++what++":"))
 154                      (vcat (map (ppr pprDumpStyle) binds2))
 155             ))
 156          else return ()) >>
 157         let
 158             linted_binds = stg_linter what binds2
 159         in
 160         return (linted_binds, us2, ccs)
 161             -- return: processed binds
 162             --         UniqueSupply for the next guy to use
 163             --         cost-centres to be declared/registered (specialised)
 164             --         add to description of what's happened (reverse order)
 165
 166 -- here so it can be inlined...
 167 foldl_mn f z []     = return z
 168 foldl_mn f z (x:xs) = f z x     >>= \ zz ->
 169                      foldl_mn f zz xs
 170 \end{code}