-> TcRnIf a b ModIface
readBinIface checkHiWay traceBinIFaceReading hi_path = do
update_nc <- mkNameCacheUpdater
- liftIO $ readBinIface_ checkHiWay traceBinIFaceReading hi_path update_nc
+ dflags <- getDOpts
+ liftIO $ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path update_nc
-readBinIface_ :: CheckHiWay -> TraceBinIFaceReading -> FilePath
+readBinIface_ :: DynFlags -> CheckHiWay -> TraceBinIFaceReading -> FilePath
-> NameCacheUpdater (Array Int Name)
-> IO ModIface
-readBinIface_ checkHiWay traceBinIFaceReading hi_path update_nc = do
+readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path update_nc = do
let printer :: SDoc -> IO ()
printer = case traceBinIFaceReading of
TraceBinIFaceReading -> \sd -> printSDoc sd defaultDumpStyle
errorOnMismatch "mismatched interface file versions" our_ver check_ver
check_way <- get bh
- way_descr <- getWayDescr
+ let way_descr = getWayDescr dflags
wantedGot "Way" way_descr check_way
when (checkHiWay == CheckHiWay) $
errorOnMismatch "mismatched interface file ways" way_descr check_way
-- The version and way descriptor go next
put_ bh (show opt_HiVersion)
- way_descr <- getWayDescr
+ let way_descr = getWayDescr dflags
put_ bh way_descr
-- Remember where the symbol table pointer will go
mi_fix_fn = mkIfaceFixCache fixities,
mi_hash_fn = mkIfaceHashCache decls })
-getWayDescr :: IO String
-getWayDescr = do
- tag <- readIORef v_Build_tag
- if cGhcUnregisterised == "YES" then return ('u':tag) else return tag
+getWayDescr :: DynFlags -> String
+getWayDescr dflags
+ | cGhcUnregisterised == "YES" = 'u':tag
+ | otherwise = tag
+ where tag = buildTag dflags
-- if this is an unregisterised build, make sure our interfaces
-- can't be used by a registerised build.
DynLibLoader(..),
fFlags, xFlags,
dphPackage,
+ wayNames,
-- ** Manipulating DynFlags
defaultDynFlags, -- DynFlags
import Module
import PackageConfig
import PrelNames ( mAIN )
-#if defined(i386_TARGET_ARCH) || (!defined(mingw32_TARGET_OS) && !defined(darwin_TARGET_OS))
-import StaticFlags ( opt_Static )
-#endif
-import StaticFlags ( opt_PIC, WayName(..), v_Ways, v_Build_tag,
- v_RTS_Build_tag )
+import StaticFlags
import {-# SOURCE #-} Packages (PackageState)
import DriverPhases ( Phase(..), phaseInputExt )
import Config
thisPackage :: PackageId, -- ^ name of package currently being compiled
-- ways
- wayNames :: [WayName], -- ^ Way flags from the command line
+ ways :: [Way], -- ^ Way flags from the command line
buildTag :: String, -- ^ The global \"way\" (e.g. \"p\" for prof)
rtsBuildTag :: String, -- ^ The RTS \"way\"
haddockOptions :: Maybe String
}
+wayNames :: DynFlags -> [WayName]
+wayNames = map wayName . ways
+
-- | The target code type of the compilation (if any).
--
-- Whenever you change the target, also make sure to set 'ghcLink' to
initDynFlags dflags = do
-- someday these will be dynamic flags
ways <- readIORef v_Ways
- build_tag <- readIORef v_Build_tag
- rts_build_tag <- readIORef v_RTS_Build_tag
refFilesToClean <- newIORef []
refDirsToClean <- newIORef emptyFM
return dflags{
- wayNames = ways,
- buildTag = build_tag,
- rtsBuildTag = rts_build_tag,
+ ways = ways,
+ buildTag = mkBuildTag (filter (not . wayRTSOnly) ways),
+ rtsBuildTag = mkBuildTag ways,
filesToClean = refFilesToClean,
dirsToClean = refDirsToClean
}
packageFlags = [],
pkgDatabase = Nothing,
pkgState = panic "no package state yet: call GHC.setSessionDynFlags",
- wayNames = panic "defaultDynFlags: No wayNames",
+ ways = panic "defaultDynFlags: No ways",
buildTag = panic "defaultDynFlags: No buildTag",
rtsBuildTag = panic "defaultDynFlags: No rtsBuildTag",
splitInfo = Nothing,
initStaticOpts,
-- Ways
- WayName(..), v_Ways, v_Build_tag, v_RTS_Build_tag, isRTSWay,
+ WayName(..), Way(..), v_Ways, isRTSWay, mkBuildTag,
-- Output style options
opt_PprUserLength,
opt_StubDeadValues,
-- For the parser
- addOpt, removeOpt, addWay, findBuildTag, v_opt_C_ready
+ addOpt, removeOpt, addWay, getWayFlags, v_opt_C_ready
) where
#include "HsVersions.h"
import Maybes ( firstJust )
import Panic
+import Data.Maybe ( listToMaybe )
import Data.IORef
import System.IO.Unsafe ( unsafePerformIO )
import Data.List
addOpt = consIORef v_opt_C
addWay :: WayName -> IO ()
-addWay = consIORef v_Ways
+addWay = consIORef v_Ways . lkupWay
removeOpt :: String -> IO ()
removeOpt f = do
-- becomes the suffix used to find .hi files and libraries used in
-- this compilation.
-GLOBAL_VAR(v_Build_tag, "", String)
-
--- The RTS has its own build tag, because there are some ways that
--- affect the RTS only.
-GLOBAL_VAR(v_RTS_Build_tag, "", String)
-
data WayName
= WayThreaded
| WayDebug
| WayPar
| WayGran
| WayNDP
- | WayUser_a
- | WayUser_b
- | WayUser_c
- | WayUser_d
- | WayUser_e
- | WayUser_f
- | WayUser_g
- | WayUser_h
- | WayUser_i
- | WayUser_j
- | WayUser_k
- | WayUser_l
- | WayUser_m
- | WayUser_n
- | WayUser_o
- | WayUser_A
- | WayUser_B
+ | WayDyn
deriving (Eq,Ord)
-GLOBAL_VAR(v_Ways, [] ,[WayName])
+GLOBAL_VAR(v_Ways, [] ,[Way])
allowed_combination :: [WayName] -> Bool
allowed_combination way = and [ x `allowedWith` y
-- <= the right argument, according to the Ord instance
-- on Way above.
+ -- dyn is allowed with everything
+ _ `allowedWith` WayDyn = True
+ WayDyn `allowedWith` _ = True
+
-- debug is allowed with everything
_ `allowedWith` WayDebug = True
WayDebug `allowedWith` _ = True
_ `allowedWith` _ = False
-findBuildTag :: IO [String] -- new options
-findBuildTag = do
- way_names <- readIORef v_Ways
- let ws = sort (nub way_names)
+getWayFlags :: IO [String] -- new options
+getWayFlags = do
+ unsorted <- readIORef v_Ways
+ let ways = sortBy (compare `on` wayName) $
+ nubBy ((==) `on` wayName) $ unsorted
+ writeIORef v_Ways ways
- if not (allowed_combination ws)
+ if not (allowed_combination (map wayName ways))
then ghcError (CmdLineError $
"combination not supported: " ++
foldr1 (\a b -> a ++ '/':b)
- (map (wayName . lkupWay) ws))
- else let ways = map lkupWay ws
- tag = mkBuildTag (filter (not.wayRTSOnly) ways)
- rts_tag = mkBuildTag ways
- flags = map wayOpts ways
- in do
- writeIORef v_Build_tag tag
- writeIORef v_RTS_Build_tag rts_tag
- return (concat flags)
-
-
+ (map wayDesc ways))
+ else
+ return (concatMap wayOpts ways)
mkBuildTag :: [Way] -> String
mkBuildTag ways = concat (intersperse "_" (map wayTag ways))
lkupWay :: WayName -> Way
lkupWay w =
- case lookup w way_details of
+ case listToMaybe (filter ((==) w . wayName) way_details) of
Nothing -> error "findBuildTag"
Just details -> details
isRTSWay = wayRTSOnly . lkupWay
data Way = Way {
+ wayName :: WayName,
wayTag :: String,
wayRTSOnly :: Bool,
- wayName :: String,
+ wayDesc :: String,
wayOpts :: [String]
}
-way_details :: [ (WayName, Way) ]
+way_details :: [ Way ]
way_details =
- [ (WayThreaded, Way "thr" True "Threaded" [
+ [ Way WayThreaded "thr" True "Threaded" [
#if defined(freebsd_TARGET_OS)
-- "-optc-pthread"
-- , "-optl-pthread"
#elif defined(solaris2_TARGET_OS)
"-optl-lrt"
#endif
- ] ),
+ ],
+
+ Way WayDebug "debug" True "Debug" [],
- (WayDebug, Way "debug" True "Debug" [] ),
+ Way WayDyn "dyn" False "Dynamic"
+ [ "-DDYNAMIC"
+ , "-optc-DDYNAMIC" ],
- (WayProf, Way "p" False "Profiling"
+ Way WayProf "p" False "Profiling"
[ "-fscc-profiling"
, "-DPROFILING"
- , "-optc-DPROFILING" ]),
+ , "-optc-DPROFILING" ],
- (WayEventLog, Way "l" True "RTS Event Logging"
+ Way WayEventLog "l" True "RTS Event Logging"
[ "-DEVENTLOG"
- , "-optc-DEVENTLOG" ]),
+ , "-optc-DEVENTLOG" ],
- (WayTicky, Way "t" True "Ticky-ticky Profiling"
+ Way WayTicky "t" True "Ticky-ticky Profiling"
[ "-DTICKY_TICKY"
- , "-optc-DTICKY_TICKY" ]),
+ , "-optc-DTICKY_TICKY" ],
- -- optl's below to tell linker where to find the PVM library -- HWL
- (WayPar, Way "mp" False "Parallel"
+ Way WayPar "mp" False "Parallel"
[ "-fparallel"
, "-D__PARALLEL_HASKELL__"
, "-optc-DPAR"
, "-optc-w"
, "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}"
, "-optl-lpvm3"
- , "-optl-lgpvm3" ]),
+ , "-optl-lgpvm3" ],
-- at the moment we only change the RTS and could share compiler and libs!
- (WayPar, Way "mt" False "Parallel ticky profiling"
+ Way WayPar "mt" False "Parallel ticky profiling"
[ "-fparallel"
, "-D__PARALLEL_HASKELL__"
, "-optc-DPAR"
, "-optc-w"
, "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}"
, "-optl-lpvm3"
- , "-optl-lgpvm3" ]),
+ , "-optl-lgpvm3" ],
- (WayPar, Way "md" False "Distributed"
+ Way WayPar "md" False "Distributed"
[ "-fparallel"
, "-D__PARALLEL_HASKELL__"
, "-D__DISTRIBUTED_HASKELL__"
, "-optc-w"
, "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}"
, "-optl-lpvm3"
- , "-optl-lgpvm3" ]),
+ , "-optl-lgpvm3" ],
- (WayGran, Way "mg" False "GranSim"
+ Way WayGran "mg" False "GranSim"
[ "-fgransim"
, "-D__GRANSIM__"
, "-optc-DGRAN"
- , "-package concurrent" ]),
+ , "-package concurrent" ],
- (WayNDP, Way "ndp" False "Nested data parallelism"
+ Way WayNDP "ndp" False "Nested data parallelism"
[ "-XParr"
- , "-fvectorise"]),
-
- (WayUser_a, Way "a" False "User way 'a'" ["$WAY_a_REAL_OPTS"]),
- (WayUser_b, Way "b" False "User way 'b'" ["$WAY_b_REAL_OPTS"]),
- (WayUser_c, Way "c" False "User way 'c'" ["$WAY_c_REAL_OPTS"]),
- (WayUser_d, Way "d" False "User way 'd'" ["$WAY_d_REAL_OPTS"]),
- (WayUser_e, Way "e" False "User way 'e'" ["$WAY_e_REAL_OPTS"]),
- (WayUser_f, Way "f" False "User way 'f'" ["$WAY_f_REAL_OPTS"]),
- (WayUser_g, Way "g" False "User way 'g'" ["$WAY_g_REAL_OPTS"]),
- (WayUser_h, Way "h" False "User way 'h'" ["$WAY_h_REAL_OPTS"]),
- (WayUser_i, Way "i" False "User way 'i'" ["$WAY_i_REAL_OPTS"]),
- (WayUser_j, Way "j" False "User way 'j'" ["$WAY_j_REAL_OPTS"]),
- (WayUser_k, Way "k" False "User way 'k'" ["$WAY_k_REAL_OPTS"]),
- (WayUser_l, Way "l" False "User way 'l'" ["$WAY_l_REAL_OPTS"]),
- (WayUser_m, Way "m" False "User way 'm'" ["$WAY_m_REAL_OPTS"]),
- (WayUser_n, Way "n" False "User way 'n'" ["$WAY_n_REAL_OPTS"]),
- (WayUser_o, Way "o" False "User way 'o'" ["$WAY_o_REAL_OPTS"]),
- (WayUser_A, Way "A" False "User way 'A'" ["$WAY_A_REAL_OPTS"]),
- (WayUser_B, Way "B" False "User way 'B'" ["$WAY_B_REAL_OPTS"])
+ , "-fvectorise"]
]
-
projects / ghc-hetmet.git / commitdiff