blob: 854bb92258cda3bc0d855d3267925a4370d68508 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
|
{-
(c) The GRASP/AQUA Project, Glasgow University, 1993-1998
\section[SimplStg]{Driver for simplifying @STG@ programs}
-}
{-# LANGUAGE CPP #-}
module SimplStg ( stg2stg ) where
#include "HsVersions.h"
import GhcPrelude
import StgSyn
import StgLint ( lintStgTopBindings )
import StgStats ( showStgStats )
import UnariseStg ( unarise )
import StgCse ( stgCse )
import DynFlags
import ErrUtils
import SrcLoc
import UniqSupply ( mkSplitUniqSupply )
import Outputable
import Control.Monad
stg2stg :: DynFlags -- includes spec of what stg-to-stg passes to do
-> [StgTopBinding] -- input...
-> IO [StgTopBinding] -- output program
stg2stg dflags binds
= do { showPass dflags "Stg2Stg"
; us <- mkSplitUniqSupply 'g'
; when (dopt Opt_D_verbose_stg2stg dflags)
(putLogMsg dflags NoReason SevDump noSrcSpan
(defaultDumpStyle dflags) (text "VERBOSE STG-TO-STG:"))
; binds' <- end_pass "Stg2Stg" binds
-- Do the main business!
; processed_binds <- foldM do_stg_pass binds' (getStgToDo dflags)
; dumpIfSet_dyn dflags Opt_D_dump_stg "Pre unarise:"
(pprStgTopBindings processed_binds)
; let un_binds = unarise us processed_binds
; stg_linter True "Unarise" un_binds
; dumpIfSet_dyn dflags Opt_D_dump_stg "STG syntax:"
(pprStgTopBindings un_binds)
; return un_binds
}
where
stg_linter unarised
| gopt Opt_DoStgLinting dflags = lintStgTopBindings dflags unarised
| otherwise = \ _whodunnit _binds -> return ()
-------------------------------------------
do_stg_pass binds to_do
= case to_do of
D_stg_stats ->
trace (showStgStats binds)
end_pass "StgStats" binds
StgCSE ->
{-# SCC "StgCse" #-}
let
binds' = stgCse binds
in
end_pass "StgCse" binds'
end_pass what binds2
= do -- report verbosely, if required
dumpIfSet_dyn dflags Opt_D_verbose_stg2stg what
(vcat (map ppr binds2))
stg_linter False what binds2
return binds2
-- -----------------------------------------------------------------------------
-- StgToDo: abstraction of stg-to-stg passes to run.
-- | Optional Stg-to-Stg passes.
data StgToDo
= StgCSE
| D_stg_stats
-- | Which optional Stg-to-Stg passes to run. Depends on flags, ways etc.
getStgToDo :: DynFlags -> [StgToDo]
getStgToDo dflags
= [ StgCSE | gopt Opt_StgCSE dflags] ++
[ D_stg_stats | stg_stats ]
where
stg_stats = gopt Opt_StgStats dflags
|
