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