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