Make the ways dynamic
authorIan Lynagh <ian@well-typed.com>
Mon, 3 Sep 2012 16:02:18 +0000 (17:02 +0100)
committerIan Lynagh <ian@well-typed.com>
Mon, 3 Sep 2012 16:02:18 +0000 (17:02 +0100)
compiler/cmm/CLabel.hs
compiler/main/DriverPipeline.hs
compiler/main/DynFlags.hs
compiler/main/Packages.lhs
compiler/main/StaticFlagParser.hs
compiler/main/StaticFlags.hs
compiler/main/TidyPgm.lhs
compiler/nativeGen/PIC.hs
compiler/simplCore/CoreMonad.lhs
compiler/stgSyn/StgSyn.lhs

index 6ffbbc7..ed4b567 100644 (file)
@@ -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
index 6eff097..a579519 100644 (file)
@@ -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]
 
index b227172..8a87188 100644 (file)
@@ -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]
             _                  -> []
         _ -> [])
 
@@ -2524,6 +2724,11 @@ 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)
 unSetDynFlag f = upd (\dfs -> dopt_unset 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]
index 0f9ab36..87e573e 100644 (file)
@@ -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)
         rts_tag = mkBuildTag ways2
 
-        mkDynName | opt_Static = id
+        mkDynName | dopt Opt_Static dflags = id
                   | otherwise = (++ ("-ghc" ++ cProjectVersion))
 
         addSuffix rts@"HSrts"    = rts       ++ (expandTag rts_tag)
@@ -1031,12 +1030,12 @@ missingDependencyMsg (Just parent)
 -- -----------------------------------------------------------------------------
 
 -- | Will the 'Name' come from a dynamically linked library?
-isDllName :: PackageId -> Name -> Bool
+isDllName :: DynFlags -> PackageId -> Name -> Bool
 -- Despite the "dll", I think this function just means that
 -- the synbol comes from another dynamically-linked package,
 -- and applies on all platforms, not just Windows
-isDllName this_pkg name
-  | opt_Static = False
+isDllName dflags this_pkg name
+  | dopt Opt_Static dflags = False
   | Just mod <- nameModule_maybe name = modulePackageId mod /= this_pkg
   | otherwise = False  -- no, it is not even an external name
 
index 8f6ff84..05a4639 100644 (file)
@@ -18,8 +18,7 @@ module StaticFlagParser (
 #include "HsVersions.h"
 
 import qualified StaticFlags as SF
-import StaticFlags ( v_opt_C_ready, getWayFlags, Way(..)
-                   , opt_SimplExcessPrecision )
+import StaticFlags ( v_opt_C_ready, opt_SimplExcessPrecision )
 import CmdLineParser
 import SrcLoc
 import Util
@@ -60,18 +59,9 @@ parseStaticFlagsFull flagsAvailable args = do
   ready <- readIORef v_opt_C_ready
   when ready $ ghcError (ProgramError "Too late for parseStaticFlags: call it before newSession")
 
-  (leftover, errs, warns1) <- processArgs flagsAvailable args
+  (leftover, errs, warns) <- processArgs flagsAvailable args
   when (not (null errs)) $ ghcError $ errorsToGhcException errs
 
-    -- deal with the way flags: the way (eg. prof) gives rise to
-    -- further flags, some of which might be static.
-  way_flags <- getWayFlags
-  let way_flags' = map (mkGeneralLocated "in way flags") way_flags
-
-    -- as these are GHC generated flags, we parse them with all static flags
-    -- in scope, regardless of what availableFlags are passed in.
-  (more_leftover, errs, warns2) <- processArgs flagsStatic way_flags'
-
     -- see sanity code in staticOpts
   writeIORef v_opt_C_ready True
 
@@ -83,9 +73,7 @@ parseStaticFlagsFull flagsAvailable args = do
                                         ["-fexcess-precision"]
        | otherwise                = []
 
-  when (not (null errs)) $ ghcError $ errorsToGhcException errs
-  return (excess_prec ++ more_leftover ++ leftover,
-          warns1 ++ warns2)
+  return (excess_prec ++ leftover, warns)
 
 flagsStatic :: [Flag IO]
 -- All the static flags should appear in this list.  It describes how each
@@ -102,22 +90,8 @@ flagsStatic :: [Flag IO]
 -- flags further down the list with the same prefix.
 
 flagsStatic = [
-        ------- 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"          (PassFlag (\f -> do addOpt f; addWay WayDebug))
-    -- -ticky enables ticky-ticky code generation, and also implies -debug which
-    -- is required to get the RTS ticky support.
-
         ------ Debugging ----------------------------------------------------
-  , Flag "dppr-debug"                  (PassFlag addOpt)
+    Flag "dppr-debug"                  (PassFlag addOpt)
   , Flag "dsuppress-all"               (PassFlag addOpt)
   , Flag "dsuppress-uniques"           (PassFlag addOpt)
   , Flag "dsuppress-coercions"         (PassFlag addOpt)
@@ -131,12 +105,6 @@ flagsStatic = [
   , Flag "dstub-dead-values"           (PassFlag addOpt)
       -- rest of the debugging flags are dynamic
 
-        ----- Linker --------------------------------------------------------
-  , Flag "static"         (PassFlag addOpt)
-  , Flag "dynamic"        (NoArg (removeOpt "-static" >> addWay WayDyn))
-    -- ignored for compat w/ gcc:
-  , Flag "rdynamic"       (NoArg (return ()))
-
         ----- RTS opts ------------------------------------------------------
   , Flag "H"              (HasArg (\s -> liftEwM (setHeapSize (fromIntegral (decodeSize s)))))
 
@@ -166,7 +134,6 @@ isStaticFlag f =
     "fno-pre-inlining",
     "fno-opt-coercion",
     "fexcess-precision",
-    "static",
     "fhardwire-lib-paths",
     "fcpr-off",
     "ferror-spans",
@@ -203,9 +170,6 @@ type StaticP = EwM IO
 addOpt :: String -> StaticP ()
 addOpt = liftEwM . SF.addOpt
 
-addWay :: Way -> StaticP ()
-addWay = liftEwM . SF.addWay
-
 removeOpt :: String -> StaticP ()
 removeOpt = liftEwM . SF.removeOpt
 
index ec5be5f..34acd98 100644 (file)
@@ -23,9 +23,6 @@ module StaticFlags (
        staticFlags,
         initStaticOpts,
 
-       -- Ways
-       Way(..), v_Ways, mkBuildTag, wayRTSOnly,
-
        -- Output style options
        opt_PprStyle_Debug,
         opt_NoDebugOutput,
@@ -66,18 +63,14 @@ module StaticFlags (
        -- Optimization fuel controls
        opt_Fuel,
 
-       -- Related to linking
-       opt_Static,
-
        -- misc opts
        opt_ErrorSpans,
        opt_HistorySize,
        v_Ld_inputs,
         opt_StubDeadValues,
-        opt_Ticky,
 
     -- For the parser
-    addOpt, removeOpt, addWay, getWayFlags, v_opt_C_ready,
+    addOpt, removeOpt, v_opt_C_ready,
 
     -- Saving/restoring globals
     saveStaticFlagGlobals, restoreStaticFlagGlobals
@@ -90,7 +83,7 @@ import Util
 import Maybes          ( firstJusts )
 import Panic
 
-import Control.Monad    ( liftM3 )
+import Control.Monad
 import Data.IORef
 import System.IO.Unsafe        ( unsafePerformIO )
 import Data.List
@@ -104,9 +97,6 @@ initStaticOpts = writeIORef v_opt_C_ready True
 addOpt :: String -> IO ()
 addOpt = consIORef v_opt_C
 
-addWay :: Way -> IO ()
-addWay = consIORef v_Ways
-
 removeOpt :: String -> IO ()
 removeOpt f = do
   fs <- readIORef v_opt_C
@@ -119,7 +109,7 @@ lookup_str       :: String -> Maybe String
 
 -- holds the static opts while they're being collected, before
 -- being unsafely read by unpacked_static_opts below.
-GLOBAL_VAR(v_opt_C, defaultStaticOpts, [String])
+GLOBAL_VAR(v_opt_C, [], [String])
 GLOBAL_VAR(v_opt_C_ready, False, Bool)
 
 staticFlags :: [String]
@@ -129,10 +119,6 @@ staticFlags = unsafePerformIO $ do
         then panic "Static flags have not been initialised!\n        Please call GHC.newSession or GHC.parseStaticFlags early enough."
         else readIORef v_opt_C
 
--- -static is the default
-defaultStaticOpts :: [String]
-defaultStaticOpts = ["-static"]
-
 packed_static_opts :: [FastString]
 packed_static_opts   = map mkFastString staticFlags
 
@@ -303,207 +289,16 @@ opt_UF_KeenessFactor      = lookup_def_float "-funfolding-keeness-factor"   (1.5::Fl
 opt_UF_DearOp            = ( 40 :: Int)
 
 
--- Related to linking
-opt_Static :: Bool
-opt_Static                     = lookUp  (fsLit "-static")
-
 -- Include full span info in error messages, instead of just the start position.
 opt_ErrorSpans :: Bool
 opt_ErrorSpans                 = lookUp (fsLit "-ferror-spans")
 
-opt_Ticky :: Bool
-opt_Ticky                       = lookUp (fsLit "-ticky")
-
 -- object files and libraries to be linked in are collected here.
 -- ToDo: perhaps this could be done without a global, it wasn't obvious
 -- how to do it though --SDM.
 GLOBAL_VAR(v_Ld_inputs,        [],      [String])
 
 -----------------------------------------------------------------------------
--- 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)
-
-GLOBAL_VAR(v_Ways, [] ,[Way])
-
-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
-
-
-getWayFlags :: IO [String]  -- new options
-getWayFlags = do
-  unsorted <- readIORef v_Ways
-  let ways = sort $ nub $ unsorted
-  writeIORef v_Ways ways
-
-  if not (allowed_combination ways)
-      then ghcError (CmdLineError $
-                   "combination not supported: "  ++
-                   foldr1 (\a b -> a ++ '/':b)
-                   (map wayDesc ways))
-      else
-          return (concatMap wayOpts ways)
-
-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 -> [String]
-wayOpts WayThreaded = [
-#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:
-          "-optl-lthr"
-#elif defined(openbsd_TARGET_OS) || defined(netbsd_TARGET_OS)
-          "-optc-pthread"
-        , "-optl-pthread"
-#elif defined(solaris2_TARGET_OS)
-          "-optl-lrt"
-#endif
-        ]
-wayOpts WayDebug = []
-wayOpts WayDyn =
-        [ "-DDYNAMIC"
-        , "-optc-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.
-        , "-fPIC"
-#elif defined(openbsd_TARGET_OS) || defined(netbsd_TARGET_OS)
-        -- Without this, linking the shared libHSffi fails because
-        -- it uses pthread mutexes.
-        , "-optl-pthread"
-#endif
-        ]
-wayOpts WayProf =
-        [ "-fscc-profiling"
-        , "-DPROFILING"
-        , "-optc-DPROFILING" ]
-wayOpts WayEventLog =
-        [ "-DTRACING"
-        , "-optc-DTRACING" ]
-wayOpts WayPar =
-        [ "-fparallel"
-        , "-D__PARALLEL_HASKELL__"
-        , "-optc-DPAR"
-        , "-package concurrent"
-        , "-optc-w"
-        , "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}"
-        , "-optl-lpvm3"
-        , "-optl-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 =
-        [ "-fgransim"
-        , "-D__GRANSIM__"
-        , "-optc-DGRAN"
-        , "-package concurrent" ]
-wayOpts WayNDP =
-        [ "-XParr"
-        , "-fvectorise"]
-
------------------------------------------------------------------------------
 -- Tunneling our global variables into a new instance of the GHC library
 
 -- Ignore the v_Ld_inputs global because:
@@ -512,12 +307,11 @@ wayOpts WayNDP =
 --  b) We can get away without sharing it because it only affects the link,
 --     and is mutated by the GHC exe. Users who load up a new copy of the GHC
 --     library while another is running almost certainly won't actually access it.
-saveStaticFlagGlobals :: IO (Bool, [String], [Way])
-saveStaticFlagGlobals = liftM3 (,,) (readIORef v_opt_C_ready) (readIORef v_opt_C) (readIORef v_Ways)
+saveStaticFlagGlobals :: IO (Bool, [String])
+saveStaticFlagGlobals = liftM2 (,) (readIORef v_opt_C_ready) (readIORef v_opt_C)
 
-restoreStaticFlagGlobals :: (Bool, [String], [Way]) -> IO ()
-restoreStaticFlagGlobals (c_ready, c, ways) = do
+restoreStaticFlagGlobals :: (Bool, [String]) -> IO ()
+restoreStaticFlagGlobals (c_ready, c) = do
     writeIORef v_opt_C_ready c_ready
     writeIORef v_opt_C c
-    writeIORef v_Ways ways
 
index bea9f14..ffd5de8 100644 (file)
@@ -47,7 +47,6 @@ import Module
 import Packages( isDllName )
 import HscTypes
 import Maybes
-import Platform
 import UniqSupply
 import ErrUtils (Severity(..))
 import Outputable
@@ -1049,20 +1048,20 @@ tidyTopBinds hsc_env unfold_env init_occ_env binds
                     $ initTcForLookup hsc_env (tcLookupGlobal mkIntegerName)
        return $ tidy mkIntegerId init_env binds
   where
-    platform = targetPlatform (hsc_dflags hsc_env)
+    dflags = hsc_dflags hsc_env
 
     init_env = (init_occ_env, emptyVarEnv)
 
-    this_pkg = thisPackage (hsc_dflags hsc_env)
+    this_pkg = thisPackage dflags
 
     tidy _           env []     = (env, [])
-    tidy mkIntegerId env (b:bs) = let (env1, b')  = tidyTopBind platform this_pkg mkIntegerId unfold_env env b
+    tidy mkIntegerId env (b:bs) = let (env1, b')  = tidyTopBind dflags this_pkg mkIntegerId unfold_env env b
                                       (env2, bs') = tidy mkIntegerId env1 bs
                                   in
                                       (env2, b':bs')
 
 ------------------------
-tidyTopBind  :: Platform
+tidyTopBind  :: DynFlags
              -> PackageId
              -> Id
              -> UnfoldEnv
@@ -1070,16 +1069,16 @@ tidyTopBind  :: Platform
              -> CoreBind
              -> (TidyEnv, CoreBind)
 
-tidyTopBind platform this_pkg mkIntegerId unfold_env (occ_env,subst1) (NonRec bndr rhs)
+tidyTopBind dflags this_pkg mkIntegerId unfold_env (occ_env,subst1) (NonRec bndr rhs)
   = (tidy_env2,  NonRec bndr' rhs')
   where
     Just (name',show_unfold) = lookupVarEnv unfold_env bndr
-    caf_info      = hasCafRefs platform this_pkg (mkIntegerId, subst1) (idArity bndr) rhs
+    caf_info      = hasCafRefs dflags this_pkg (mkIntegerId, subst1) (idArity bndr) rhs
     (bndr', rhs') = tidyTopPair show_unfold tidy_env2 caf_info name' (bndr, rhs)
     subst2        = extendVarEnv subst1 bndr bndr'
     tidy_env2     = (occ_env, subst2)
 
-tidyTopBind platform this_pkg mkIntegerId unfold_env (occ_env,subst1) (Rec prs)
+tidyTopBind dflags this_pkg mkIntegerId unfold_env (occ_env,subst1) (Rec prs)
   = (tidy_env2, Rec prs')
   where
     prs' = [ tidyTopPair show_unfold tidy_env2 caf_info name' (id,rhs)
@@ -1096,7 +1095,7 @@ tidyTopBind platform this_pkg mkIntegerId unfold_env (occ_env,subst1) (Rec prs)
         -- the CafInfo for a recursive group says whether *any* rhs in
         -- the group may refer indirectly to a CAF (because then, they all do).
     caf_info
-        | or [ mayHaveCafRefs (hasCafRefs platform this_pkg (mkIntegerId, subst1) (idArity bndr) rhs)
+        | or [ mayHaveCafRefs (hasCafRefs dflags this_pkg (mkIntegerId, subst1) (idArity bndr) rhs)
              | (bndr,rhs) <- prs ] = MayHaveCafRefs
         | otherwise                = NoCafRefs
 
@@ -1233,15 +1232,15 @@ it as a CAF.  In these cases however, we would need to use an additional
 CAF list to keep track of non-collectable CAFs.
 
 \begin{code}
-hasCafRefs :: Platform -> PackageId -> (Id, VarEnv Var) -> Arity -> CoreExpr
+hasCafRefs :: DynFlags -> PackageId -> (Id, VarEnv Var) -> Arity -> CoreExpr
            -> CafInfo
-hasCafRefs platform this_pkg p arity expr
+hasCafRefs dflags this_pkg p arity expr
   | is_caf || mentions_cafs = MayHaveCafRefs
   | otherwise               = NoCafRefs
  where
   mentions_cafs = isFastTrue (cafRefsE p expr)
-  is_dynamic_name = isDllName this_pkg
-  is_caf = not (arity > 0 || rhsIsStatic platform is_dynamic_name expr)
+  is_dynamic_name = isDllName dflags this_pkg
+  is_caf = not (arity > 0 || rhsIsStatic (targetPlatform dflags) is_dynamic_name expr)
 
   -- NB. we pass in the arity of the expression, which is expected
   -- to be calculated by exprArity.  This is because exprArity
index fb75d87..0b5ffcd 100644 (file)
@@ -75,7 +75,6 @@ import CLabel           ( CLabel, ForeignLabelSource(..), pprCLabel,
 import CLabel           ( mkForeignLabel )
 
 
-import StaticFlags     ( opt_Static )
 import BasicTypes
 
 import Outputable
@@ -161,7 +160,7 @@ cmmMakePicReference dflags lbl
        = CmmLit $ CmmLabel lbl
 
 
-       | (dopt Opt_PIC dflags || not opt_Static) && absoluteLabel lbl 
+       | (dopt Opt_PIC dflags || not (dopt Opt_Static dflags)) && absoluteLabel lbl 
        = CmmMachOp (MO_Add wordWidth) 
                [ CmmReg (CmmGlobal PicBaseReg)
                , CmmLit $ picRelative 
@@ -214,14 +213,14 @@ howToAccessLabel
 -- To access the function at SYMBOL from our local module, we just need to
 -- dereference the local __imp_SYMBOL.
 --
--- If opt_Static is set then we assume that all our code will be linked
+-- If Opt_Static is set then we assume that all our code will be linked
 -- into the same .exe file. In this case we always access symbols directly, 
 -- and never use __imp_SYMBOL.
 --
 howToAccessLabel dflags _ OSMinGW32 _ lbl
 
        -- Assume all symbols will be in the same PE, so just access them directly.
-       | opt_Static
+       | dopt Opt_Static dflags
        = AccessDirectly
        
        -- If the target symbol is in another PE we need to access it via the
@@ -307,7 +306,7 @@ howToAccessLabel dflags _ os _ _
        --           if we don't dynamically link to Haskell code,
        --           it actually manages to do so without messing thins up.
        | osElfTarget os
-       , not (dopt Opt_PIC dflags) && opt_Static 
+       , not (dopt Opt_PIC dflags) && dopt Opt_Static dflags
        = AccessDirectly
 
 howToAccessLabel dflags arch os DataReference lbl
@@ -429,12 +428,12 @@ needImportedSymbols dflags arch os
        -- PowerPC Linux: -fPIC or -dynamic
        | osElfTarget os
        , arch  == ArchPPC
-       = dopt Opt_PIC dflags || not opt_Static
+       = dopt Opt_PIC dflags || not (dopt Opt_Static dflags)
 
        -- i386 (and others?): -dynamic but not -fPIC
        | osElfTarget os
        , arch  /= ArchPPC_64
-       = not opt_Static && not (dopt Opt_PIC dflags)
+       = not (dopt Opt_Static dflags) && not (dopt Opt_PIC dflags)
 
        | otherwise
        = False
@@ -623,7 +622,7 @@ pprImportedSymbol _ (Platform { platformOS = OSDarwin }) _
 --    section.
 --    The "official" GOT mechanism (label@got) isn't intended to be used
 --    in position dependent code, so we have to create our own "fake GOT"
---    when not Opt_PIC && not opt_Static.
+--    when not Opt_PIC && not (dopt Opt_Static dflags).
 --
 -- 2) PowerPC Linux is just plain broken.
 --    While it's theoretically possible to use GOT offsets larger
index b1429c5..5c97fbd 100644 (file)
@@ -720,7 +720,7 @@ data CoreReader = CoreReader {
         cr_hsc_env :: HscEnv,
         cr_rule_base :: RuleBase,
         cr_module :: Module,
-        cr_globals :: ((Bool, [String], [Way]),
+        cr_globals :: ((Bool, [String]),
 #ifdef GHCI
                        (MVar PersistentLinkerState, Bool))
 #else
index 84a4c69..e5c525e 100644 (file)
@@ -106,14 +106,14 @@ data GenStgArg occ
 isDllConApp :: DynFlags -> DataCon -> [StgArg] -> Bool
 isDllConApp dflags con args
  | platformOS (targetPlatform dflags) == OSMinGW32
-    = isDllName this_pkg (dataConName con) || any is_dll_arg args
+    = isDllName dflags this_pkg (dataConName con) || any is_dll_arg args
  | otherwise = False
   where
     -- NB: typePrimRep is legit because any free variables won't have
     -- unlifted type (there are no unlifted things at top level)
     is_dll_arg :: StgArg -> Bool
     is_dll_arg (StgVarArg v) =  isAddrRep (typePrimRep (idType v))
-                             && isDllName this_pkg (idName v)
+                             && isDllName dflags this_pkg (idName v)
     is_dll_arg _             = False
 
     this_pkg = thisPackage dflags