Commit 0c4a9f38 authored by ian@well-typed.com's avatar ian@well-typed.com
Browse files

Add a function to change DynFlags to be suitable for compiling for way=dynamic

Will be used when we are compiling with -dynamic-too. This needed a
little refactoring of the "addWay" code to allow the code to be shared.
parent e5182b7c
...@@ -27,6 +27,7 @@ module DynFlags ( ...@@ -27,6 +27,7 @@ module DynFlags (
wopt, wopt_set, wopt_unset, wopt, wopt_set, wopt_unset,
xopt, xopt_set, xopt_unset, xopt, xopt_set, xopt_unset,
lang_set, lang_set,
doDynamicToo,
DynFlags(..), DynFlags(..),
HasDynFlags(..), ContainsDynFlags(..), HasDynFlags(..), ContainsDynFlags(..),
RtsOptsEnabled(..), RtsOptsEnabled(..),
...@@ -1047,16 +1048,16 @@ wayGeneralFlags _ WayPar = [Opt_Parallel] ...@@ -1047,16 +1048,16 @@ wayGeneralFlags _ WayPar = [Opt_Parallel]
wayGeneralFlags _ WayGran = [Opt_GranMacros] wayGeneralFlags _ WayGran = [Opt_GranMacros]
wayGeneralFlags _ WayNDP = [] wayGeneralFlags _ WayNDP = []
wayExtras :: Platform -> Way -> DynP () wayExtras :: Platform -> Way -> DynFlags -> DynFlags
wayExtras _ WayThreaded = return () wayExtras _ WayThreaded dflags = dflags
wayExtras _ WayDebug = return () wayExtras _ WayDebug dflags = dflags
wayExtras _ WayDyn = return () wayExtras _ WayDyn dflags = dflags
wayExtras _ WayProf = return () wayExtras _ WayProf dflags = dflags
wayExtras _ WayEventLog = return () wayExtras _ WayEventLog dflags = dflags
wayExtras _ WayPar = exposePackage "concurrent" wayExtras _ WayPar dflags = exposePackage' "concurrent" dflags
wayExtras _ WayGran = exposePackage "concurrent" wayExtras _ WayGran dflags = exposePackage' "concurrent" dflags
wayExtras _ WayNDP = do setExtensionFlag Opt_ParallelArrays wayExtras _ WayNDP dflags = setExtensionFlag' Opt_ParallelArrays
setGeneralFlag Opt_Vectorise $ setGeneralFlag' Opt_Vectorise dflags
wayOptc :: Platform -> Way -> [String] wayOptc :: Platform -> Way -> [String]
wayOptc platform WayThreaded = case platformOS platform of wayOptc platform WayThreaded = case platformOS platform of
...@@ -1111,6 +1112,15 @@ wayOptP _ WayPar = ["-D__PARALLEL_HASKELL__"] ...@@ -1111,6 +1112,15 @@ wayOptP _ WayPar = ["-D__PARALLEL_HASKELL__"]
wayOptP _ WayGran = ["-D__GRANSIM__"] wayOptP _ WayGran = ["-D__GRANSIM__"]
wayOptP _ WayNDP = [] wayOptP _ WayNDP = []
doDynamicToo :: DynFlags -> DynFlags
doDynamicToo dflags0 = let dflags1 = unSetGeneralFlag' Opt_Static dflags0
dflags2 = addWay' WayDyn dflags1
dflags3 = dflags2 {
hiSuf = dynHiSuf dflags2,
objectSuf = dynObjectSuf dflags2
}
in dflags3
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- | Used by 'GHC.newSession' to partially initialize a new 'DynFlags' value -- | Used by 'GHC.newSession' to partially initialize a new 'DynFlags' value
...@@ -2865,11 +2875,14 @@ setDumpFlag dump_flag = NoArg (setDumpFlag' dump_flag) ...@@ -2865,11 +2875,14 @@ setDumpFlag dump_flag = NoArg (setDumpFlag' dump_flag)
-------------------------- --------------------------
addWay :: Way -> DynP () addWay :: Way -> DynP ()
addWay w = do upd (\dfs -> dfs { ways = w : ways dfs }) addWay w = upd (addWay' w)
dfs <- liftEwM getCmdLineState
let platform = targetPlatform dfs addWay' :: Way -> DynFlags -> DynFlags
wayExtras platform w addWay' w dflags0 = let platform = targetPlatform dflags0
mapM_ setGeneralFlag $ wayGeneralFlags platform w dflags1 = dflags0 { ways = w : ways dflags0 }
dflags2 = wayExtras platform w dflags1
dflags3 = foldr setGeneralFlag' dflags2 (wayGeneralFlags platform w)
in dflags3
removeWay :: Way -> DynP () removeWay :: Way -> DynP ()
removeWay w = do removeWay w = do
...@@ -2883,8 +2896,13 @@ removeWay w = do ...@@ -2883,8 +2896,13 @@ removeWay w = do
-------------------------- --------------------------
setGeneralFlag, unSetGeneralFlag :: GeneralFlag -> DynP () setGeneralFlag, unSetGeneralFlag :: GeneralFlag -> DynP ()
setGeneralFlag f = upd (\dfs -> gopt_set dfs f) setGeneralFlag f = upd (setGeneralFlag' f)
unSetGeneralFlag f = upd (\dfs -> gopt_unset dfs f) unSetGeneralFlag f = upd (unSetGeneralFlag' f)
setGeneralFlag' :: GeneralFlag -> DynFlags -> DynFlags
setGeneralFlag' f dflags = gopt_set dflags f
unSetGeneralFlag' :: GeneralFlag -> DynFlags -> DynFlags
unSetGeneralFlag' f dflags = gopt_unset dflags f
-------------------------- --------------------------
setWarningFlag, unSetWarningFlag :: WarningFlag -> DynP () setWarningFlag, unSetWarningFlag :: WarningFlag -> DynP ()
...@@ -2893,17 +2911,20 @@ unSetWarningFlag f = upd (\dfs -> wopt_unset dfs f) ...@@ -2893,17 +2911,20 @@ unSetWarningFlag f = upd (\dfs -> wopt_unset dfs f)
-------------------------- --------------------------
setExtensionFlag, unSetExtensionFlag :: ExtensionFlag -> DynP () setExtensionFlag, unSetExtensionFlag :: ExtensionFlag -> DynP ()
setExtensionFlag f = do upd (\dfs -> xopt_set dfs f) setExtensionFlag f = upd (setExtensionFlag' f)
sequence_ deps unSetExtensionFlag f = upd (unSetExtensionFlag' f)
setExtensionFlag', unSetExtensionFlag' :: ExtensionFlag -> DynFlags -> DynFlags
setExtensionFlag' f dflags = foldr ($) (xopt_set dflags f) deps
where where
deps = [ if turn_on then setExtensionFlag d deps = [ if turn_on then setExtensionFlag' d
else unSetExtensionFlag d else unSetExtensionFlag' d
| (f', turn_on, d) <- impliedFlags, f' == f ] | (f', turn_on, d) <- impliedFlags, f' == f ]
-- When you set f, set the ones it implies -- When you set f, set the ones it implies
-- NB: use setExtensionFlag recursively, in case the implied flags -- NB: use setExtensionFlag recursively, in case the implied flags
-- implies further flags -- implies further flags
unSetExtensionFlag f = upd (\dfs -> xopt_unset dfs f) unSetExtensionFlag' f dflags = xopt_unset dflags f
-- When you un-set f, however, we don't un-set the things it implies -- When you un-set f, however, we don't un-set the things it implies
-- (except for -fno-glasgow-exts, which is treated specially) -- (except for -fno-glasgow-exts, which is treated specially)
...@@ -2973,8 +2994,7 @@ clearPkgConf = upd $ \s -> s { extraPkgConfs = const [] } ...@@ -2973,8 +2994,7 @@ clearPkgConf = upd $ \s -> s { extraPkgConfs = const [] }
exposePackage, exposePackageId, hidePackage, ignorePackage, exposePackage, exposePackageId, hidePackage, ignorePackage,
trustPackage, distrustPackage :: String -> DynP () trustPackage, distrustPackage :: String -> DynP ()
exposePackage p = exposePackage p = upd (exposePackage' p)
upd (\s -> s{ packageFlags = ExposePackage p : packageFlags s })
exposePackageId p = exposePackageId p =
upd (\s -> s{ packageFlags = ExposePackageId p : packageFlags s }) upd (\s -> s{ packageFlags = ExposePackageId p : packageFlags s })
hidePackage p = hidePackage p =
...@@ -2986,6 +3006,10 @@ trustPackage p = exposePackage p >> -- both trust and distrust also expose a pac ...@@ -2986,6 +3006,10 @@ trustPackage p = exposePackage p >> -- both trust and distrust also expose a pac
distrustPackage p = exposePackage p >> distrustPackage p = exposePackage p >>
upd (\s -> s{ packageFlags = DistrustPackage p : packageFlags s }) upd (\s -> s{ packageFlags = DistrustPackage p : packageFlags s })
exposePackage' :: String -> DynFlags -> DynFlags
exposePackage' p dflags
= dflags { packageFlags = ExposePackage p : packageFlags dflags }
setPackageName :: String -> DynFlags -> DynFlags setPackageName :: String -> DynFlags -> DynFlags
setPackageName p s = s{ thisPackage = stringToPackageId p } setPackageName p s = s{ thisPackage = stringToPackageId p }
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment