never executed always true always false
    1 {-# LANGUAGE CPP #-}
    2 
    3 -- | Ways
    4 --
    5 -- The central concept of a "way" is that all objects in a given
    6 -- program must be compiled in the same "way". Certain options change
    7 -- parameters of the virtual machine, eg. profiling adds an extra word
    8 -- to the object header, so profiling objects cannot be linked with
    9 -- non-profiling objects.
   10 --
   11 -- After parsing the command-line options, we determine which "way" we
   12 -- are building - this might be a combination way, eg. profiling+threaded.
   13 --
   14 -- There are two kinds of ways:
   15 --    - RTS only: only affect the runtime system (RTS) and don't affect code
   16 --    generation (e.g. threaded, debug)
   17 --    - Full ways: affect code generation and the RTS (e.g. profiling, dynamic
   18 --    linking)
   19 --
   20 -- We then find the "build-tag" associated with this way, and this
   21 -- becomes the suffix used to find .hi files and libraries used in
   22 -- this compilation.
   23 module GHC.Platform.Ways
   24    ( Way(..)
   25    , Ways
   26    , hasWay
   27    , hasNotWay
   28    , addWay
   29    , removeWay
   30    , allowed_combination
   31    , wayGeneralFlags
   32    , wayUnsetGeneralFlags
   33    , wayOptc
   34    , wayOptl
   35    , wayOptP
   36    , wayDesc
   37    , wayRTSOnly
   38    , wayTag
   39    , waysTag
   40    , waysBuildTag
   41    , fullWays
   42    , rtsWays
   43    -- * Host GHC ways
   44    , hostWays
   45    , hostFullWays
   46    , hostIsProfiled
   47    , hostIsDynamic
   48    , hostIsThreaded
   49    , hostIsDebugged
   50    , hostIsTracing
   51    )
   52 where
   53 
   54 import GHC.Prelude
   55 import GHC.Platform
   56 import GHC.Driver.Flags
   57 
   58 import qualified Data.Set as Set
   59 import Data.Set (Set)
   60 import Data.List (intersperse)
   61 
   62 -- | A way
   63 --
   64 -- Don't change the constructor order as it us used by `waysTag` to create a
   65 -- unique tag (e.g. thr_debug_p) which is expected by other tools (e.g. Cabal).
   66 data Way
   67   = WayCustom String -- ^ for GHC API clients building custom variants
   68   | WayThreaded      -- ^ (RTS only) Multithreaded runtime system
   69   | WayDebug         -- ^ Debugging, enable trace messages and extra checks
   70   | WayProf          -- ^ Profiling, enable cost-centre stacks and profiling reports
   71   | WayTracing       -- ^ (RTS only) enable event logging (tracing)
   72   | WayDyn           -- ^ Dynamic linking
   73   deriving (Eq, Ord, Show)
   74 
   75 type Ways = Set Way
   76 
   77 -- | Test if a way is enabled
   78 hasWay :: Ways -> Way -> Bool
   79 hasWay ws w = Set.member w ws
   80 
   81 -- | Test if a way is not enabled
   82 hasNotWay :: Ways -> Way -> Bool
   83 hasNotWay ws w = Set.notMember w ws
   84 
   85 -- | Add a way
   86 addWay :: Way -> Ways -> Ways
   87 addWay = Set.insert
   88 
   89 -- | Remove a way
   90 removeWay :: Way -> Ways -> Ways
   91 removeWay = Set.delete
   92 
   93 -- | Check if a combination of ways is allowed
   94 allowed_combination :: Ways -> Bool
   95 allowed_combination ways = not disallowed
   96   where
   97    disallowed = or [ hasWay ways x && hasWay ways y
   98                    | (x,y) <- couples
   99                    ]
  100    -- List of disallowed couples of ways
  101    couples = [] -- we don't have any disallowed combination of ways nowadays
  102 
  103 -- | Unique tag associated to a list of ways
  104 waysTag :: Ways -> String
  105 waysTag = concat . intersperse "_" . map wayTag . Set.toAscList
  106 
  107 -- | Unique build-tag associated to a list of ways
  108 --
  109 -- RTS only ways are filtered out because they have no impact on the build.
  110 waysBuildTag :: Ways -> String
  111 waysBuildTag ws = waysTag (Set.filter (not . wayRTSOnly) ws)
  112 
  113 
  114 -- | Unique build-tag associated to a way
  115 wayTag :: Way -> String
  116 wayTag (WayCustom xs) = xs
  117 wayTag WayThreaded    = "thr"
  118 wayTag WayDebug       = "debug"
  119 wayTag WayDyn         = "dyn"
  120 wayTag WayProf        = "p"
  121 wayTag WayTracing     = "l" -- "l" for "logging"
  122 
  123 -- | Return true for ways that only impact the RTS, not the generated code
  124 wayRTSOnly :: Way -> Bool
  125 wayRTSOnly (WayCustom {}) = False
  126 wayRTSOnly WayDyn         = False
  127 wayRTSOnly WayProf        = False
  128 wayRTSOnly WayThreaded    = True
  129 wayRTSOnly WayDebug       = True
  130 wayRTSOnly WayTracing     = True
  131 
  132 -- | Filter ways that have an impact on compilation
  133 fullWays :: Ways -> Ways
  134 fullWays ws = Set.filter (not . wayRTSOnly) ws
  135 
  136 -- | Filter RTS-only ways (ways that don't have an impact on compilation)
  137 rtsWays :: Ways -> Ways
  138 rtsWays ws = Set.filter wayRTSOnly ws
  139 
  140 wayDesc :: Way -> String
  141 wayDesc (WayCustom xs) = xs
  142 wayDesc WayThreaded    = "Threaded"
  143 wayDesc WayDebug       = "Debug"
  144 wayDesc WayDyn         = "Dynamic"
  145 wayDesc WayProf        = "Profiling"
  146 wayDesc WayTracing     = "Tracing"
  147 
  148 -- | Turn these flags on when enabling this way
  149 wayGeneralFlags :: Platform -> Way -> [GeneralFlag]
  150 wayGeneralFlags _ (WayCustom {}) = []
  151 wayGeneralFlags _ WayThreaded = []
  152 wayGeneralFlags _ WayDebug    = []
  153 wayGeneralFlags _ WayDyn      = [Opt_PIC, Opt_ExternalDynamicRefs]
  154     -- We could get away without adding -fPIC when compiling the
  155     -- modules of a program that is to be linked with -dynamic; the
  156     -- program itself does not need to be position-independent, only
  157     -- the libraries need to be.  HOWEVER, GHCi links objects into a
  158     -- .so before loading the .so using the system linker.  Since only
  159     -- PIC objects can be linked into a .so, we have to compile even
  160     -- modules of the main program with -fPIC when using -dynamic.
  161 wayGeneralFlags _ WayProf     = []
  162 wayGeneralFlags _ WayTracing  = []
  163 
  164 -- | Turn these flags off when enabling this way
  165 wayUnsetGeneralFlags :: Platform -> Way -> [GeneralFlag]
  166 wayUnsetGeneralFlags _ (WayCustom {}) = []
  167 wayUnsetGeneralFlags _ WayThreaded = []
  168 wayUnsetGeneralFlags _ WayDebug    = []
  169 wayUnsetGeneralFlags _ WayDyn      = [Opt_SplitSections]
  170    -- There's no point splitting when we're going to be dynamically linking.
  171    -- Plus it breaks compilation on OSX x86.
  172 wayUnsetGeneralFlags _ WayProf     = []
  173 wayUnsetGeneralFlags _ WayTracing  = []
  174 
  175 -- | Pass these options to the C compiler when enabling this way
  176 wayOptc :: Platform -> Way -> [String]
  177 wayOptc _ (WayCustom {}) = []
  178 wayOptc platform WayThreaded = case platformOS platform of
  179                                OSOpenBSD -> ["-pthread"]
  180                                OSNetBSD  -> ["-pthread"]
  181                                _         -> []
  182 wayOptc _ WayDebug      = []
  183 wayOptc _ WayDyn        = []
  184 wayOptc _ WayProf       = ["-DPROFILING"]
  185 wayOptc _ WayTracing    = ["-DTRACING"]
  186 
  187 -- | Pass these options to linker when enabling this way
  188 wayOptl :: Platform -> Way -> [String]
  189 wayOptl _ (WayCustom {}) = []
  190 wayOptl platform WayThreaded =
  191    case platformOS platform of
  192    -- N.B. FreeBSD cc throws a warning if we pass -pthread without
  193    -- actually using any pthread symbols.
  194    OSFreeBSD  -> ["-pthread", "-Wno-unused-command-line-argument"]
  195    OSOpenBSD  -> ["-pthread"]
  196    OSNetBSD   -> ["-pthread"]
  197    _          -> []
  198 wayOptl _ WayDebug      = []
  199 wayOptl _ WayDyn        = []
  200 wayOptl _ WayProf       = []
  201 wayOptl _ WayTracing    = []
  202 
  203 -- | Pass these options to the preprocessor when enabling this way
  204 wayOptP :: Platform -> Way -> [String]
  205 wayOptP _ (WayCustom {}) = []
  206 wayOptP _ WayThreaded = []
  207 wayOptP _ WayDebug    = []
  208 wayOptP _ WayDyn      = []
  209 wayOptP _ WayProf     = ["-DPROFILING"]
  210 wayOptP _ WayTracing  = ["-DTRACING"]
  211 
  212 
  213 -- | Consult the RTS to find whether it has been built with profiling enabled.
  214 hostIsProfiled :: Bool
  215 hostIsProfiled = rtsIsProfiled_ /= 0
  216 
  217 foreign import ccall unsafe "rts_isProfiled" rtsIsProfiled_ :: Int
  218 
  219 -- | Consult the RTS to find whether GHC itself has been built with
  220 -- dynamic linking.  This can't be statically known at compile-time,
  221 -- because we build both the static and dynamic versions together with
  222 -- -dynamic-too.
  223 hostIsDynamic :: Bool
  224 hostIsDynamic = rtsIsDynamic_ /= 0
  225 
  226 foreign import ccall unsafe "rts_isDynamic" rtsIsDynamic_ :: Int
  227 
  228 -- we need this until the bootstrap GHC is always recent enough
  229 #if MIN_VERSION_GLASGOW_HASKELL(9,1,0,0)
  230 
  231 -- | Consult the RTS to find whether it is threaded.
  232 hostIsThreaded :: Bool
  233 hostIsThreaded = rtsIsThreaded_ /= 0
  234 
  235 foreign import ccall unsafe "rts_isThreaded" rtsIsThreaded_ :: Int
  236 
  237 -- | Consult the RTS to find whether it is debugged.
  238 hostIsDebugged :: Bool
  239 hostIsDebugged = rtsIsDebugged_ /= 0
  240 
  241 foreign import ccall unsafe "rts_isDebugged" rtsIsDebugged_ :: Int
  242 
  243 -- | Consult the RTS to find whether it is tracing.
  244 hostIsTracing :: Bool
  245 hostIsTracing = rtsIsTracing_ /= 0
  246 
  247 foreign import ccall unsafe "rts_isTracing" rtsIsTracing_ :: Int
  248 
  249 
  250 #else
  251 
  252 hostIsThreaded :: Bool
  253 hostIsThreaded = False
  254 
  255 hostIsDebugged :: Bool
  256 hostIsDebugged = False
  257 
  258 hostIsTracing :: Bool
  259 hostIsTracing = False
  260 
  261 #endif
  262 
  263 
  264 -- | Host ways.
  265 hostWays :: Ways
  266 hostWays = Set.unions
  267    [ if hostIsDynamic  then Set.singleton WayDyn      else Set.empty
  268    , if hostIsProfiled then Set.singleton WayProf     else Set.empty
  269    , if hostIsThreaded then Set.singleton WayThreaded else Set.empty
  270    , if hostIsDebugged then Set.singleton WayDebug    else Set.empty
  271    , if hostIsTracing  then Set.singleton WayTracing  else Set.empty
  272    ]
  273 
  274 -- | Host "full" ways (i.e. ways that have an impact on the compilation,
  275 -- not RTS only ways).
  276 --
  277 -- These ways must be used when compiling codes targeting the internal
  278 -- interpreter.
  279 hostFullWays :: Ways
  280 hostFullWays = fullWays hostWays