compiler/cmm/Cmm.hs

   1 -- Cmm representations using Hoopl's Graph CmmNode e x.
   2 {-# LANGUAGE GADTs #-}
   3 {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
   4
   5 {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
   6 #if __GLASGOW_HASKELL__ >= 701
   7 -- GHC 7.0.1 improved incomplete pattern warnings with GADTs
   8 {-# OPTIONS_GHC -fwarn-incomplete-patterns #-}
   9 #endif
  10
  11 module Cmm
  12   ( CmmGraph, GenCmmGraph(..), CmmBlock
  13   , CmmStackInfo(..), CmmTopInfo(..), Cmm, CmmTop
  14   , CmmReplGraph, GenCmmReplGraph, CmmFwdRewrite, CmmBwdRewrite
  15
  16   , modifyGraph
  17   , lastNode, replaceLastNode, insertBetween
  18   , ofBlockMap, toBlockMap, insertBlock
  19   , ofBlockList, toBlockList, bodyToBlockList
  20   , foldGraphBlocks, mapGraphNodes, postorderDfs
  21
  22   , analFwd, analBwd, analRewFwd, analRewBwd
  23   , dataflowPassFwd, dataflowPassBwd
  24   , module CmmNode
  25   )
  26 where
  27
  28 import BlockId
  29 import CmmDecl
  30 import CmmNode
  31 import OptimizationFuel as F
  32 import SMRep
  33 import UniqSupply
  34
  35 import Compiler.Hoopl
  36 import Control.Monad
  37 import Data.Maybe
  38 import Panic
  39
  40 #include "HsVersions.h"
  41
  42 -------------------------------------------------
  43 -- CmmBlock, CmmGraph and Cmm
  44
  45 type CmmGraph = GenCmmGraph CmmNode
  46 data GenCmmGraph n = CmmGraph { g_entry :: BlockId, g_graph :: Graph n C C }
  47 type CmmBlock = Block CmmNode C C
  48
  49 type CmmReplGraph e x = GenCmmReplGraph CmmNode e x
  50 type GenCmmReplGraph n e x = FuelUniqSM (Maybe (Graph n e x))
  51 type CmmFwdRewrite f = FwdRewrite FuelUniqSM CmmNode f
  52 type CmmBwdRewrite f = BwdRewrite FuelUniqSM CmmNode f
  53
  54 data CmmStackInfo = StackInfo {arg_space :: ByteOff, updfr_space :: Maybe ByteOff}
  55 data CmmTopInfo   = TopInfo {info_tbl :: CmmInfoTable, stack_info :: CmmStackInfo}
  56 type Cmm          = GenCmm    CmmStatic CmmTopInfo CmmGraph
  57 type CmmTop       = GenCmmTop CmmStatic CmmTopInfo CmmGraph
  58
  59 -------------------------------------------------
  60 -- Manipulating CmmGraphs
  61
  62 modifyGraph :: (Graph n C C -> Graph n' C C) -> GenCmmGraph n -> GenCmmGraph n'
  63 modifyGraph f g = CmmGraph {g_entry=g_entry g, g_graph=f (g_graph g)}
  64
  65 toBlockMap :: CmmGraph -> LabelMap CmmBlock
  66 toBlockMap (CmmGraph {g_graph=GMany NothingO body NothingO}) = body
  67
  68 ofBlockMap :: BlockId -> LabelMap CmmBlock -> CmmGraph
  69 ofBlockMap entry bodyMap = CmmGraph {g_entry=entry, g_graph=GMany NothingO bodyMap NothingO}
  70
  71 insertBlock :: CmmBlock -> LabelMap CmmBlock -> LabelMap CmmBlock
  72 insertBlock block map =
  73   ASSERT (isNothing $ mapLookup id map)
  74   mapInsert id block map
  75   where id = entryLabel block
  76
  77 toBlockList :: CmmGraph -> [CmmBlock]
  78 toBlockList g = mapElems $ toBlockMap g
  79
  80 ofBlockList :: BlockId -> [CmmBlock] -> CmmGraph
  81 ofBlockList entry blocks = CmmGraph {g_entry=entry, g_graph=GMany NothingO body NothingO}
  82   where body = foldr addBlock emptyBody blocks
  83
  84 bodyToBlockList :: Body CmmNode -> [CmmBlock]
  85 bodyToBlockList body = mapElems body
  86
  87 mapGraphNodes :: ( CmmNode C O -> CmmNode C O
  88                  , CmmNode O O -> CmmNode O O
  89                  , CmmNode O C -> CmmNode O C)
  90               -> CmmGraph -> CmmGraph
  91 mapGraphNodes funs@(mf,_,_) g =
  92   ofBlockMap (entryLabel $ mf $ CmmEntry $ g_entry g) $ mapMap (blockMapNodes3 funs) $ toBlockMap g
  93
  94 foldGraphBlocks :: (CmmBlock -> a -> a) -> a -> CmmGraph -> a
  95 foldGraphBlocks k z g = mapFold k z $ toBlockMap g
  96
  97 postorderDfs :: CmmGraph -> [CmmBlock]
  98 postorderDfs g = postorder_dfs_from (toBlockMap g) (g_entry g)
  99
 100 -------------------------------------------------
 101 -- Manipulating CmmBlocks
 102
 103 lastNode :: CmmBlock -> CmmNode O C
 104 lastNode block = foldBlockNodesF3 (nothing, nothing, const) block ()
 105   where nothing :: a -> b -> ()
 106         nothing _ _ = ()
 107
 108 replaceLastNode :: Block CmmNode e C -> CmmNode O C -> Block CmmNode e C
 109 replaceLastNode block last = blockOfNodeList (first, middle, JustC last)
 110   where (first, middle, _) = blockToNodeList block
 111
 112 ----------------------------------------------------------------------
 113 ----- Splicing between blocks
 114 -- Given a middle node, a block, and a successor BlockId,
 115 -- we can insert the middle node between the block and the successor.
 116 -- We return the updated block and a list of new blocks that must be added
 117 -- to the graph.
 118 -- The semantics is a bit tricky. We consider cases on the last node:
 119 -- o For a branch, we can just insert before the branch,
 120 --   but sometimes the optimizer does better if we actually insert
 121 --   a fresh basic block, enabling some common blockification.
 122 -- o For a conditional branch, switch statement, or call, we must insert
 123 --   a new basic block.
 124 -- o For a jump or return, this operation is impossible.
 125
 126 insertBetween :: MonadUnique m => CmmBlock -> [CmmNode O O] -> BlockId -> m (CmmBlock, [CmmBlock])
 127 insertBetween b ms succId = insert $ lastNode b
 128   where insert :: MonadUnique m => CmmNode O C -> m (CmmBlock, [CmmBlock])
 129         insert (CmmBranch bid) =
 130           if bid == succId then
 131             do (bid', bs) <- newBlocks
 132                return (replaceLastNode b (CmmBranch bid'), bs)
 133           else panic "tried invalid block insertBetween"
 134         insert (CmmCondBranch c t f) =
 135           do (t', tbs) <- if t == succId then newBlocks else return $ (t, [])
 136              (f', fbs) <- if f == succId then newBlocks else return $ (f, [])
 137              return (replaceLastNode b (CmmCondBranch c t' f'), tbs ++ fbs)
 138         insert (CmmSwitch e ks) =
 139           do (ids, bs) <- mapAndUnzipM mbNewBlocks ks
 140              return (replaceLastNode b (CmmSwitch e ids), join bs)
 141         insert (CmmCall {}) =
 142           panic "unimp: insertBetween after a call -- probably not a good idea"
 143         insert (CmmForeignCall {}) =
 144           panic "unimp: insertBetween after a foreign call -- probably not a good idea"
 145
 146         newBlocks :: MonadUnique m => m (BlockId, [CmmBlock])
 147         newBlocks = do id <- liftM mkBlockId $ getUniqueM
 148                        return $ (id, [blockOfNodeList (JustC (CmmEntry id), ms, JustC (CmmBranch succId))])
 149         mbNewBlocks :: MonadUnique m => Maybe BlockId -> m (Maybe BlockId, [CmmBlock])
 150         mbNewBlocks (Just k) = if k == succId then liftM fstJust newBlocks
 151                                else return (Just k, [])
 152         mbNewBlocks Nothing  = return (Nothing, [])
 153         fstJust (id, bs) = (Just id, bs)
 154
 155 -------------------------------------------------
 156 -- Running dataflow analysis and/or rewrites
 157
 158 -- Constructing forward and backward analysis-only pass
 159 analFwd    :: Monad m => DataflowLattice f -> FwdTransfer n f -> FwdPass m n f
 160 analBwd    :: Monad m => DataflowLattice f -> BwdTransfer n f -> BwdPass m n f
 161
 162 analFwd lat xfer = analRewFwd lat xfer noFwdRewrite
 163 analBwd lat xfer = analRewBwd lat xfer noBwdRewrite
 164
 165 -- Constructing forward and backward analysis + rewrite pass
 166 analRewFwd :: Monad m => DataflowLattice f -> FwdTransfer n f -> FwdRewrite m n f -> FwdPass m n f
 167 analRewBwd :: Monad m => DataflowLattice f -> BwdTransfer n f -> BwdRewrite m n f -> BwdPass m n f
 168
 169 analRewFwd lat xfer rew = FwdPass {fp_lattice = lat, fp_transfer = xfer, fp_rewrite = rew}
 170 analRewBwd lat xfer rew = BwdPass {bp_lattice = lat, bp_transfer = xfer, bp_rewrite = rew}
 171
 172 -- Running forward and backward dataflow analysis + optional rewrite
 173 dataflowPassFwd :: NonLocal n => GenCmmGraph n -> [(BlockId, f)] -> FwdPass FuelUniqSM n f -> FuelUniqSM (GenCmmGraph n, BlockEnv f)
 174 dataflowPassFwd (CmmGraph {g_entry=entry, g_graph=graph}) facts fwd = do
 175   (graph, facts, NothingO) <- analyzeAndRewriteFwd fwd (JustC [entry]) graph (mkFactBase (fp_lattice fwd) facts)
 176   return (CmmGraph {g_entry=entry, g_graph=graph}, facts)
 177
 178 dataflowPassBwd :: NonLocal n => GenCmmGraph n -> [(BlockId, f)] -> BwdPass FuelUniqSM n f -> FuelUniqSM (GenCmmGraph n, BlockEnv f)
 179 dataflowPassBwd (CmmGraph {g_entry=entry, g_graph=graph}) facts bwd = do
 180   (graph, facts, NothingO) <- analyzeAndRewriteBwd bwd (JustC [entry]) graph (mkFactBase (bp_lattice bwd) facts)
 181   return (CmmGraph {g_entry=entry, g_graph=graph}, facts)