Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : master
http://hackage.haskell.org/trac/ghc/changeset/0c4a9f38637dfc3bc8fd48e8ba6bf64da51b727b >--------------------------------------------------------------- commit 0c4a9f38637dfc3bc8fd48e8ba6bf64da51b727b Author: Ian Lynagh <i...@well-typed.com> Date: Sat Dec 8 19:03:00 2012 +0000 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. >--------------------------------------------------------------- compiler/main/DynFlags.hs | 72 ++++++++++++++++++++++++++++++--------------- 1 files changed, 48 insertions(+), 24 deletions(-) diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 9d2b372..186c566 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -27,6 +27,7 @@ module DynFlags ( wopt, wopt_set, wopt_unset, xopt, xopt_set, xopt_unset, lang_set, + doDynamicToo, DynFlags(..), HasDynFlags(..), ContainsDynFlags(..), RtsOptsEnabled(..), @@ -1047,16 +1048,16 @@ wayGeneralFlags _ WayPar = [Opt_Parallel] wayGeneralFlags _ WayGran = [Opt_GranMacros] wayGeneralFlags _ WayNDP = [] -wayExtras :: Platform -> Way -> DynP () -wayExtras _ WayThreaded = return () -wayExtras _ WayDebug = return () -wayExtras _ WayDyn = return () -wayExtras _ WayProf = return () -wayExtras _ WayEventLog = return () -wayExtras _ WayPar = exposePackage "concurrent" -wayExtras _ WayGran = exposePackage "concurrent" -wayExtras _ WayNDP = do setExtensionFlag Opt_ParallelArrays - setGeneralFlag Opt_Vectorise +wayExtras :: Platform -> Way -> DynFlags -> DynFlags +wayExtras _ WayThreaded dflags = dflags +wayExtras _ WayDebug dflags = dflags +wayExtras _ WayDyn dflags = dflags +wayExtras _ WayProf dflags = dflags +wayExtras _ WayEventLog dflags = dflags +wayExtras _ WayPar dflags = exposePackage' "concurrent" dflags +wayExtras _ WayGran dflags = exposePackage' "concurrent" dflags +wayExtras _ WayNDP dflags = setExtensionFlag' Opt_ParallelArrays + $ setGeneralFlag' Opt_Vectorise dflags wayOptc :: Platform -> Way -> [String] wayOptc platform WayThreaded = case platformOS platform of @@ -1111,6 +1112,15 @@ wayOptP _ WayPar = ["-D__PARALLEL_HASKELL__"] wayOptP _ WayGran = ["-D__GRANSIM__"] 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 @@ -2865,11 +2875,14 @@ setDumpFlag dump_flag = NoArg (setDumpFlag' dump_flag) -------------------------- addWay :: Way -> DynP () -addWay w = do upd (\dfs -> dfs { ways = w : ways dfs }) - dfs <- liftEwM getCmdLineState - let platform = targetPlatform dfs - wayExtras platform w - mapM_ setGeneralFlag $ wayGeneralFlags platform w +addWay w = upd (addWay' w) + +addWay' :: Way -> DynFlags -> DynFlags +addWay' w dflags0 = let platform = targetPlatform dflags0 + dflags1 = dflags0 { ways = w : ways dflags0 } + dflags2 = wayExtras platform w dflags1 + dflags3 = foldr setGeneralFlag' dflags2 (wayGeneralFlags platform w) + in dflags3 removeWay :: Way -> DynP () removeWay w = do @@ -2883,8 +2896,13 @@ removeWay w = do -------------------------- setGeneralFlag, unSetGeneralFlag :: GeneralFlag -> DynP () -setGeneralFlag f = upd (\dfs -> gopt_set dfs f) -unSetGeneralFlag f = upd (\dfs -> gopt_unset dfs f) +setGeneralFlag f = upd (setGeneralFlag' 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 () @@ -2893,17 +2911,20 @@ unSetWarningFlag f = upd (\dfs -> wopt_unset dfs f) -------------------------- setExtensionFlag, unSetExtensionFlag :: ExtensionFlag -> DynP () -setExtensionFlag f = do upd (\dfs -> xopt_set dfs f) - sequence_ deps +setExtensionFlag f = upd (setExtensionFlag' f) +unSetExtensionFlag f = upd (unSetExtensionFlag' f) + +setExtensionFlag', unSetExtensionFlag' :: ExtensionFlag -> DynFlags -> DynFlags +setExtensionFlag' f dflags = foldr ($) (xopt_set dflags f) deps where - deps = [ if turn_on then setExtensionFlag d - else unSetExtensionFlag d + deps = [ if turn_on then setExtensionFlag' d + else unSetExtensionFlag' d | (f', turn_on, d) <- impliedFlags, f' == f ] -- When you set f, set the ones it implies -- NB: use setExtensionFlag recursively, in case the implied 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 -- (except for -fno-glasgow-exts, which is treated specially) @@ -2973,8 +2994,7 @@ clearPkgConf = upd $ \s -> s { extraPkgConfs = const [] } exposePackage, exposePackageId, hidePackage, ignorePackage, trustPackage, distrustPackage :: String -> DynP () -exposePackage p = - upd (\s -> s{ packageFlags = ExposePackage p : packageFlags s }) +exposePackage p = upd (exposePackage' p) exposePackageId p = upd (\s -> s{ packageFlags = ExposePackageId p : packageFlags s }) hidePackage p = @@ -2986,6 +3006,10 @@ trustPackage p = exposePackage p >> -- both trust and distrust also expose a pac distrustPackage p = exposePackage p >> 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 p s = s{ thisPackage = stringToPackageId p } _______________________________________________ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
