CmmUtils.hs 20.4 KB
Newer Older
1
{-# LANGUAGE GADTs #-}
Ian Lynagh's avatar
Ian Lynagh committed
2 3 4 5 6 7 8
{-# OPTIONS -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
-- for details

9
{-# OPTIONS_GHC -fno-warn-deprecations #-}
Simon Peyton Jones's avatar
Simon Peyton Jones committed
10
-- Warnings from deprecated blockToNodeList
11 12 13 14 15
{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
#if __GLASGOW_HASKELL__ >= 703
-- GHC 7.0.1 improved incomplete pattern warnings with GADTs
{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}
#endif
Simon Peyton Jones's avatar
Simon Peyton Jones committed
16 17


18 19 20 21
-----------------------------------------------------------------------------
--
-- Cmm utilities.
--
Simon Marlow's avatar
Simon Marlow committed
22
-- (c) The University of Glasgow 2004-2006
23 24 25
--
-----------------------------------------------------------------------------

26
module CmmUtils( 
27
        -- CmmType
28 29 30
	primRepCmmType, primRepForeignHint,
	typeCmmType, typeForeignHint,

31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47
	-- CmmLit
	zeroCLit, mkIntCLit, 
	mkWordCLit, packHalfWordsCLit,
	mkByteStringCLit, 
        mkDataLits, mkRODataLits,

	-- CmmExpr
	mkLblExpr,
	cmmRegOff,  cmmOffset,  cmmLabelOff,  cmmOffsetLit,  cmmOffsetExpr, 
	cmmRegOffB, cmmOffsetB, cmmLabelOffB, cmmOffsetLitB, cmmOffsetExprB,
	cmmRegOffW, cmmOffsetW, cmmLabelOffW, cmmOffsetLitW, cmmOffsetExprW,
	cmmIndex, cmmIndexExpr, cmmLoadIndex, cmmLoadIndexW,
	cmmNegate, 
  	cmmULtWord, cmmUGeWord, cmmUGtWord, cmmSubWord,
  	cmmNeWord, cmmEqWord, cmmOrWord, cmmAndWord,
  	cmmUShrWord, cmmAddWord, cmmMulWord,

48
	isTrivialCmmExpr, hasNoGlobalRegs,
49 50 51
	
	-- Statics
	blankWord,
52

53 54 55
	-- Tagging
	cmmTagMask, cmmPointerMask, cmmUntag, cmmGetTag, cmmIsTagged,
	cmmConstrTag, cmmConstrTag1,
56

57 58
        -- Liveness and bitmaps
        mkLiveness,
59

60 61 62 63 64 65
        -- * Operations that probably don't belong here
        modifyGraph,

        lastNode, replaceLastNode, insertBetween,
        ofBlockMap, toBlockMap, insertBlock,
        ofBlockList, toBlockList, bodyToBlockList,
66
        foldGraphBlocks, mapGraphNodes, postorderDfs, mapGraphNodes1,
67 68
      
        analFwd, analBwd, analRewFwd, analRewBwd,
Simon Marlow's avatar
Simon Marlow committed
69 70
        dataflowPassFwd, dataflowPassBwd, dataflowAnalFwd, dataflowAnalBwd,
        dataflowAnalFwdBlocks
71 72 73 74
  ) where

#include "HsVersions.h"

75 76 77
import TyCon	( PrimRep(..) )
import Type	( Type, typePrimRep )

78 79 80
import SMRep
import Cmm
import BlockId
Simon Marlow's avatar
Simon Marlow committed
81
import CLabel
82
import Outputable
83 84 85 86 87 88 89 90 91
import OptimizationFuel as F
import Unique
import UniqSupply
import Constants( wORD_SIZE, tAG_MASK )

import Data.Word
import Data.Maybe
import Data.Bits
import Control.Monad
Simon Marlow's avatar
Simon Marlow committed
92
import Hoopl
93

94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120
---------------------------------------------------
--
--	CmmTypes
--
---------------------------------------------------

primRepCmmType :: PrimRep -> CmmType
primRepCmmType VoidRep    = panic "primRepCmmType:VoidRep"
primRepCmmType PtrRep     = gcWord
primRepCmmType IntRep	  = bWord
primRepCmmType WordRep	  = bWord
primRepCmmType Int64Rep   = b64
primRepCmmType Word64Rep  = b64
primRepCmmType AddrRep    = bWord
primRepCmmType FloatRep   = f32
primRepCmmType DoubleRep  = f64

typeCmmType :: Type -> CmmType
typeCmmType ty = primRepCmmType (typePrimRep ty)

primRepForeignHint :: PrimRep -> ForeignHint
primRepForeignHint VoidRep	= panic "primRepForeignHint:VoidRep"
primRepForeignHint PtrRep	= AddrHint
primRepForeignHint IntRep	= SignedHint
primRepForeignHint WordRep	= NoHint
primRepForeignHint Int64Rep	= SignedHint
primRepForeignHint Word64Rep	= NoHint
121
primRepForeignHint AddrRep      = AddrHint -- NB! AddrHint, but NonPtrArg
122 123 124 125 126 127
primRepForeignHint FloatRep	= NoHint
primRepForeignHint DoubleRep	= NoHint

typeForeignHint :: Type -> ForeignHint
typeForeignHint = primRepForeignHint . typePrimRep

128 129
---------------------------------------------------
--
130
--	CmmLit
131 132 133
--
---------------------------------------------------

134 135
mkIntCLit :: Int -> CmmLit
mkIntCLit i = CmmInt (toInteger i) wordWidth
136

137 138 139
zeroCLit :: CmmLit
zeroCLit = CmmInt 0 wordWidth

Simon Peyton Jones's avatar
Simon Peyton Jones committed
140
mkByteStringCLit :: Unique -> [Word8] -> (CmmLit, GenCmmDecl CmmStatics info stmt)
141 142 143 144 145 146
-- We have to make a top-level decl for the string, 
-- and return a literal pointing to it
mkByteStringCLit uniq bytes
  = (CmmLabel lbl, CmmData ReadOnlyData $ Statics lbl [CmmString bytes])
  where
    lbl = mkStringLitLabel uniq
Simon Peyton Jones's avatar
Simon Peyton Jones committed
147
mkDataLits :: Section -> CLabel -> [CmmLit] -> GenCmmDecl CmmStatics info stmt
148 149 150 151
-- Build a data-segment data block
mkDataLits section lbl lits
  = CmmData section (Statics lbl $ map CmmStaticLit lits)

Simon Peyton Jones's avatar
Simon Peyton Jones committed
152
mkRODataLits :: CLabel -> [CmmLit] -> GenCmmDecl CmmStatics info stmt
153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179
-- Build a read-only data block
mkRODataLits lbl lits
  = mkDataLits section lbl lits
  where 
    section | any needsRelocation lits = RelocatableReadOnlyData
            | otherwise                = ReadOnlyData
    needsRelocation (CmmLabel _)      = True
    needsRelocation (CmmLabelOff _ _) = True
    needsRelocation _                 = False

mkWordCLit :: StgWord -> CmmLit
mkWordCLit wd = CmmInt (fromIntegral wd) wordWidth

packHalfWordsCLit :: (Integral a, Integral b) => a -> b -> CmmLit
-- Make a single word literal in which the lower_half_word is
-- at the lower address, and the upper_half_word is at the 
-- higher address
-- ToDo: consider using half-word lits instead
-- 	 but be careful: that's vulnerable when reversed
packHalfWordsCLit lower_half_word upper_half_word
#ifdef WORDS_BIGENDIAN
   = mkWordCLit ((fromIntegral lower_half_word `shiftL` hALF_WORD_SIZE_IN_BITS)
		 .|. fromIntegral upper_half_word)
#else 
   = mkWordCLit ((fromIntegral lower_half_word) 
		 .|. (fromIntegral upper_half_word `shiftL` hALF_WORD_SIZE_IN_BITS))
#endif
180

181 182
---------------------------------------------------
--
183
--	CmmExpr
184 185 186
--
---------------------------------------------------

187 188 189
mkLblExpr :: CLabel -> CmmExpr
mkLblExpr lbl = CmmLit (CmmLabel lbl)

190
cmmOffsetExpr :: CmmExpr -> CmmExpr -> CmmExpr
191
-- assumes base and offset have the same CmmType
192
cmmOffsetExpr e (CmmLit (CmmInt n _)) = cmmOffset e (fromInteger n)
193
cmmOffsetExpr e byte_off = CmmMachOp (MO_Add (cmmExprWidth e)) [e, byte_off]
194 195 196 197 198 199 200 201 202

-- NB. Do *not* inspect the value of the offset in these smart constructors!!!
-- because the offset is sometimes involved in a loop in the code generator
-- (we don't know the real Hp offset until we've generated code for the entire
-- basic block, for example).  So we cannot eliminate zero offsets at this
-- stage; they're eliminated later instead (either during printing or
-- a later optimisation step on Cmm).
--
cmmOffset :: CmmExpr -> Int -> CmmExpr
203
cmmOffset e                 0        = e
204 205 206 207 208 209 210
cmmOffset (CmmReg reg)      byte_off = cmmRegOff reg byte_off
cmmOffset (CmmRegOff reg m) byte_off = cmmRegOff reg (m+byte_off)
cmmOffset (CmmLit lit)      byte_off = CmmLit (cmmOffsetLit lit byte_off)
cmmOffset (CmmMachOp (MO_Add rep) [expr, CmmLit (CmmInt byte_off1 _rep)]) byte_off2
  = CmmMachOp (MO_Add rep) 
	      [expr, CmmLit (CmmInt (byte_off1 + toInteger byte_off2) rep)]
cmmOffset expr byte_off
211
  = CmmMachOp (MO_Add width) [expr, CmmLit (CmmInt (toInteger byte_off) width)]
212
  where
213
    width = cmmExprWidth expr
214 215 216 217 218 219 220 221 222

-- Smart constructor for CmmRegOff.  Same caveats as cmmOffset above.
cmmRegOff :: CmmReg -> Int -> CmmExpr
cmmRegOff reg byte_off = CmmRegOff reg byte_off

cmmOffsetLit :: CmmLit -> Int -> CmmLit
cmmOffsetLit (CmmLabel l)      byte_off = cmmLabelOff	l byte_off
cmmOffsetLit (CmmLabelOff l m) byte_off = cmmLabelOff	l (m+byte_off)
cmmOffsetLit (CmmInt m rep)    byte_off = CmmInt (m + fromIntegral byte_off) rep
Ian Lynagh's avatar
Ian Lynagh committed
223
cmmOffsetLit _    	       byte_off = pprPanic "cmmOffsetLit" (ppr byte_off)
224 225 226 227 228 229 230

cmmLabelOff :: CLabel -> Int -> CmmLit
-- Smart constructor for CmmLabelOff
cmmLabelOff lbl 0        = CmmLabel lbl
cmmLabelOff lbl byte_off = CmmLabelOff lbl byte_off

-- | Useful for creating an index into an array, with a staticaly known offset.
231 232 233 234 235 236
-- The type is the element type; used for making the multiplier
cmmIndex :: Width	-- Width w
	 -> CmmExpr	-- Address of vector of items of width w
	 -> Int		-- Which element of the vector (0 based)
	 -> CmmExpr	-- Address of i'th element
cmmIndex width base idx = cmmOffset base (idx * widthInBytes width)
237 238

-- | Useful for creating an index into an array, with an unknown offset.
239 240 241 242 243 244
cmmIndexExpr :: Width		-- Width w
	     -> CmmExpr		-- Address of vector of items of width w
	     -> CmmExpr		-- Which element of the vector (0 based)
	     -> CmmExpr		-- Address of i'th element
cmmIndexExpr width base (CmmLit (CmmInt n _)) = cmmIndex width base (fromInteger n)
cmmIndexExpr width base idx =
245 246
  cmmOffsetExpr base byte_off
  where
247 248
    idx_w = cmmExprWidth idx
    byte_off = CmmMachOp (MO_Shl idx_w) [idx, CmmLit (mkIntCLit (widthInLog width))]
249

250 251
cmmLoadIndex :: CmmType -> CmmExpr -> Int -> CmmExpr
cmmLoadIndex ty expr ix = CmmLoad (cmmIndex (typeWidth ty) expr ix) ty
252

253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315
-- The "B" variants take byte offsets
cmmRegOffB :: CmmReg -> ByteOff -> CmmExpr
cmmRegOffB = cmmRegOff

cmmOffsetB :: CmmExpr -> ByteOff -> CmmExpr
cmmOffsetB = cmmOffset

cmmOffsetExprB :: CmmExpr -> CmmExpr -> CmmExpr
cmmOffsetExprB = cmmOffsetExpr

cmmLabelOffB :: CLabel -> ByteOff -> CmmLit
cmmLabelOffB = cmmLabelOff

cmmOffsetLitB :: CmmLit -> ByteOff -> CmmLit
cmmOffsetLitB = cmmOffsetLit

-----------------------
-- The "W" variants take word offsets
cmmOffsetExprW :: CmmExpr -> CmmExpr -> CmmExpr
-- The second arg is a *word* offset; need to change it to bytes
cmmOffsetExprW e (CmmLit (CmmInt n _)) = cmmOffsetW e (fromInteger n)
cmmOffsetExprW e wd_off = cmmIndexExpr wordWidth e wd_off

cmmOffsetW :: CmmExpr -> WordOff -> CmmExpr
cmmOffsetW e n = cmmOffsetB e (wORD_SIZE * n)

cmmRegOffW :: CmmReg -> WordOff -> CmmExpr
cmmRegOffW reg wd_off = cmmRegOffB reg (wd_off * wORD_SIZE)

cmmOffsetLitW :: CmmLit -> WordOff -> CmmLit
cmmOffsetLitW lit wd_off = cmmOffsetLitB lit (wORD_SIZE * wd_off)

cmmLabelOffW :: CLabel -> WordOff -> CmmLit
cmmLabelOffW lbl wd_off = cmmLabelOffB lbl (wORD_SIZE * wd_off)

cmmLoadIndexW :: CmmExpr -> Int -> CmmType -> CmmExpr
cmmLoadIndexW base off ty = CmmLoad (cmmOffsetW base off) ty

-----------------------
cmmULtWord, cmmUGeWord, cmmUGtWord, cmmSubWord,
  cmmNeWord, cmmEqWord, cmmOrWord, cmmAndWord,
  cmmUShrWord, cmmAddWord, cmmMulWord
  :: CmmExpr -> CmmExpr -> CmmExpr
cmmOrWord  e1 e2 = CmmMachOp mo_wordOr  [e1, e2]
cmmAndWord e1 e2 = CmmMachOp mo_wordAnd [e1, e2]
cmmNeWord  e1 e2 = CmmMachOp mo_wordNe  [e1, e2]
cmmEqWord  e1 e2 = CmmMachOp mo_wordEq  [e1, e2]
cmmULtWord e1 e2 = CmmMachOp mo_wordULt [e1, e2]
cmmUGeWord e1 e2 = CmmMachOp mo_wordUGe [e1, e2]
cmmUGtWord e1 e2 = CmmMachOp mo_wordUGt [e1, e2]
--cmmShlWord e1 e2 = CmmMachOp mo_wordShl [e1, e2]
cmmUShrWord e1 e2 = CmmMachOp mo_wordUShr [e1, e2]
cmmAddWord e1 e2 = CmmMachOp mo_wordAdd [e1, e2]
cmmSubWord e1 e2 = CmmMachOp mo_wordSub [e1, e2]
cmmMulWord e1 e2 = CmmMachOp mo_wordMul [e1, e2]

cmmNegate :: CmmExpr -> CmmExpr
cmmNegate (CmmLit (CmmInt n rep)) = CmmLit (CmmInt (-n) rep)
cmmNegate e			  = CmmMachOp (MO_S_Neg (cmmExprWidth e)) [e]

blankWord :: CmmStatic
blankWord = CmmUninitialised wORD_SIZE

316 317
---------------------------------------------------
--
318
--	CmmExpr predicates
319 320 321
--
---------------------------------------------------

322 323 324 325 326 327 328
isTrivialCmmExpr :: CmmExpr -> Bool
isTrivialCmmExpr (CmmLoad _ _)   = False
isTrivialCmmExpr (CmmMachOp _ _) = False
isTrivialCmmExpr (CmmLit _)      = True
isTrivialCmmExpr (CmmReg _)      = True
isTrivialCmmExpr (CmmRegOff _ _) = True
isTrivialCmmExpr (CmmStackSlot _ _) = panic "isTrivialCmmExpr CmmStackSlot"
329

330 331 332 333 334 335 336
hasNoGlobalRegs :: CmmExpr -> Bool
hasNoGlobalRegs (CmmLoad e _)   	   = hasNoGlobalRegs e
hasNoGlobalRegs (CmmMachOp _ es) 	   = all hasNoGlobalRegs es
hasNoGlobalRegs (CmmLit _)      	   = True
hasNoGlobalRegs (CmmReg (CmmLocal _))      = True
hasNoGlobalRegs (CmmRegOff (CmmLocal _) _) = True
hasNoGlobalRegs _ = False
337

338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404
---------------------------------------------------
--
--	Tagging
--
---------------------------------------------------

-- Tag bits mask
--cmmTagBits = CmmLit (mkIntCLit tAG_BITS)
cmmTagMask, cmmPointerMask :: CmmExpr
cmmTagMask = CmmLit (mkIntCLit tAG_MASK)
cmmPointerMask = CmmLit (mkIntCLit (complement tAG_MASK))

-- Used to untag a possibly tagged pointer
-- A static label need not be untagged
cmmUntag, cmmGetTag :: CmmExpr -> CmmExpr
cmmUntag e@(CmmLit (CmmLabel _)) = e
-- Default case
cmmUntag e = (e `cmmAndWord` cmmPointerMask)

cmmGetTag e = (e `cmmAndWord` cmmTagMask)

-- Test if a closure pointer is untagged
cmmIsTagged :: CmmExpr -> CmmExpr
cmmIsTagged e = (e `cmmAndWord` cmmTagMask)
                 `cmmNeWord` CmmLit zeroCLit

cmmConstrTag, cmmConstrTag1 :: CmmExpr -> CmmExpr
cmmConstrTag e = (e `cmmAndWord` cmmTagMask) `cmmSubWord` (CmmLit (mkIntCLit 1))
-- Get constructor tag, but one based.
cmmConstrTag1 e = e `cmmAndWord` cmmTagMask


--------------------------------------------
--
--        mkLiveness
--
---------------------------------------------

mkLiveness :: [Maybe LocalReg] -> Liveness
mkLiveness [] = []
mkLiveness (reg:regs) 
  = take sizeW bits ++ mkLiveness regs 
  where
    sizeW = case reg of
              Nothing -> 1
              Just r -> (widthInBytes (typeWidth (localRegType r)) + wORD_SIZE - 1)
                        `quot` wORD_SIZE
                        -- number of words, rounded up
    bits = repeat $ is_non_ptr reg -- True <=> Non Ptr

    is_non_ptr Nothing    = True
    is_non_ptr (Just reg) = not $ isGcPtrType (localRegType reg)


-- ============================================== -
-- ============================================== -
-- ============================================== -

---------------------------------------------------
--
--      Manipulating CmmGraphs
--
---------------------------------------------------

modifyGraph :: (Graph n C C -> Graph n' C C) -> GenCmmGraph n -> GenCmmGraph n'
modifyGraph f g = CmmGraph {g_entry=g_entry g, g_graph=f (g_graph g)}

405
toBlockMap :: CmmGraph -> BlockEnv CmmBlock
406 407
toBlockMap (CmmGraph {g_graph=GMany NothingO body NothingO}) = body

408
ofBlockMap :: BlockId -> BlockEnv CmmBlock -> CmmGraph
409 410
ofBlockMap entry bodyMap = CmmGraph {g_entry=entry, g_graph=GMany NothingO bodyMap NothingO}

411
insertBlock :: CmmBlock -> BlockEnv CmmBlock -> BlockEnv CmmBlock
412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433
insertBlock block map =
  ASSERT (isNothing $ mapLookup id map)
  mapInsert id block map
  where id = entryLabel block

toBlockList :: CmmGraph -> [CmmBlock]
toBlockList g = mapElems $ toBlockMap g

ofBlockList :: BlockId -> [CmmBlock] -> CmmGraph
ofBlockList entry blocks = CmmGraph {g_entry=entry, g_graph=GMany NothingO body NothingO}
  where body = foldr addBlock emptyBody blocks

bodyToBlockList :: Body CmmNode -> [CmmBlock]
bodyToBlockList body = mapElems body

mapGraphNodes :: ( CmmNode C O -> CmmNode C O
                 , CmmNode O O -> CmmNode O O
                 , CmmNode O C -> CmmNode O C)
              -> CmmGraph -> CmmGraph
mapGraphNodes funs@(mf,_,_) g =
  ofBlockMap (entryLabel $ mf $ CmmEntry $ g_entry g) $ mapMap (blockMapNodes3 funs) $ toBlockMap g

434 435 436 437
mapGraphNodes1 :: (forall e x. CmmNode e x -> CmmNode e x) -> CmmGraph -> CmmGraph
mapGraphNodes1 f g = modifyGraph (graphMapBlocks (blockMapNodes f)) g


438 439 440 441
foldGraphBlocks :: (CmmBlock -> a -> a) -> a -> CmmGraph -> a
foldGraphBlocks k z g = mapFold k z $ toBlockMap g

postorderDfs :: CmmGraph -> [CmmBlock]
Simon Marlow's avatar
Simon Marlow committed
442
postorderDfs g = {-# SCC "postorderDfs" #-} postorder_dfs_from (toBlockMap g) (g_entry g)
443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490

----------------------------------------------------------------------
----- Splicing between blocks
-- Given a middle node, a block, and a successor BlockId,
-- we can insert the middle node between the block and the successor.
-- We return the updated block and a list of new blocks that must be added
-- to the graph.
-- The semantics is a bit tricky. We consider cases on the last node:
-- o For a branch, we can just insert before the branch,
--   but sometimes the optimizer does better if we actually insert
--   a fresh basic block, enabling some common blockification.
-- o For a conditional branch, switch statement, or call, we must insert
--   a new basic block.
-- o For a jump or return, this operation is impossible.

insertBetween :: MonadUnique m => CmmBlock -> [CmmNode O O] -> BlockId -> m (CmmBlock, [CmmBlock])
insertBetween b ms succId = insert $ lastNode b
  where insert :: MonadUnique m => CmmNode O C -> m (CmmBlock, [CmmBlock])
        insert (CmmBranch bid) =
          if bid == succId then
            do (bid', bs) <- newBlocks
               return (replaceLastNode b (CmmBranch bid'), bs)
          else panic "tried invalid block insertBetween"
        insert (CmmCondBranch c t f) =
          do (t', tbs) <- if t == succId then newBlocks else return $ (t, [])
             (f', fbs) <- if f == succId then newBlocks else return $ (f, [])
             return (replaceLastNode b (CmmCondBranch c t' f'), tbs ++ fbs)
        insert (CmmSwitch e ks) =
          do (ids, bs) <- mapAndUnzipM mbNewBlocks ks
             return (replaceLastNode b (CmmSwitch e ids), join bs)
        insert (CmmCall {}) =
          panic "unimp: insertBetween after a call -- probably not a good idea"
        insert (CmmForeignCall {}) =
          panic "unimp: insertBetween after a foreign call -- probably not a good idea"

        newBlocks :: MonadUnique m => m (BlockId, [CmmBlock])
        newBlocks = do id <- liftM mkBlockId $ getUniqueM
                       return $ (id, [blockOfNodeList (JustC (CmmEntry id), ms, JustC (CmmBranch succId))])
        mbNewBlocks :: MonadUnique m => Maybe BlockId -> m (Maybe BlockId, [CmmBlock])
        mbNewBlocks (Just k) = if k == succId then liftM fstJust newBlocks
                               else return (Just k, [])
        mbNewBlocks Nothing  = return (Nothing, [])
        fstJust (id, bs) = (Just id, bs)

-------------------------------------------------
-- Running dataflow analysis and/or rewrites

-- Constructing forward and backward analysis-only pass
Simon Marlow's avatar
Simon Marlow committed
491 492
analFwd    :: DataflowLattice f -> FwdTransfer n f -> FwdPass FuelUniqSM n f
analBwd    :: DataflowLattice f -> BwdTransfer n f -> BwdPass FuelUniqSM n f
493 494 495 496 497

analFwd lat xfer = analRewFwd lat xfer noFwdRewrite
analBwd lat xfer = analRewBwd lat xfer noBwdRewrite

-- Constructing forward and backward analysis + rewrite pass
Simon Marlow's avatar
Simon Marlow committed
498 499 500 501 502 503 504 505
analRewFwd :: DataflowLattice f -> FwdTransfer n f
           -> FwdRewrite FuelUniqSM n f
           -> FwdPass FuelUniqSM n f

analRewBwd :: DataflowLattice f
           -> BwdTransfer n f
           -> BwdRewrite FuelUniqSM n f
           -> BwdPass FuelUniqSM n f
506 507 508 509 510

analRewFwd lat xfer rew = FwdPass {fp_lattice = lat, fp_transfer = xfer, fp_rewrite = rew}
analRewBwd lat xfer rew = BwdPass {bp_lattice = lat, bp_transfer = xfer, bp_rewrite = rew}

-- Running forward and backward dataflow analysis + optional rewrite
Simon Marlow's avatar
Simon Marlow committed
511 512 513 514
dataflowPassFwd :: NonLocal n =>
                   GenCmmGraph n -> [(BlockId, f)]
                -> FwdPass FuelUniqSM n f
                -> FuelUniqSM (GenCmmGraph n, BlockEnv f)
515 516 517 518
dataflowPassFwd (CmmGraph {g_entry=entry, g_graph=graph}) facts fwd = do
  (graph, facts, NothingO) <- analyzeAndRewriteFwd fwd (JustC [entry]) graph (mkFactBase (fp_lattice fwd) facts)
  return (CmmGraph {g_entry=entry, g_graph=graph}, facts)

Simon Marlow's avatar
Simon Marlow committed
519 520 521 522 523 524 525 526 527
dataflowAnalFwd :: NonLocal n =>
                   GenCmmGraph n -> [(BlockId, f)]
                -> FwdPass FuelUniqSM n f
                -> FuelUniqSM (BlockEnv f)
dataflowAnalFwd (CmmGraph {g_entry=entry, g_graph=graph}) facts fwd = do
--  (graph, facts, NothingO) <- analyzeAndRewriteFwd fwd (JustC [entry]) graph (mkFactBase (fp_lattice fwd) facts)
--  return facts
  return (analyzeFwd fwd (JustC [entry]) graph (mkFactBase (fp_lattice fwd) facts))

Simon Marlow's avatar
Simon Marlow committed
528 529 530 531 532 533 534 535 536
dataflowAnalFwdBlocks :: NonLocal n =>
                   GenCmmGraph n -> [(BlockId, f)]
                -> FwdPass FuelUniqSM n f
                -> FuelUniqSM (BlockEnv f)
dataflowAnalFwdBlocks (CmmGraph {g_entry=entry, g_graph=graph}) facts fwd = do
--  (graph, facts, NothingO) <- analyzeAndRewriteFwd fwd (JustC [entry]) graph (mkFactBase (fp_lattice fwd) facts)
--  return facts
  return (analyzeFwdBlocks fwd (JustC [entry]) graph (mkFactBase (fp_lattice fwd) facts))

Simon Marlow's avatar
Simon Marlow committed
537 538 539 540 541 542 543 544 545 546 547 548 549
dataflowAnalBwd :: NonLocal n =>
                   GenCmmGraph n -> [(BlockId, f)]
                -> BwdPass FuelUniqSM n f
                -> FuelUniqSM (BlockEnv f)
dataflowAnalBwd (CmmGraph {g_entry=entry, g_graph=graph}) facts bwd = do
--  (graph, facts, NothingO) <- analyzeAndRewriteBwd fwd (JustC [entry]) graph (mkFactBase (fp_lattice fwd) facts)
--  return facts
  return (analyzeBwd bwd (JustC [entry]) graph (mkFactBase (bp_lattice bwd) facts))

dataflowPassBwd :: NonLocal n =>
                   GenCmmGraph n -> [(BlockId, f)]
                -> BwdPass FuelUniqSM n f
                -> FuelUniqSM (GenCmmGraph n, BlockEnv f)
550 551 552
dataflowPassBwd (CmmGraph {g_entry=entry, g_graph=graph}) facts bwd = do
  (graph, facts, NothingO) <- analyzeAndRewriteBwd bwd (JustC [entry]) graph (mkFactBase (bp_lattice bwd) facts)
  return (CmmGraph {g_entry=entry, g_graph=graph}, facts)