compiler/cmm/BlockId.hs

   1 module BlockId
   2   ( BlockId(..), mkBlockId      -- ToDo: BlockId should be abstract, but it isn't yet
   3   , BlockEnv, emptyBlockEnv, elemBlockEnv, lookupBlockEnv, extendBlockEnv
   4   , mkBlockEnv, mapBlockEnv
   5   , eltsBlockEnv, plusBlockEnv, delFromBlockEnv, blockEnvToList, lookupWithDefaultBEnv
   6   , isNullBEnv, sizeBEnv, foldBlockEnv, foldBlockEnv', addToBEnv_Acc
   7   , BlockSet, emptyBlockSet, unitBlockSet, isEmptyBlockSet
   8   , elemBlockSet, extendBlockSet, sizeBlockSet, unionBlockSets
   9   , removeBlockSet, mkBlockSet, blockSetToList, foldBlockSet
  10   , blockLbl, infoTblLbl, retPtLbl
  11   ) where
  12
  13 import CLabel
  14 import IdInfo
  15 import Maybes
  16 import Name
  17 import Outputable
  18 import UniqFM
  19 import Unique
  20 import UniqSet
  21
  22 ----------------------------------------------------------------
  23 --- Block Ids, their environments, and their sets
  24
  25 {- Note [Unique BlockId]
  26 ~~~~~~~~~~~~~~~~~~~~~~~~
  27 Although a 'BlockId' is a local label, for reasons of implementation,
  28 'BlockId's must be unique within an entire compilation unit.  The reason
  29 is that each local label is mapped to an assembly-language label, and in
  30 most assembly languages allow, a label is visible throughout the entire
  31 compilation unit in which it appears.
  32 -}
  33
  34 data BlockId = BlockId Unique
  35   deriving (Eq,Ord)
  36
  37 instance Uniquable BlockId where
  38   getUnique (BlockId id) = id
  39
  40 mkBlockId :: Unique -> BlockId
  41 mkBlockId uniq = BlockId uniq
  42
  43 instance Show BlockId where
  44   show (BlockId u) = show u
  45
  46 instance Outputable BlockId where
  47   ppr (BlockId id) = ppr id
  48
  49 retPtLbl :: BlockId -> CLabel
  50 retPtLbl (BlockId id) = mkReturnPtLabel id
  51
  52 blockLbl :: BlockId -> CLabel
  53 blockLbl (BlockId id) = mkEntryLabel (mkFCallName id "block") NoCafRefs
  54
  55 infoTblLbl :: BlockId -> CLabel
  56 infoTblLbl (BlockId id) = mkInfoTableLabel (mkFCallName id "block") NoCafRefs
  57
  58 -- Block environments: Id blocks
  59 newtype BlockEnv a = BlockEnv (UniqFM {- id -} a)
  60
  61 instance Outputable a => Outputable (BlockEnv a) where
  62   ppr (BlockEnv env) = ppr env
  63
  64 -- This is pretty horrid. There must be common patterns here that can be
  65 -- abstracted into wrappers.
  66 emptyBlockEnv :: BlockEnv a
  67 emptyBlockEnv = BlockEnv emptyUFM
  68
  69 isNullBEnv :: BlockEnv a -> Bool
  70 isNullBEnv (BlockEnv env) = isNullUFM env
  71
  72 sizeBEnv :: BlockEnv a -> Int
  73 sizeBEnv (BlockEnv env)  = sizeUFM env
  74
  75 mkBlockEnv :: [(BlockId,a)] -> BlockEnv a
  76 mkBlockEnv = foldl (uncurry . extendBlockEnv) emptyBlockEnv
  77
  78 eltsBlockEnv :: BlockEnv elt -> [elt]
  79 eltsBlockEnv (BlockEnv env) = eltsUFM env
  80
  81 delFromBlockEnv :: BlockEnv elt -> BlockId -> BlockEnv elt
  82 delFromBlockEnv   (BlockEnv env) (BlockId id) = BlockEnv (delFromUFM env id)
  83
  84 lookupBlockEnv :: BlockEnv a -> BlockId -> Maybe a
  85 lookupBlockEnv (BlockEnv env) (BlockId id) = lookupUFM env id
  86
  87 elemBlockEnv :: BlockEnv a -> BlockId -> Bool
  88 elemBlockEnv (BlockEnv env) (BlockId id) = isJust $ lookupUFM env id
  89
  90 lookupWithDefaultBEnv :: BlockEnv a -> a -> BlockId -> a
  91 lookupWithDefaultBEnv env x id = lookupBlockEnv env id `orElse` x
  92
  93 extendBlockEnv :: BlockEnv a -> BlockId -> a -> BlockEnv a
  94 extendBlockEnv (BlockEnv env) (BlockId id) x = BlockEnv (addToUFM env id x)
  95
  96 mapBlockEnv :: (a -> b) -> BlockEnv a -> BlockEnv b
  97 mapBlockEnv f (BlockEnv env) = BlockEnv (mapUFM f env)
  98
  99 foldBlockEnv :: (BlockId -> a -> b -> b) -> b -> BlockEnv a -> b
 100 foldBlockEnv f b (BlockEnv env) =
 101   foldUFM_Directly (\u x y -> f (mkBlockId u) x y) b env
 102
 103 foldBlockEnv' :: (a -> b -> b) -> b -> BlockEnv a -> b
 104 foldBlockEnv' f b (BlockEnv env) = foldUFM f b env
 105
 106 plusBlockEnv :: BlockEnv elt -> BlockEnv elt -> BlockEnv elt
 107 plusBlockEnv (BlockEnv x) (BlockEnv y) = BlockEnv (plusUFM x y)
 108
 109 blockEnvToList :: BlockEnv elt -> [(BlockId, elt)]
 110 blockEnvToList (BlockEnv env) =
 111   map (\ (id, elt) -> (BlockId id, elt)) $ ufmToList env
 112
 113 addToBEnv_Acc   :: (elt -> elts -> elts)        -- Add to existing
 114                            -> (elt -> elts)             -- New element
 115                            -> BlockEnv elts             -- old
 116                            -> BlockId -> elt            -- new
 117                            -> BlockEnv elts             -- result
 118 addToBEnv_Acc add new (BlockEnv old) (BlockId k) v =
 119   BlockEnv (addToUFM_Acc add new old k v)
 120   -- I believe this is only used by obsolete code.
 121
 122
 123 newtype BlockSet = BlockSet (UniqSet Unique)
 124 instance Outputable BlockSet where
 125   ppr (BlockSet set) = ppr set
 126
 127
 128 emptyBlockSet :: BlockSet
 129 emptyBlockSet = BlockSet emptyUniqSet
 130
 131 isEmptyBlockSet :: BlockSet -> Bool
 132 isEmptyBlockSet (BlockSet s) = isEmptyUniqSet s
 133
 134 unitBlockSet :: BlockId -> BlockSet
 135 unitBlockSet = extendBlockSet emptyBlockSet
 136
 137 elemBlockSet :: BlockId -> BlockSet -> Bool
 138 elemBlockSet (BlockId id) (BlockSet set) = elementOfUniqSet id set
 139
 140 extendBlockSet :: BlockSet -> BlockId -> BlockSet
 141 extendBlockSet (BlockSet set) (BlockId id) = BlockSet (addOneToUniqSet set id)
 142
 143 removeBlockSet :: BlockSet -> BlockId -> BlockSet
 144 removeBlockSet (BlockSet set) (BlockId id) = BlockSet (delOneFromUniqSet set id)
 145
 146 mkBlockSet :: [BlockId] -> BlockSet
 147 mkBlockSet = foldl extendBlockSet emptyBlockSet
 148
 149 unionBlockSets :: BlockSet -> BlockSet -> BlockSet
 150 unionBlockSets (BlockSet s) (BlockSet s') = BlockSet (unionUniqSets s s')
 151
 152 sizeBlockSet :: BlockSet -> Int
 153 sizeBlockSet (BlockSet set) = sizeUniqSet set
 154
 155 blockSetToList :: BlockSet -> [BlockId]
 156 blockSetToList (BlockSet set) = map BlockId $ uniqSetToList set
 157
 158 foldBlockSet :: (BlockId -> b -> b) -> b -> BlockSet -> b
 159 foldBlockSet f z (BlockSet set) = foldUniqSet (f . BlockId) z set