Fix #11407.
[ghc.git] / compiler / cmm / BlockId.hs
1 {-# LANGUAGE TypeSynonymInstances #-}
2 {-# OPTIONS_GHC -fno-warn-orphans #-}
3
4 {- BlockId module should probably go away completely, being superseded by Label -}
5 module BlockId
6 ( BlockId, mkBlockId -- ToDo: BlockId should be abstract, but it isn't yet
7 , BlockSet, BlockEnv
8 , IsSet(..), setInsertList, setDeleteList, setUnions
9 , IsMap(..), mapInsertList, mapDeleteList, mapUnions
10 , emptyBlockSet, emptyBlockMap
11 , blockLbl, infoTblLbl, retPtLbl
12 ) where
13
14 import CLabel
15 import IdInfo
16 import Name
17 import Outputable
18 import Unique
19
20 import Compiler.Hoopl as Hoopl hiding (Unique)
21 import Compiler.Hoopl.Internals (uniqueToLbl, lblToUnique)
22
23 ----------------------------------------------------------------
24 --- Block Ids, their environments, and their sets
25
26 {- Note [Unique BlockId]
27 ~~~~~~~~~~~~~~~~~~~~~~~~
28 Although a 'BlockId' is a local label, for reasons of implementation,
29 'BlockId's must be unique within an entire compilation unit. The reason
30 is that each local label is mapped to an assembly-language label, and in
31 most assembly languages allow, a label is visible throughout the entire
32 compilation unit in which it appears.
33 -}
34
35 type BlockId = Hoopl.Label
36
37 instance Uniquable BlockId where
38 getUnique label = getUnique (lblToUnique label)
39
40 instance Outputable BlockId where
41 ppr label = ppr (getUnique label)
42
43 mkBlockId :: Unique -> BlockId
44 mkBlockId unique = uniqueToLbl $ intToUnique $ getKey unique
45
46 retPtLbl :: BlockId -> CLabel
47 retPtLbl label = mkReturnPtLabel $ getUnique label
48
49 blockLbl :: BlockId -> CLabel
50 blockLbl label = mkEntryLabel (mkFCallName (getUnique label) "block") NoCafRefs
51
52 infoTblLbl :: BlockId -> CLabel
53 infoTblLbl label = mkInfoTableLabel (mkFCallName (getUnique label) "block") NoCafRefs
54
55 -- Block environments: Id blocks
56 type BlockEnv a = Hoopl.LabelMap a
57
58 instance Outputable a => Outputable (BlockEnv a) where
59 ppr = ppr . mapToList
60
61 emptyBlockMap :: BlockEnv a
62 emptyBlockMap = mapEmpty
63
64 -- Block sets
65 type BlockSet = Hoopl.LabelSet
66
67 instance Outputable BlockSet where
68 ppr = ppr . setElems
69
70 emptyBlockSet :: BlockSet
71 emptyBlockSet = setEmpty