9f7f12a114eb7e1e3ccc85f69f028055f104f5fb
[hadrian.git] / src / Way.hs
1 module Way (
2 WayUnit (..), Way, wayUnit,
3
4 vanilla, profiling, logging, parallel, granSim,
5 threaded, threadedProfiling, threadedLogging,
6 debug, debugProfiling, threadedDebug, threadedDebugProfiling,
7 dynamic, profilingDynamic, threadedProfilingDynamic,
8 threadedDynamic, threadedDebugDynamic, debugDynamic,
9 loggingDynamic, threadedLoggingDynamic,
10
11 wayPrefix, hisuf, osuf, hcsuf, obootsuf, hibootsuf, ssuf, libsuf,
12 safeDetectWay, detectWay, matchBuildResult
13 ) where
14
15 import Base hiding (unit)
16 import Data.IntSet (IntSet)
17 import qualified Data.IntSet as Set
18 import Oracles
19
20 -- Note: order of constructors is important for compatibility with the old build
21 -- system, e.g. we want "thr_p", not "p_thr" (see instance Show Way).
22 -- | A 'WayUnit' is a single way of building source code, for example with
23 -- profiling enabled, or dynamically linked.
24 data WayUnit = Threaded
25 | Debug
26 | Profiling
27 | Logging
28 | Dynamic
29 | Parallel
30 | GranSim
31 deriving (Eq, Enum, Bounded)
32
33 -- TODO: get rid of non-derived Show instances
34 instance Show WayUnit where
35 show unit = case unit of
36 Threaded -> "thr"
37 Debug -> "debug"
38 Profiling -> "p"
39 Logging -> "l"
40 Dynamic -> "dyn"
41 Parallel -> "mp"
42 GranSim -> "gm"
43
44 instance Read WayUnit where
45 readsPrec _ s = [(unit, "") | unit <- [minBound ..], show unit == s]
46
47 -- | Collection of 'WayUnit's that stands for the different ways source code
48 -- is to be built.
49 newtype Way = Way IntSet
50
51 -- | Construct a 'Way' from multiple 'WayUnit's. Inverse of 'wayToUnits'.
52 wayFromUnits :: [WayUnit] -> Way
53 wayFromUnits = Way . Set.fromList . map fromEnum
54
55 -- | Split a 'Way' into its 'WayUnit' building blocks.
56 -- Inverse of 'wayFromUnits'.
57 wayToUnits :: Way -> [WayUnit]
58 wayToUnits (Way set) = map toEnum . Set.elems $ set
59
60 -- | Check whether a 'Way' contains a certain 'WayUnit'.
61 wayUnit :: WayUnit -> Way -> Bool
62 wayUnit unit (Way set) = fromEnum unit `Set.member` set
63
64 instance Show Way where
65 show way = if null tag then "v" else tag
66 where
67 tag = intercalate "_" . map show . wayToUnits $ way
68
69 instance Read Way where
70 readsPrec _ s = if s == "v" then [(vanilla, "")] else result
71 where
72 uniqueReads token = case reads token of
73 [(unit, "")] -> Just unit
74 _ -> Nothing
75 units = map uniqueReads . words . replaceEq '_' ' ' $ s
76 result = if Nothing `elem` units
77 then []
78 else [(wayFromUnits . map fromJust $ units, "")]
79
80 instance Eq Way where
81 Way a == Way b = a == b
82
83 -- | Build with no 'WayUnit's at all.
84 vanilla :: Way
85 vanilla = wayFromUnits []
86
87 -- | Build with profiling.
88 profiling :: Way
89 profiling = wayFromUnits [Profiling]
90
91 -- | Build with logging.
92 logging :: Way
93 logging = wayFromUnits [Logging]
94
95 -- | Build in parallel.
96 parallel :: Way
97 parallel = wayFromUnits [Parallel]
98
99 granSim :: Way
100 granSim = wayFromUnits [GranSim]
101
102 -- RTS only ways
103 -- TODO: do we need to define *only* these? Shall we generalise/simplify?
104 threaded, threadedProfiling, threadedLogging, debug, debugProfiling,
105 threadedDebug, threadedDebugProfiling, dynamic, profilingDynamic,
106 threadedProfilingDynamic, threadedDynamic, threadedDebugDynamic,
107 debugDynamic, loggingDynamic, threadedLoggingDynamic :: Way
108
109 threaded = wayFromUnits [Threaded]
110 threadedProfiling = wayFromUnits [Threaded, Profiling]
111 threadedLogging = wayFromUnits [Threaded, Logging]
112 debug = wayFromUnits [Debug]
113 debugProfiling = wayFromUnits [Debug, Profiling]
114 threadedDebug = wayFromUnits [Threaded, Debug]
115 threadedDebugProfiling = wayFromUnits [Threaded, Debug, Profiling]
116 dynamic = wayFromUnits [Dynamic]
117 profilingDynamic = wayFromUnits [Profiling, Dynamic]
118 threadedProfilingDynamic = wayFromUnits [Threaded, Profiling, Dynamic]
119 threadedDynamic = wayFromUnits [Threaded, Dynamic]
120 threadedDebugDynamic = wayFromUnits [Threaded, Debug, Dynamic]
121 debugDynamic = wayFromUnits [Debug, Dynamic]
122 loggingDynamic = wayFromUnits [Logging, Dynamic]
123 threadedLoggingDynamic = wayFromUnits [Threaded, Logging, Dynamic]
124
125 wayPrefix :: Way -> String
126 wayPrefix way | way == vanilla = ""
127 | otherwise = show way ++ "_"
128
129 osuf, ssuf, hisuf, hcsuf, obootsuf, hibootsuf :: Way -> String
130 osuf = (++ "o" ) . wayPrefix
131 ssuf = (++ "s" ) . wayPrefix
132 hisuf = (++ "hi" ) . wayPrefix
133 hcsuf = (++ "hc" ) . wayPrefix
134 obootsuf = (++ "o-boot" ) . wayPrefix
135 hibootsuf = (++ "hi-boot") . wayPrefix
136
137 -- Note: in the previous build system libsuf was mysteriously different
138 -- from other suffixes. For example, in the profiling way it used to be
139 -- "_p.a" instead of ".p_a" which is how other suffixes work. I decided
140 -- to make all suffixes consistent: ".way_extension".
141 -- TODO: find out why we need version number in the dynamic suffix
142 -- The current theory: dynamic libraries are eventually placed in a single
143 -- giant directory in the load path of the dynamic linker, and hence we must
144 -- distinguish different versions of GHC. In contrast static libraries live
145 -- in their own per-package directory and hence do not need a unique filename.
146 -- We also need to respect the system's dynamic extension, e.g. .dll or .so.
147 libsuf :: Way -> Action String
148 libsuf way @ (Way set) =
149 if (not . wayUnit Dynamic $ way)
150 then return $ wayPrefix way ++ "a" -- e.g., p_a
151 else do
152 extension <- setting DynamicExtension -- e.g., .dll or .so
153 version <- setting ProjectVersion -- e.g., 7.11.20141222
154 let prefix = wayPrefix . Way . Set.delete (fromEnum Dynamic) $ set
155 -- e.g., p_ghc7.11.20141222.dll (the result)
156 return $ prefix ++ "ghc" ++ version ++ extension
157
158 -- | Detect way from a given 'FilePath'. Returns 'Nothing' if there is no match.
159 --
160 -- * @'safeDetectWay' "foo/bar.hi" '==' 'Just' vanilla@
161 -- * @'safeDetectWay' "baz.thr_p_o" '==' 'Just' threadedProfiling@
162 -- * @'safeDetectWay' "qwe.ph_i" '==' 'Nothing' (expected "qwe.p_hi")@
163 -- * @'safeDetectWay' "xru.p_ghc7.11.123.so" '==' 'Just' profiling@
164 safeDetectWay :: FilePath -> Maybe Way
165 safeDetectWay file = case reads prefix of
166 [(way, "")] -> Just way
167 _ -> Nothing
168 where
169 extension = takeExtension file
170 prefixed = if extension `notElem` [".so", ".dll", ".dynlib"]
171 then extension
172 else takeExtension . dropExtension .
173 dropExtension . dropExtension $ file
174 prefix = drop 1 . dropWhileEnd (== '_') . dropWhileEnd (/= '_') $ prefixed
175
176 -- Unsafe version of safeDetectWay. Useful when matchBuildResult has succeeded.
177 detectWay :: FilePath -> Way
178 detectWay = fromJust . safeDetectWay
179
180 -- Given a path, an extension suffix, and a file name check:
181 -- 1) the file conforms to pattern 'path//*suffix'
182 -- 2) file's extension has a valid way tag (i.e., safeDetectWay does not fail)
183 matchBuildResult :: FilePath -> String -> FilePath -> Bool
184 matchBuildResult path suffix file =
185 (path <//> "*" ++ suffix) ?== file && isJust (safeDetectWay file)
186
187 -- Instances for storing in the Shake database
188 instance Binary Way where
189 put = put . show
190 get = fmap read get
191
192 instance Hashable Way where
193 hashWithSalt salt = hashWithSalt salt . show
194
195 instance NFData Way where
196 rnf (Way s) = s `seq` ()