Occurrrence analysis improvements for NOINLINE functions
[ghc.git] / hadrian / src / Way.hs
1 module Way (
2 WayUnit (..), Way, wayUnit, removeWayUnit, wayFromUnits, allWays,
3
4 vanilla, profiling, dynamic, profilingDynamic, threaded, debug, logging,
5 threadedDebug, threadedProfiling, threadedLogging, threadedDynamic,
6 threadedDebugProfiling, threadedDebugDynamic, threadedProfilingDynamic,
7 threadedLoggingDynamic, debugProfiling, debugDynamic, loggingDynamic,
8
9 wayPrefix, waySuffix, hisuf, osuf, hcsuf, obootsuf, hibootsuf, ssuf
10 ) where
11
12 import Data.IntSet (IntSet)
13 import qualified Data.IntSet as Set
14 import Data.List
15 import Data.Maybe
16 import Development.Shake.Classes
17 import Hadrian.Utilities
18
19 -- Note: order of constructors is important for compatibility with the old build
20 -- system, e.g. we want "thr_p", not "p_thr" (see instance Show Way).
21 -- | A 'WayUnit' is a single way of building source code, for example with
22 -- profiling enabled, or dynamically linked.
23 data WayUnit = Threaded
24 | Debug
25 | Profiling
26 | Logging
27 | Dynamic
28 deriving (Bounded, Enum, Eq, Ord)
29
30 -- TODO: get rid of non-derived Show instances
31 instance Show WayUnit where
32 show unit = case unit of
33 Threaded -> "thr"
34 Debug -> "debug"
35 Profiling -> "p"
36 Logging -> "l"
37 Dynamic -> "dyn"
38
39 instance Read WayUnit where
40 readsPrec _ s = [(unit, "") | unit <- [minBound ..], show unit == s]
41
42 -- | Collection of 'WayUnit's that stands for the different ways source code
43 -- is to be built.
44 newtype Way = Way IntSet
45
46 instance Binary Way where
47 put = put . show
48 get = fmap read get
49
50 instance Hashable Way where
51 hashWithSalt salt = hashWithSalt salt . show
52
53 instance NFData Way where
54 rnf (Way s) = s `seq` ()
55
56 -- | Construct a 'Way' from multiple 'WayUnit's. Inverse of 'wayToUnits'.
57 wayFromUnits :: [WayUnit] -> Way
58 wayFromUnits = Way . Set.fromList . map fromEnum
59
60 -- | Split a 'Way' into its 'WayUnit' building blocks.
61 -- Inverse of 'wayFromUnits'.
62 wayToUnits :: Way -> [WayUnit]
63 wayToUnits (Way set) = map toEnum . Set.elems $ set
64
65 -- | Check whether a 'Way' contains a certain 'WayUnit'.
66 wayUnit :: WayUnit -> Way -> Bool
67 wayUnit unit (Way set) = fromEnum unit `Set.member` set
68
69 -- | Remove a 'WayUnit' from 'Way'.
70 removeWayUnit :: WayUnit -> Way -> Way
71 removeWayUnit unit (Way set) = Way . Set.delete (fromEnum unit) $ set
72
73 instance Show Way where
74 show way = if null tag then "v" else tag
75 where
76 tag = intercalate "_" . map show . wayToUnits $ way
77
78 instance Read Way where
79 readsPrec _ s = if s == "v" then [(vanilla, "")] else result
80 where
81 uniqueReads token = case reads token of
82 [(unit, "")] -> Just unit
83 _ -> Nothing
84 units = map uniqueReads . words . replaceEq '_' ' ' $ s
85 result = if Nothing `elem` units
86 then []
87 else [(wayFromUnits . map fromJust $ units, "")]
88
89 instance Eq Way where
90 Way a == Way b = a == b
91
92 instance Ord Way where
93 compare (Way a) (Way b) = compare a b
94
95 -- | Build default _vanilla_ way.
96 vanilla :: Way
97 vanilla = wayFromUnits []
98
99 -- | Build with profiling.
100 profiling :: Way
101 profiling = wayFromUnits [Profiling]
102
103 -- | Build with dynamic linking.
104 dynamic :: Way
105 dynamic = wayFromUnits [Dynamic]
106
107 -- | Build with profiling and dynamic linking.
108 profilingDynamic :: Way
109 profilingDynamic = wayFromUnits [Profiling, Dynamic]
110
111 -- RTS only ways below. See compiler/main/DynFlags.hs.
112 -- | Build RTS with event logging.
113 logging :: Way
114 logging = wayFromUnits [Logging]
115
116 -- | Build multithreaded RTS.
117 threaded :: Way
118 threaded = wayFromUnits [Threaded]
119
120 -- | Build RTS with debug information.
121 debug :: Way
122 debug = wayFromUnits [Debug]
123
124 -- | Various combinations of RTS only ways.
125 threadedDebug, threadedProfiling, threadedLogging, threadedDynamic,
126 threadedDebugProfiling, threadedDebugDynamic, threadedProfilingDynamic,
127 threadedLoggingDynamic, debugProfiling, debugDynamic, loggingDynamic :: Way
128 threadedDebug = wayFromUnits [Threaded, Debug]
129 threadedProfiling = wayFromUnits [Threaded, Profiling]
130 threadedLogging = wayFromUnits [Threaded, Logging]
131 threadedDynamic = wayFromUnits [Threaded, Dynamic]
132 threadedDebugProfiling = wayFromUnits [Threaded, Debug, Profiling]
133 threadedDebugDynamic = wayFromUnits [Threaded, Debug, Dynamic]
134 threadedProfilingDynamic = wayFromUnits [Threaded, Profiling, Dynamic]
135 threadedLoggingDynamic = wayFromUnits [Threaded, Logging, Dynamic]
136 debugProfiling = wayFromUnits [Debug, Profiling]
137 debugDynamic = wayFromUnits [Debug, Dynamic]
138 loggingDynamic = wayFromUnits [Logging, Dynamic]
139
140 -- | All ways supported by the build system.
141 allWays :: [Way]
142 allWays =
143 [ vanilla, profiling, dynamic, profilingDynamic, threaded, debug, logging
144 , threadedDebug, threadedProfiling, threadedLogging, threadedDynamic
145 , threadedDebugProfiling, threadedDebugDynamic, threadedProfilingDynamic
146 , threadedLoggingDynamic, debugProfiling, debugDynamic, loggingDynamic ]
147
148 wayPrefix :: Way -> String
149 wayPrefix way | way == vanilla = ""
150 | otherwise = show way ++ "_"
151
152 waySuffix :: Way -> String
153 waySuffix way | way == vanilla = ""
154 | otherwise = "_" ++ show way
155
156 osuf, ssuf, hisuf, hcsuf, obootsuf, hibootsuf :: Way -> String
157 osuf = (++ "o" ) . wayPrefix
158 ssuf = (++ "s" ) . wayPrefix
159 hisuf = (++ "hi" ) . wayPrefix
160 hcsuf = (++ "hc" ) . wayPrefix
161 obootsuf = (++ "o-boot" ) . wayPrefix
162 hibootsuf = (++ "hi-boot") . wayPrefix