SimplStg.hs 2.72 KB
Newer Older
Austin Seipp's avatar
Austin Seipp committed
1 2 3
{-
(c) The GRASP/AQUA Project, Glasgow University, 1993-1998

4
\section[SimplStg]{Driver for simplifying @STG@ programs}
Austin Seipp's avatar
Austin Seipp committed
5
-}
6

7 8
{-# LANGUAGE CPP #-}

9 10
module SimplStg ( stg2stg ) where

11
#include "HsVersions.h"
12

13 14
import GhcPrelude

15 16
import StgSyn

17
import StgLint          ( lintStgTopBindings )
18
import StgStats         ( showStgStats )
19
import UnariseStg       ( unarise )
20
import StgCse           ( stgCse )
21

22
import DynFlags
23 24
import ErrUtils
import SrcLoc
25
import UniqSupply       ( mkSplitUniqSupply )
26
import Outputable
27
import Control.Monad
28

29
stg2stg :: DynFlags                  -- includes spec of what stg-to-stg passes to do
30
        -> [StgTopBinding]           -- input...
31
        -> IO [StgTopBinding]        -- output program
32

33
stg2stg dflags binds
34 35
  = do  { showPass dflags "Stg2Stg"
        ; us <- mkSplitUniqSupply 'g'
36

37
        ; when (dopt Opt_D_verbose_stg2stg dflags)
Ben Gamari's avatar
Ben Gamari committed
38
               (putLogMsg dflags NoReason SevDump noSrcSpan
Sylvain Henry's avatar
Sylvain Henry committed
39
                  (defaultDumpStyle dflags) (text "VERBOSE STG-TO-STG:"))
40

41
        ; binds' <- end_pass "Stg2Stg" binds
42

43
                -- Do the main business!
44
        ; processed_binds <- foldM do_stg_pass binds' (getStgToDo dflags)
45

46
        ; dumpIfSet_dyn dflags Opt_D_dump_stg "Pre unarise:"
47
                        (pprStgTopBindings processed_binds)
48

49
        ; let un_binds = stg_linter True "Unarise"
50
                         $ unarise us processed_binds
51

52
        ; dumpIfSet_dyn dflags Opt_D_dump_stg "STG syntax:"
53
                        (pprStgTopBindings un_binds)
54

55
        ; return un_binds
56
   }
57

58
  where
59 60 61
    stg_linter unarised
      | gopt Opt_DoStgLinting dflags = lintStgTopBindings unarised
      | otherwise                    = \ _whodunnit binds -> binds
62 63

    -------------------------------------------
64
    do_stg_pass binds to_do
65
      = case to_do of
66 67
          D_stg_stats ->
             trace (showStgStats binds)
68
             end_pass "StgStats" binds
69

70 71 72 73 74
          StgCSE ->
             {-# SCC "StgCse" #-}
             let
                 binds' = stgCse binds
             in
75
             end_pass "StgCse" binds'
76

77
    end_pass what binds2
78
      = do -- report verbosely, if required
79 80
           dumpIfSet_dyn dflags Opt_D_verbose_stg2stg what
              (vcat (map ppr binds2))
81
           return (stg_linter False what binds2)
82 83 84 85 86 87

-- -----------------------------------------------------------------------------
-- StgToDo:  abstraction of stg-to-stg passes to run.

-- | Optional Stg-to-Stg passes.
data StgToDo
88
  = StgCSE
89 90 91 92 93
  | D_stg_stats

-- | Which optional Stg-to-Stg passes to run. Depends on flags, ways etc.
getStgToDo :: DynFlags -> [StgToDo]
getStgToDo dflags
94 95
  = [ StgCSE                   | gopt Opt_StgCSE dflags] ++
    [ D_stg_stats              | stg_stats ]
96 97
  where
        stg_stats = gopt Opt_StgStats dflags