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