Add an unshare stg2stg phase
[ghc.git] / compiler / simplStg / SimplStg.lhs
1 %
2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
3 %
4 \section[SimplStg]{Driver for simplifying @STG@ programs}
5
6 \begin{code}
7 {-# OPTIONS -fno-warn-tabs #-}
8 -- The above warning supression flag is a temporary kludge.
9 -- While working on this module you are encouraged to remove it and
10 -- detab the module (please do the detabbing in a separate patch). See
11 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
12 -- for details
13
14 module SimplStg ( stg2stg ) where
15
16 #include "HsVersions.h"
17
18 import StgSyn
19
20 import CostCentre       ( CollectedCCs )
21 import SCCfinal         ( stgMassageForProfiling )
22 import StgLint          ( lintStgBindings )
23 import StgStats         ( showStgStats )
24 import UnariseStg       ( unarise )
25 import Unshare          ( unshare )
26 import SRT              ( computeSRTs )
27
28 import DynFlags         ( DynFlags(..), DynFlag(..), dopt, StgToDo(..),
29                           getStgToDo )
30 import Id               ( Id )
31 import Module           ( Module )
32 import ErrUtils
33 import SrcLoc
34 import UniqSupply       ( mkSplitUniqSupply, splitUniqSupply )
35 import Outputable
36 \end{code}
37
38 \begin{code}
39 stg2stg :: DynFlags                  -- includes spec of what stg-to-stg passes to do
40         -> Module                    -- module name (profiling only)
41         -> [StgBinding]              -- input...
42         -> IO ( [(StgBinding,[(Id,[Id])])]  -- output program...
43               , CollectedCCs)        -- cost centre information (declared and used)
44
45 stg2stg dflags module_name binds
46   = do  { showPass dflags "Stg2Stg"
47         ; us <- mkSplitUniqSupply 'g'
48
49         ; doIfSet_dyn dflags Opt_D_verbose_stg2stg 
50                       (log_action dflags dflags SevDump noSrcSpan defaultDumpStyle (text "VERBOSE STG-TO-STG:"))
51
52         ; (binds', us', ccs) <- end_pass us "Stg2Stg" ([],[],[]) binds
53
54                 -- Do the main business!
55         ; let (us0, us1) = splitUniqSupply us'
56         ; (processed_binds, _, cost_centres) 
57                 <- foldl_mn do_stg_pass (binds', us0, ccs) (getStgToDo dflags)
58
59         ; let un_binds = unarise us1 processed_binds
60         ; let srt_binds
61                | dopt Opt_TryNewCodeGen dflags = zip un_binds (repeat [])
62                | otherwise = computeSRTs un_binds
63
64         ; dumpIfSet_dyn dflags Opt_D_dump_stg "STG syntax:" 
65                         (pprStgBindingsWithSRTs srt_binds)
66
67         ; return (srt_binds, cost_centres)
68    }
69
70   where
71     stg_linter = if dopt Opt_DoStgLinting dflags
72                  then lintStgBindings
73                  else ( \ _whodunnit binds -> binds )
74
75     -------------------------------------------
76     do_stg_pass (binds, us, ccs) to_do
77       = let
78             (us1, us2) = splitUniqSupply us
79         in
80         case to_do of
81           D_stg_stats ->
82              trace (showStgStats binds)
83              end_pass us2 "StgStats" ccs binds
84
85           D_stg_unshare ->
86              trace (showStgStats binds)
87              end_pass us2 "StgUnshare" ccs (unshare dflags binds)
88
89           StgDoMassageForProfiling ->
90              {-# SCC "ProfMassage" #-}
91              let
92                  (collected_CCs, binds3)
93                    = stgMassageForProfiling dflags module_name us1 binds
94              in
95              end_pass us2 "ProfMassage" collected_CCs binds3
96
97     end_pass us2 what ccs binds2
98       = do -- report verbosely, if required
99            dumpIfSet_dyn dflags Opt_D_verbose_stg2stg what
100               (vcat (map ppr binds2))
101            let linted_binds = stg_linter what binds2
102            return (linted_binds, us2, ccs)
103             -- return: processed binds
104             --         UniqueSupply for the next guy to use
105             --         cost-centres to be declared/registered (specialised)
106             --         add to description of what's happened (reverse order)
107
108 -- here so it can be inlined...
109 foldl_mn :: (b -> a -> IO b) -> b -> [a] -> IO b
110 foldl_mn _ z []     = return z
111 foldl_mn f z (x:xs) = f z x     >>= \ zz ->
112                      foldl_mn f zz xs
113 \end{code}