Make the ways dynamic

compiler/cmm/CLabel.hs

@@ -104,7 +104,6 @@ module CLabel (
     ) where
 
 import IdInfo
-import StaticFlags
 import BasicTypes
 import Packages
 import DataCon
@@ -808,15 +807,15 @@ labelDynamic :: DynFlags -> PackageId -> CLabel -> Bool
 labelDynamic dflags this_pkg lbl =
   case lbl of
    -- is the RTS in a DLL or not?
-   RtsLabel _           -> not opt_Static && (this_pkg /= rtsPackageId)
+   RtsLabel _           -> not (dopt Opt_Static dflags) && (this_pkg /= rtsPackageId)
 
-   IdLabel n _ _        -> isDllName this_pkg n
+   IdLabel n _ _        -> isDllName dflags this_pkg n
 
    -- When compiling in the "dyn" way, each package is to be linked into
    -- its own shared library.
    CmmLabel pkg _ _
     | os == OSMinGW32 ->
-       not opt_Static && (this_pkg /= pkg)
+       not (dopt Opt_Static dflags) && (this_pkg /= pkg)
     | otherwise ->
        True
 
@@ -834,14 +833,14 @@ labelDynamic dflags this_pkg lbl =
             -- When compiling in the "dyn" way, each package is to be
             -- linked into its own DLL.
             ForeignLabelInPackage pkgId ->
-                (not opt_Static) && (this_pkg /= pkgId)
+                (not (dopt Opt_Static dflags)) && (this_pkg /= pkgId)
 
        else -- On Mac OS X and on ELF platforms, false positives are OK,
             -- so we claim that all foreign imports come from dynamic
             -- libraries
             True
 
-   PlainModuleInitLabel m -> not opt_Static && this_pkg /= (modulePackageId m)
+   PlainModuleInitLabel m -> not (dopt Opt_Static dflags) && this_pkg /= (modulePackageId m)
 
    -- Note that DynamicLinkerLabels do NOT require dynamic linking themselves.
    _                 -> False

compiler/main/DriverPipeline.hs

@@ -39,7 +39,7 @@ import Module
 import UniqFM           ( eltsUFM )
 import ErrUtils
 import DynFlags
-import StaticFlags      ( v_Ld_inputs, opt_Static, Way(..) )
+import StaticFlags      ( v_Ld_inputs )
 import Config
 import Panic
 import Util
@@ -1352,9 +1352,9 @@ runPhase LlvmLlc input_fn dflags
 
     let lc_opts = getOpts dflags opt_lc
         opt_lvl = max 0 (min 2 $ optLevel dflags)
-        rmodel | dopt Opt_PIC dflags = "pic"
-               | not opt_Static = "dynamic-no-pic"
-               | otherwise      = "static"
+        rmodel | dopt Opt_PIC dflags          = "pic"
+               | not (dopt Opt_Static dflags) = "dynamic-no-pic"
+               | otherwise                    = "static"
         tbaa | ver < 29                 = "" -- no tbaa in 2.8 and earlier
              | dopt Opt_LlvmTBAA dflags = "--enable-tbaa=true"
              | otherwise                = "--enable-tbaa=false"
@@ -1448,7 +1448,7 @@ maybeMergeStub
 
 runPhase_MoveBinary :: DynFlags -> FilePath -> IO Bool
 runPhase_MoveBinary dflags input_fn
-    | WayPar `elem` ways dflags && not opt_Static =
+    | WayPar `elem` ways dflags && not (dopt Opt_Static dflags) =
         panic ("Don't know how to combine PVM wrapper and dynamic wrapper")
     | WayPar `elem` ways dflags = do
         let sysMan = pgm_sysman dflags
@@ -1668,7 +1668,7 @@ linkBinary dflags o_files dep_packages = do
         get_pkg_lib_path_opts l
          | osElfTarget (platformOS platform) &&
            dynLibLoader dflags == SystemDependent &&
-           not opt_Static
+           not (dopt Opt_Static dflags)
             = ["-L" ++ l, "-Wl,-rpath", "-Wl," ++ l]
          | otherwise = ["-L" ++ l]
 
@@ -1891,7 +1891,7 @@ linkDynLib dflags o_files dep_packages
         get_pkg_lib_path_opts l
          | osElfTarget (platformOS (targetPlatform dflags)) &&
            dynLibLoader dflags == SystemDependent &&
-           not opt_Static
+           not (dopt Opt_Static dflags)
             = ["-L" ++ l, "-Wl,-rpath", "-Wl," ++ l]
          | otherwise = ["-L" ++ l]
 

compiler/main/DynFlags.hs

@@ -50,6 +50,8 @@ module DynFlags (
 
         printOutputForUser, printInfoForUser,
 
+        Way(..), mkBuildTag, wayRTSOnly,
+
         -- ** Safe Haskell
         SafeHaskellMode(..),
         safeHaskellOn, safeImportsOn, safeLanguageOn, safeInferOn,
@@ -122,7 +124,6 @@ import Platform
 import Module
 import PackageConfig
 import PrelNames        ( mAIN )
-import StaticFlags
 import {-# SOURCE #-} Packages (PackageState)
 import DriverPhases     ( Phase(..), phaseInputExt )
 import Config
@@ -144,7 +145,7 @@ import {-# SOURCE #-} ErrUtils ( Severity(..), MsgDoc, mkLocMessage )
 import System.IO.Unsafe ( unsafePerformIO )
 #endif
 import Data.IORef
-import Control.Monad    ( when )
+import Control.Monad
 
 import Data.Char
 import Data.List
@@ -325,6 +326,8 @@ data DynFlag
    | Opt_GranMacros
    | Opt_PIC
    | Opt_SccProfilingOn
+   | Opt_Ticky
+   | Opt_Static
 
    -- output style opts
    | Opt_PprCaseAsLet
@@ -852,12 +855,8 @@ isNoLink :: GhcLink -> Bool
 isNoLink NoLink = True
 isNoLink _      = False
 
--- Is it worth evaluating this Bool and caching it in the DynFlags value
--- during initDynFlags?
 doingTickyProfiling :: DynFlags -> Bool
-doingTickyProfiling _ = opt_Ticky
-  -- XXX -ticky is a static flag, because it implies -debug which is also
-  -- static.  If the way flags were made dynamic, we could fix this.
+doingTickyProfiling dflags = dopt Opt_Ticky dflags
 
 data PackageFlag
   = ExposePackage   String
@@ -899,19 +898,184 @@ data DynLibLoader
 data RtsOptsEnabled = RtsOptsNone | RtsOptsSafeOnly | RtsOptsAll
   deriving (Show)
 
+-----------------------------------------------------------------------------
+-- Ways
+
+-- The central concept of a "way" is that all objects in a given
+-- program must be compiled in the same "way".  Certain options change
+-- parameters of the virtual machine, eg. profiling adds an extra word
+-- to the object header, so profiling objects cannot be linked with
+-- non-profiling objects.
+
+-- After parsing the command-line options, we determine which "way" we
+-- are building - this might be a combination way, eg. profiling+threaded.
+
+-- We then find the "build-tag" associated with this way, and this
+-- becomes the suffix used to find .hi files and libraries used in
+-- this compilation.
+
+data Way
+  = WayThreaded
+  | WayDebug
+  | WayProf
+  | WayEventLog
+  | WayPar
+  | WayGran
+  | WayNDP
+  | WayDyn
+  deriving (Eq,Ord)
+
+allowed_combination :: [Way] -> Bool
+allowed_combination way = and [ x `allowedWith` y
+                              | x <- way, y <- way, x < y ]
+  where
+        -- Note ordering in these tests: the left argument is
+        -- <= 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
+
+        WayProf `allowedWith` WayNDP            = True
+        WayThreaded `allowedWith` WayProf       = True
+        WayThreaded `allowedWith` WayEventLog   = True
+        _ `allowedWith` _                       = False
+
+mkBuildTag :: [Way] -> String
+mkBuildTag ways = concat (intersperse "_" (map wayTag ways))
+
+wayTag :: Way -> String
+wayTag WayThreaded = "thr"
+wayTag WayDebug    = "debug"
+wayTag WayDyn      = "dyn"
+wayTag WayProf     = "p"
+wayTag WayEventLog = "l"
+wayTag WayPar      = "mp"
+-- wayTag WayPar      = "mt"
+-- wayTag WayPar      = "md"
+wayTag WayGran     = "mg"
+wayTag WayNDP      = "ndp"
+
+wayRTSOnly :: Way -> Bool
+wayRTSOnly WayThreaded = True
+wayRTSOnly WayDebug    = True
+wayRTSOnly WayDyn      = False
+wayRTSOnly WayProf     = False
+wayRTSOnly WayEventLog = True
+wayRTSOnly WayPar      = False
+-- wayRTSOnly WayPar      = False
+-- wayRTSOnly WayPar      = False
+wayRTSOnly WayGran     = False
+wayRTSOnly WayNDP      = False
+
+wayDesc :: Way -> String
+wayDesc WayThreaded = "Threaded"
+wayDesc WayDebug    = "Debug"
+wayDesc WayDyn      = "Dynamic"
+wayDesc WayProf     = "Profiling"
+wayDesc WayEventLog = "RTS Event Logging"
+wayDesc WayPar      = "Parallel"
+-- wayDesc WayPar      = "Parallel ticky profiling"
+-- wayDesc WayPar      = "Distributed"
+wayDesc WayGran     = "GranSim"
+wayDesc WayNDP      = "Nested data parallelism"
+
+wayOpts :: Way -> DynP ()
+wayOpts WayThreaded = do
+#if defined(freebsd_TARGET_OS)
+--        "-optc-pthread"
+--      , "-optl-pthread"
+        -- FreeBSD's default threading library is the KSE-based M:N libpthread,
+        -- which GHC has some problems with.  It's currently not clear whether
+        -- the problems are our fault or theirs, but it seems that using the
+        -- alternative 1:1 threading library libthr works around it:
+          upd $ addOptl "-lthr"
+#elif defined(openbsd_TARGET_OS) || defined(netbsd_TARGET_OS)
+          upd $ addOptc "-pthread"
+          upd $ addOptl "-pthread"
+#elif defined(solaris2_TARGET_OS)
+          upd $ addOptl "-lrt"
+#endif
+          return ()
+wayOpts WayDebug = return ()
+wayOpts WayDyn = do
+        upd $ addOptP "-DDYNAMIC"
+        upd $ addOptc "-DDYNAMIC"
+#if defined(mingw32_TARGET_OS)
+        -- On Windows, code that is to be linked into a dynamic library must be compiled
+        --      with -fPIC. Labels not in the current package are assumed to be in a DLL
+        --      different from the current one.
+        setFPIC
+#elif defined(darwin_TARGET_OS)
+        setFPIC
+#elif defined(openbsd_TARGET_OS) || defined(netbsd_TARGET_OS)
+        -- Without this, linking the shared libHSffi fails because
+        -- it uses pthread mutexes.
+        upd $ addOptl "-optl-pthread"
+#endif
+wayOpts WayProf = do
+        setDynFlag Opt_SccProfilingOn
+        upd $ addOptP "-DPROFILING"
+        upd $ addOptc "-DPROFILING"
+wayOpts WayEventLog = do
+        upd $ addOptP "-DTRACING"
+        upd $ addOptc "-DTRACING"
+wayOpts WayPar = do
+        setDynFlag Opt_Parallel
+        upd $ addOptP "-D__PARALLEL_HASKELL__"
+        upd $ addOptc "-DPAR"
+        exposePackage "concurrent"
+        upd $ addOptc "-w"
+        upd $ addOptl "-L${PVM_ROOT}/lib/${PVM_ARCH}"
+        upd $ addOptl "-lpvm3"
+        upd $ addOptl "-lgpvm3"
+{-
+wayOpts WayPar =
+        [ "-fparallel"
+        , "-D__PARALLEL_HASKELL__"
+        , "-optc-DPAR"
+        , "-optc-DPAR_TICKY"
+        , "-package concurrent"
+        , "-optc-w"
+        , "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}"
+        , "-optl-lpvm3"
+        , "-optl-lgpvm3" ]
+wayOpts WayPar =
+        [ "-fparallel"
+        , "-D__PARALLEL_HASKELL__"
+        , "-D__DISTRIBUTED_HASKELL__"
+        , "-optc-DPAR"
+        , "-optc-DDIST"
+        , "-package concurrent"
+        , "-optc-w"
+        , "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}"
+        , "-optl-lpvm3"
+        , "-optl-lgpvm3" ]
+-}
+wayOpts WayGran = do
+        setDynFlag Opt_GranMacros
+        upd $ addOptP "-D__GRANSIM__"
+        upd $ addOptc "-DGRAN"
+        exposePackage "concurrent"
+wayOpts WayNDP = do
+        setExtensionFlag Opt_ParallelArrays
+        setDynFlag Opt_Vectorise
+
+-----------------------------------------------------------------------------
+
 -- | Used by 'GHC.newSession' to partially initialize a new 'DynFlags' value
 initDynFlags :: DynFlags -> IO DynFlags
 initDynFlags dflags = do
- -- someday these will be dynamic flags
- ways <- readIORef v_Ways
  refFilesToClean <- newIORef []
  refDirsToClean <- newIORef Map.empty
  refGeneratedDumps <- newIORef Set.empty
  refLlvmVersion <- newIORef 28
  return dflags{
-        ways           = ways,
-        buildTag       = mkBuildTag (filter (not . wayRTSOnly) ways),
-        rtsBuildTag    = mkBuildTag ways,
         filesToClean   = refFilesToClean,
         dirsToClean    = refDirsToClean,
         generatedDumps = refGeneratedDumps,
@@ -980,7 +1144,7 @@ defaultDynFlags mySettings =
         packageFlags            = [],
         pkgDatabase             = Nothing,
         pkgState                = panic "no package state yet: call GHC.setSessionDynFlags",
-        ways                    = panic "defaultDynFlags: No ways",
+        ways                    = [],
         buildTag                = panic "defaultDynFlags: No buildTag",
         rtsBuildTag             = panic "defaultDynFlags: No rtsBuildTag",
         splitInfo               = Nothing,
@@ -1286,7 +1450,7 @@ getVerbFlags dflags
 setObjectDir, setHiDir, setStubDir, setDumpDir, setOutputDir,
          setDylibInstallName,
          setObjectSuf, setHiSuf, setHcSuf, parseDynLibLoaderMode,
-         setPgmP, addOptl, addOptP,
+         setPgmP, addOptl, addOptc, addOptP,
          addCmdlineFramework, addHaddockOpts, addGhciScript, 
          setInteractivePrint
    :: String -> DynFlags -> DynFlags
@@ -1332,6 +1496,7 @@ setDumpPrefixForce f d = d { dumpPrefixForce = f}
 -- Config.hs should really use Option.
 setPgmP   f = let (pgm:args) = words f in alterSettings (\s -> s { sPgm_P   = (pgm, map Option args)})
 addOptl   f = alterSettings (\s -> s { sOpt_l   = f : sOpt_l s})
+addOptc   f = alterSettings (\s -> s { sOpt_c   = f : sOpt_c s})
 addOptP   f = alterSettings (\s -> s { sOpt_P   = f : sOpt_P s})
 
 
@@ -1483,7 +1648,19 @@ parseDynamicFlagsFull activeFlags cmdline dflags0 args = do
   -- check for disabled flags in safe haskell
   let (dflags2, sh_warns) = safeFlagCheck cmdline dflags1
 
-  return (dflags2, leftover, sh_warns ++ warns)
+      theWays = sort $ nub $ ways dflags2
+      theBuildTag = mkBuildTag (filter (not . wayRTSOnly) theWays)
+      dflags3 = dflags2 {
+                    ways        = theWays,
+                    buildTag    = theBuildTag,
+                    rtsBuildTag = mkBuildTag theWays
+                }
+
+  unless (allowed_combination theWays) $
+      ghcError (CmdLineError ("combination not supported: "  ++
+                              intercalate "/" (map wayDesc theWays)))
+
+  return (dflags3, leftover, sh_warns ++ warns)
 
 
 -- | Check (and potentially disable) any extensions that aren't allowed
@@ -1579,6 +1756,32 @@ dynamic_flags = [
                            addWarn "-#include and INCLUDE pragmas are deprecated: They no longer have any effect"))
   , Flag "v"        (OptIntSuffix setVerbosity)
 
+        ------- ways --------------------------------------------------------
+  , Flag "prof"           (NoArg (addWay WayProf))
+  , Flag "eventlog"       (NoArg (addWay WayEventLog))
+  , Flag "parallel"       (NoArg (addWay WayPar))
+  , Flag "gransim"        (NoArg (addWay WayGran))
+  , Flag "smp"            (NoArg (addWay WayThreaded >> deprecate "Use -threaded instead"))
+  , Flag "debug"          (NoArg (addWay WayDebug))
+  , Flag "ndp"            (NoArg (addWay WayNDP))
+  , Flag "threaded"       (NoArg (addWay WayThreaded))
+
+  , Flag "ticky"          (NoArg (setDynFlag Opt_Ticky >> addWay WayDebug))
+
+    -- -ticky enables ticky-ticky code generation, and also implies -debug which
+    -- is required to get the RTS ticky support.
+
+        ----- Linker --------------------------------------------------------
+  -- -static is the default. If -dynamic has been given then, due to the
+  -- way wayOpts is currently used, we've already set -DDYNAMIC etc.
+  -- It's too fiddly to undo that, so we just give an error if
+  -- Opt_Static has been unset.
+  , Flag "static"         (noArgM (\dfs -> do unless (dopt Opt_Static dfs) (addErr "Can't use -static after -dynamic")
+                                              return dfs))
+  , Flag "dynamic"        (NoArg (unSetDynFlag Opt_Static >> addWay WayDyn))
+    -- ignored for compat w/ gcc:
+  , Flag "rdynamic"       (NoArg (return ()))
+
         ------- Specific phases  --------------------------------------------
     -- need to appear before -pgmL to be parsed as LLVM flags.
   , Flag "pgmlo"          (hasArg (\f -> alterSettings (\s -> s { sPgm_lo  = (f,[])})))
@@ -1600,7 +1803,7 @@ dynamic_flags = [
   , Flag "optL"           (hasArg (\f -> alterSettings (\s -> s { sOpt_L   = f : sOpt_L s})))
   , Flag "optP"           (hasArg addOptP)
   , Flag "optF"           (hasArg (\f -> alterSettings (\s -> s { sOpt_F   = f : sOpt_F s})))
-  , Flag "optc"           (hasArg (\f -> alterSettings (\s -> s { sOpt_c   = f : sOpt_c s})))
+  , Flag "optc"           (hasArg addOptc)
   , Flag "optm"           (HasArg (\_ -> addWarn "The -optm flag does nothing; it will be removed in a future GHC release"))
   , Flag "opta"           (hasArg (\f -> alterSettings (\s -> s { sOpt_a   = f : sOpt_a s})))
   , Flag "optl"           (hasArg addOptl)
@@ -2064,9 +2267,6 @@ fFlags = [
   ( "ghci-history",                     Opt_GhciHistory, nop ),
   ( "helpful-errors",                   Opt_HelpfulErrors, nop ),
   ( "defer-type-errors",                Opt_DeferTypeErrors, nop ),
-  ( "parallel",                         Opt_Parallel, nop ),
-  ( "scc-profiling",                    Opt_SccProfilingOn, nop ),
-  ( "gransim",                          Opt_GranMacros, nop ),
   ( "building-cabal-package",           Opt_BuildingCabalPackage, nop ),
   ( "implicit-import-qualified",        Opt_ImplicitImportQualified, nop ),
   ( "prof-count-entries",               Opt_ProfCountEntries, nop ),
@@ -2239,6 +2439,7 @@ xFlags = [
 defaultFlags :: Platform -> [DynFlag]
 defaultFlags platform
   = [ Opt_AutoLinkPackages,
+      Opt_Static,
 
       Opt_SharedImplib,
 
@@ -2260,7 +2461,6 @@ defaultFlags platform
         OSDarwin ->
             case platformArch platform of
             ArchX86_64         -> [Opt_PIC]
-            _ | not opt_Static -> [Opt_PIC]
             _                  -> []
         _ -> [])
 
@@ -2523,6 +2723,11 @@ optIntSuffixM fn = OptIntSuffix (\mi -> updM (fn mi))
 setDumpFlag :: DynFlag -> OptKind (CmdLineP DynFlags)
 setDumpFlag dump_flag = NoArg (setDumpFlag' dump_flag)
 
+--------------------------
+addWay :: Way -> DynP ()
+addWay w = do upd (\dfs -> dfs { ways = w : ways dfs })
+              wayOpts w
+
 --------------------------
 setDynFlag, unSetDynFlag :: DynFlag -> DynP ()
 setDynFlag   f = upd (\dfs -> dopt_set dfs f)
@@ -2667,7 +2872,7 @@ setObjTarget l = updM set
                 return dflags
          HscLlvm
           | not ((arch == ArchX86_64) && (os == OSLinux || os == OSDarwin)) &&
-            (not opt_Static || dopt Opt_PIC dflags)
+            (not (dopt Opt_Static dflags) || dopt Opt_PIC dflags)
             ->
              do addWarn ("Ignoring " ++ flag ++ " as it is incompatible with -fPIC and -dynamic on this platform")
                 return dflags
@@ -2704,7 +2909,7 @@ unSetFPIC = updM set
              | platformArch platform == ArchX86_64 ->
                 do addWarn "Ignoring -fno-PIC on this platform"
                    return dflags
-            _ | not opt_Static ->
+            _ | not (dopt Opt_Static dflags) ->
                 do addWarn "Ignoring -fno-PIC as -fstatic is off"
                    return dflags
             _ -> return $ dopt_unset dflags Opt_PIC
@@ -2879,7 +3084,8 @@ picCCOpts dflags
       -- correctly.  They need to reference data in the Haskell
       -- objects, but can't without -fPIC.  See
       -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/PositionIndependentCode
-       | dopt Opt_PIC dflags || not opt_Static -> ["-fPIC", "-U __PIC__", "-D__PIC__"]
+       | dopt Opt_PIC dflags || not (dopt Opt_Static dflags) ->
+          ["-fPIC", "-U __PIC__", "-D__PIC__"]
        | otherwise                             -> []
 
 picPOpts :: DynFlags -> [String]

compiler/main/Packages.lhs

@@ -37,7 +37,6 @@ where
 
 import PackageConfig
 import DynFlags
-import StaticFlags
 import Config           ( cProjectVersion )
 import Name             ( Name, nameModule_maybe )
 import UniqFM
@@ -896,7 +895,7 @@ packageHsLibs dflags p = map (mkDynName . addSuffix) (hsLibraries p)
         tag     = mkBuildTag (filter (not . wayRTSOnly) ways2)