SimplStg.lhs 4.31 KB
Newer Older
1
%
2
% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
3
4
5
6
7
8
%
\section[SimplStg]{Driver for simplifying @STG@ programs}

\begin{code}
module SimplStg ( stg2stg ) where

9
#include "HsVersions.h"
10
11
12
13

import StgSyn

import LambdaLift	( liftProgram )
14
import CostCentre       ( CostCentre, CostCentreStack )
15
import SCCfinal		( stgMassageForProfiling )
16
import StgLint		( lintStgBindings )
17
18
19
import StgStats	        ( showStgStats )
import StgVarInfo	( setStgVarInfo )
import UpdAnal		( updateAnalyse )
20
import SRT		( computeSRTs )
21

22
import CmdLineOpts	( opt_SccGroup,
23
			  opt_StgDoLetNoEscapes, opt_D_verbose_stg2stg,
24
			  opt_DoStgLinting, opt_D_dump_stg,
25
26
			  StgToDo(..)
			)
27
import Id		( Id )
sof's avatar
sof committed
28
import Module		( Module, moduleString )
29
import VarEnv
30
import ErrUtils		( doIfSet, dumpIfSet )
sof's avatar
sof committed
31
import UniqSupply	( splitUniqSupply, UniqSupply )
32
33
import IO		( hPutStr, stderr )
import Outputable
34
35
36
\end{code}

\begin{code}
37
stg2stg :: [StgToDo]		-- spec of what stg-to-stg passes to do
38
	-> Module		-- module name (profiling only)
39
40
	-> UniqSupply		-- a name supply
	-> [StgBinding]		-- input...
41
	-> IO
42
43
44
45
	    ([(StgBinding,[Id])],  -- output program...
	     ([CostCentre],	   -- local cost-centres that need to be decl'd
	      [CostCentre],	   -- "extern" cost-centres
	      [CostCentreStack]))  -- pre-defined "singleton" cost centre stacks
46

sof's avatar
sof committed
47
stg2stg stg_todos module_name us binds
48
  = case (splitUniqSupply us)	of { (us4now, us4later) ->
49

50
51
52
53
    doIfSet opt_D_verbose_stg2stg (printErrs (text "VERBOSE STG-TO-STG:")) >>

    end_pass us4now "Core2Stg" ([],[],[]) binds
		>>= \ (binds', us, ccs) ->
54
55

	-- Do the main business!
56
    foldl_mn do_stg_pass (binds', us, ccs) stg_todos
57
		>>= \ (processed_binds, _, cost_centres) ->
58

59
	-- 	Do essential wind-up
60

61
	-- Essential wind-up: part (b), do setStgVarInfo. It has to
62
63
64
65
66
67
68
69
	-- happen regardless, because the code generator uses its
	-- decorations.
	--
	-- Why does it have to happen last?  Because earlier passes
	-- may move things around, which would change the live-var
	-- info.  Also, setStgVarInfo decides about let-no-escape
	-- things, which in turn do a better job if arities are
	-- correct, which is done by satStgRhs.
70
	--
71

72
    let
73
	annotated_binds = setStgVarInfo opt_StgDoLetNoEscapes processed_binds
74
75
76
	srt_binds       = computeSRTs annotated_binds
    in

77
78
79
    dumpIfSet opt_D_dump_stg "STG syntax:" 
	      (pprStgBindingsWithSRTs srt_binds)	>>

80
    return (srt_binds, cost_centres)
81
   }
82

83
  where
84
    grp_name  = case (opt_SccGroup) of
85
		  Just xx -> _PK_ xx
86
		  Nothing -> _PK_ (moduleString module_name) -- default: module name
87
88

    -------------
89
    stg_linter = if opt_DoStgLinting
90
		 then lintStgBindings
91
92
93
94
95
96
97
98
		 else ( \ whodunnit binds -> binds )

    -------------------------------------------
    do_stg_pass (binds, us, ccs) to_do
      =	let
	    (us1, us2) = splitUniqSupply us
	in
	case to_do of
99
	  StgDoStaticArgs ->  panic "STG static argument transformation deleted"
100
101

	  StgDoUpdateAnalysis ->
102
	     _scc_ "StgUpdAnal"
103
104
105
106
107
108
109
110
111
112
		-- NB We have to do setStgVarInfo first!  (There's one
		-- place free-var info is used) But no let-no-escapes,
		-- because update analysis doesn't care.
	     end_pass us2 "UpdAnal" ccs (updateAnalyse (setStgVarInfo False binds))

	  D_stg_stats ->
	     trace (showStgStats binds)
	     end_pass us2 "StgStats" ccs binds

	  StgDoLambdaLift ->
113
	     _scc_ "StgLambdaLift"
114
115
		-- NB We have to do setStgVarInfo first!
	     let
116
		binds3 = liftProgram module_name us1 (setStgVarInfo opt_StgDoLetNoEscapes binds)
117
118
119
120
	     in
	     end_pass us2 "LambdaLift" ccs binds3

	  StgDoMassageForProfiling ->
121
	     _scc_ "ProfMassage"
122
123
	     let
		 (collected_CCs, binds3)
124
		   = stgMassageForProfiling module_name grp_name us1 binds
125
126
127
128
129
	     in
	     end_pass us2 "ProfMassage" collected_CCs binds3

    end_pass us2 what ccs binds2
      = -- report verbosely, if required
130
	(if opt_D_verbose_stg2stg then
131
	    hPutStr stderr (showSDoc
132
	      (text ("*** "++what++":") $$ vcat (map ppr binds2)
133
	    ))
134
	 else return ()) >>
135
136
137
	let
	    linted_binds = stg_linter what binds2
	in
138
	return (linted_binds, us2, ccs)
139
140
141
142
143
144
	    -- return: processed binds
	    -- 	       UniqueSupply for the next guy to use
	    --	       cost-centres to be declared/registered (specialised)
	    --	       add to description of what's happened (reverse order)

-- here so it can be inlined...
145
146
foldl_mn f z []     = return z
foldl_mn f z (x:xs) = f z x	>>= \ zz ->
147
148
		     foldl_mn f zz xs
\end{code}