Commit 46258b40 authored by ian@well-typed.com's avatar ian@well-typed.com

Make the ways dynamic

parent 494eb3dc
......@@ -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
......
......@@ -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]
......
This diff is collapsed.
......@@ -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
......
......@@ -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
......
......@@ -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,206 +289,15 @@ 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
......@@ -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
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
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