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