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