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 Outputable       ( PprStyle, Outputable(..) )
  38 import Pretty           ( Doc, ($$), vcat, text, ptext )
  39 import UniqSupply       ( splitUniqSupply, UniqSupply )
  40 import Util             ( mapAccumL, panic, assertPanic )
  41 \end{code}
  42
  43 \begin{code}
  44 stg2stg :: [StgToDo]            -- spec of what stg-to-stg passes to do
  45         -> FAST_STRING          -- module name (profiling only)
  46         -> PprStyle             -- printing style (for debugging 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 ppr_style us binds
  55   = case (splitUniqSupply us)   of { (us4now, us4later) ->
  56
  57     (if do_verbose_stg2stg then
  58         hPutStr stderr "VERBOSE STG-TO-STG:\n" >>
  59         hPutStr stderr (show
  60         (($$) (ptext SLIT("*** Core2Stg:"))
  61                  (vcat (map (ppr ppr_style) (setStgVarInfo False binds)))
  62         ))
  63      else return ()) >>
  64
  65         -- Do the main business!
  66     foldl_mn do_stg_pass (binds, us4now, ([],[])) stg_todos
  67                 >>= \ (processed_binds, _, cost_centres) ->
  68
  69         --      Do essential wind-up
  70
  71 {- Nuked for now        SLPJ Dec 96
  72
  73         -- Essential wind-up: part (a), saturate RHSs
  74         -- This must occur *after* elimIndirections, because elimIndirections
  75         -- can change things' arities.  Consider:
  76         --      x_local = f x
  77         --      x_global = \a -> x_local a
  78         -- Then elimIndirections will change the program to
  79         --      x_global = f x
  80         -- and lo and behold x_global's arity has changed!
  81     case (satStgRhs processed_binds us4later) of { saturated_binds ->
  82 -}
  83
  84         -- Essential wind-up: part (b), do setStgVarInfo. It has to
  85         -- happen regardless, because the code generator uses its
  86         -- decorations.
  87         --
  88         -- Why does it have to happen last?  Because earlier passes
  89         -- may move things around, which would change the live-var
  90         -- info.  Also, setStgVarInfo decides about let-no-escape
  91         -- things, which in turn do a better job if arities are
  92         -- correct, which is done by satStgRhs.
  93         --
  94
  95     return (setStgVarInfo do_let_no_escapes processed_binds, cost_centres)
  96    }
  97   where
  98     do_let_no_escapes  = opt_StgDoLetNoEscapes
  99     do_verbose_stg2stg = opt_D_verbose_stg2stg
 100
 101 {-
 102     (do_unlocalising, unlocal_tag)
 103      = case opt_EnsureSplittableC of
 104          Just tag -> (True, _PK_ tag)
 105          Nothing  -> (False, panic "tag")
 106 -}
 107     grp_name  = case (opt_SccGroup) of
 108                   Just xx -> _PK_ xx
 109                   Nothing -> module_name -- default: module name
 110
 111     -------------
 112     stg_linter = if False --LATER: opt_DoStgLinting (ToDo)
 113                  then lintStgBindings ppr_style
 114                  else ( \ whodunnit binds -> binds )
 115
 116     -------------------------------------------
 117     do_stg_pass (binds, us, ccs) to_do
 118       = let
 119             (us1, us2) = splitUniqSupply us
 120         in
 121         case to_do of
 122           StgDoStaticArgs ->  panic "STG static argument transformation deleted"
 123
 124           StgDoUpdateAnalysis ->
 125              ASSERT(null (fst ccs) && null (snd ccs))
 126              _scc_ "StgUpdAnal"
 127                 -- NB We have to do setStgVarInfo first!  (There's one
 128                 -- place free-var info is used) But no let-no-escapes,
 129                 -- because update analysis doesn't care.
 130              end_pass us2 "UpdAnal" ccs (updateAnalyse (setStgVarInfo False binds))
 131
 132           D_stg_stats ->
 133              trace (showStgStats binds)
 134              end_pass us2 "StgStats" ccs binds
 135
 136           StgDoLambdaLift ->
 137              _scc_ "StgLambdaLift"
 138                 -- NB We have to do setStgVarInfo first!
 139              let
 140                 binds3 = liftProgram module_name us1 (setStgVarInfo do_let_no_escapes binds)
 141              in
 142              end_pass us2 "LambdaLift" ccs binds3
 143
 144           StgDoMassageForProfiling ->
 145              _scc_ "ProfMassage"
 146              let
 147                  (collected_CCs, binds3)
 148                    = stgMassageForProfiling module_name grp_name us1 binds
 149              in
 150              end_pass us2 "ProfMassage" collected_CCs binds3
 151
 152     end_pass us2 what ccs binds2
 153       = -- report verbosely, if required
 154         (if do_verbose_stg2stg then
 155             hPutStr stderr (show
 156             (($$) (text ("*** "++what++":"))
 157                      (vcat (map (ppr ppr_style) binds2))
 158             ))
 159          else return ()) >>
 160         let
 161             linted_binds = stg_linter what binds2
 162         in
 163         return (linted_binds, us2, ccs)
 164             -- return: processed binds
 165             --         UniqueSupply for the next guy to use
 166             --         cost-centres to be declared/registered (specialised)
 167             --         add to description of what's happened (reverse order)
 168
 169 -- here so it can be inlined...
 170 foldl_mn f z []     = return z
 171 foldl_mn f z (x:xs) = f z x     >>= \ zz ->
 172                      foldl_mn f zz xs
 173 \end{code}