/ghc-7.0.4/compiler/cmm/BlockId.hs

module BlockId
  ( BlockId(..), mkBlockId 	-- ToDo: BlockId should be abstract, but it isn't yet
  , BlockEnv, emptyBlockEnv, elemBlockEnv, lookupBlockEnv, extendBlockEnv
  , mkBlockEnv, mapBlockEnv
  , eltsBlockEnv, plusBlockEnv, delFromBlockEnv, blockEnvToList, lookupWithDefaultBEnv
  , isNullBEnv, sizeBEnv, foldBlockEnv, foldBlockEnv', addToBEnv_Acc
  , BlockSet, emptyBlockSet, unitBlockSet, isEmptyBlockSet
  , elemBlockSet, extendBlockSet, sizeBlockSet, unionBlockSets
  , removeBlockSet, mkBlockSet, blockSetToList, foldBlockSet
  , blockLbl, infoTblLbl, retPtLbl
  ) where

import CLabel
import IdInfo
import Maybes
import Name
import Outputable
import UniqFM
import Unique
import UniqSet

----------------------------------------------------------------
--- Block Ids, their environments, and their sets

{- Note [Unique BlockId]
~~~~~~~~~~~~~~~~~~~~~~~~
Although a 'BlockId' is a local label, for reasons of implementation,
'BlockId's must be unique within an entire compilation unit.  The reason
is that each local label is mapped to an assembly-language label, and in
most assembly languages allow, a label is visible throughout the entire
compilation unit in which it appears.
-}

data BlockId = BlockId Unique
  deriving (Eq,Ord)

instance Uniquable BlockId where
  getUnique (BlockId id) = id

mkBlockId :: Unique -> BlockId
mkBlockId uniq = BlockId uniq

instance Show BlockId where
  show (BlockId u) = show u

instance Outputable BlockId where
  ppr (BlockId id) = ppr id

retPtLbl :: BlockId -> CLabel
retPtLbl (BlockId id) = mkReturnPtLabel id

blockLbl :: BlockId -> CLabel
blockLbl (BlockId id) = mkEntryLabel (mkFCallName id "block") NoCafRefs

infoTblLbl :: BlockId -> CLabel
infoTblLbl (BlockId id) = mkInfoTableLabel (mkFCallName id "block") NoCafRefs

-- Block environments: Id blocks
newtype BlockEnv a = BlockEnv (UniqFM {- id -} a)

instance Outputable a => Outputable (BlockEnv a) where
  ppr (BlockEnv env) = ppr env

-- This is pretty horrid. There must be common patterns here that can be
-- abstracted into wrappers.
emptyBlockEnv :: BlockEnv a
emptyBlockEnv = BlockEnv emptyUFM

isNullBEnv :: BlockEnv a -> Bool
isNullBEnv (BlockEnv env) = isNullUFM env

sizeBEnv :: BlockEnv a -> Int
sizeBEnv (BlockEnv env)  = sizeUFM env

mkBlockEnv :: [(BlockId,a)] -> BlockEnv a
mkBlockEnv = foldl (uncurry . extendBlockEnv) emptyBlockEnv

eltsBlockEnv :: BlockEnv elt -> [elt]
eltsBlockEnv (BlockEnv env) = eltsUFM env

delFromBlockEnv	:: BlockEnv elt -> BlockId -> BlockEnv elt
delFromBlockEnv	  (BlockEnv env) (BlockId id) = BlockEnv (delFromUFM env id)

lookupBlockEnv :: BlockEnv a -> BlockId -> Maybe a
lookupBlockEnv (BlockEnv env) (BlockId id) = lookupUFM env id

elemBlockEnv :: BlockEnv a -> BlockId -> Bool
elemBlockEnv (BlockEnv env) (BlockId id) = isJust $ lookupUFM env id

lookupWithDefaultBEnv :: BlockEnv a -> a -> BlockId -> a
lookupWithDefaultBEnv env x id = lookupBlockEnv env id `orElse` x

extendBlockEnv :: BlockEnv a -> BlockId -> a -> BlockEnv a
extendBlockEnv (BlockEnv env) (BlockId id) x = BlockEnv (addToUFM env id x)

mapBlockEnv :: (a -> b) -> BlockEnv a -> BlockEnv b
mapBlockEnv f (BlockEnv env) = BlockEnv (mapUFM f env)

foldBlockEnv :: (BlockId -> a -> b -> b) -> b -> BlockEnv a -> b
foldBlockEnv f b (BlockEnv env) = 
  foldUFM_Directly (\u x y -> f (mkBlockId u) x y) b env

foldBlockEnv' :: (a -> b -> b) -> b -> BlockEnv a -> b
foldBlockEnv' f b (BlockEnv env) = foldUFM f b env

plusBlockEnv :: BlockEnv elt -> BlockEnv elt -> BlockEnv elt
plusBlockEnv (BlockEnv x) (BlockEnv y) = BlockEnv (plusUFM x y)

blockEnvToList :: BlockEnv elt -> [(BlockId, elt)]
blockEnvToList (BlockEnv env) =
  map (\ (id, elt) -> (BlockId id, elt)) $ ufmToList env

addToBEnv_Acc	:: (elt -> elts -> elts)	-- Add to existing
			   -> (elt -> elts)		-- New element
			   -> BlockEnv elts 		-- old
			   -> BlockId -> elt 		-- new
			   -> BlockEnv elts		-- result
addToBEnv_Acc add new (BlockEnv old) (BlockId k) v =
  BlockEnv (addToUFM_Acc add new old k v)
  -- I believe this is only used by obsolete code.


newtype BlockSet = BlockSet (UniqSet Unique)
instance Outputable BlockSet where
  ppr (BlockSet set) = ppr set


emptyBlockSet :: BlockSet
emptyBlockSet = BlockSet emptyUniqSet

isEmptyBlockSet :: BlockSet -> Bool
isEmptyBlockSet (BlockSet s) = isEmptyUniqSet s

unitBlockSet :: BlockId -> BlockSet
unitBlockSet = extendBlockSet emptyBlockSet

elemBlockSet :: BlockId -> BlockSet -> Bool
elemBlockSet (BlockId id) (BlockSet set) = elementOfUniqSet id set

extendBlockSet :: BlockSet -> BlockId -> BlockSet
extendBlockSet (BlockSet set) (BlockId id) = BlockSet (addOneToUniqSet set id)

removeBlockSet :: BlockSet -> BlockId -> BlockSet
removeBlockSet (BlockSet set) (BlockId id) = BlockSet (delOneFromUniqSet set id)

mkBlockSet :: [BlockId] -> BlockSet
mkBlockSet = foldl extendBlockSet emptyBlockSet

unionBlockSets :: BlockSet -> BlockSet -> BlockSet
unionBlockSets (BlockSet s) (BlockSet s') = BlockSet (unionUniqSets s s')

sizeBlockSet :: BlockSet -> Int
sizeBlockSet (BlockSet set) = sizeUniqSet set

blockSetToList :: BlockSet -> [BlockId]
blockSetToList (BlockSet set) = map BlockId $ uniqSetToList set

foldBlockSet :: (BlockId -> b -> b) -> b -> BlockSet -> b
foldBlockSet f z (BlockSet set) = foldUniqSet (f . BlockId) z set