diff options
| -rw-r--r-- | compiler/basicTypes/Module.hs | 2 | ||||
| -rw-r--r-- | compiler/coreSyn/CorePrep.hs | 1 | ||||
| -rw-r--r-- | compiler/ghc.mk | 12 | ||||
| -rw-r--r-- | compiler/ghci/Debugger.hs | 6 | ||||
| -rw-r--r-- | compiler/ghci/GHCi.hs | 24 | ||||
| -rw-r--r-- | compiler/ghci/Linker.hs | 149 | ||||
| -rw-r--r-- | compiler/iface/LoadIface.hs | 2 | ||||
| -rw-r--r-- | compiler/main/DynFlags.hs | 14 | ||||
| -rw-r--r-- | compiler/main/DynFlags.hs-boot | 1 | ||||
| -rw-r--r-- | compiler/main/DynamicLoading.hs | 53 | ||||
| -rw-r--r-- | compiler/main/GHC.hs | 4 | ||||
| -rw-r--r-- | compiler/main/InteractiveEval.hs | 18 | ||||
| -rw-r--r-- | compiler/main/Packages.hs | 59 | ||||
| -rw-r--r-- | compiler/main/SysTools.hs | 10 | ||||
| -rw-r--r-- | compiler/simplCore/SimplCore.hs | 4 | ||||
| -rw-r--r-- | compiler/utils/Platform.hs | 10 | ||||
| -rw-r--r-- | configure.ac | 7 | ||||
| -rw-r--r-- | ghc/Main.hs | 10 | ||||
| -rw-r--r-- | libraries/ghci/GHCi/BreakArray.hs | 2 | ||||
| -rw-r--r-- | libraries/ghci/GHCi/InfoTable.hsc | 1 | ||||
| -rw-r--r-- | libraries/ghci/ghci.cabal.in | 11 | ||||
| -rw-r--r-- | settings.in | 4 |
22 files changed, 253 insertions, 151 deletions
diff --git a/compiler/basicTypes/Module.hs b/compiler/basicTypes/Module.hs index 339cb0f4f9..316e36e18a 100644 --- a/compiler/basicTypes/Module.hs +++ b/compiler/basicTypes/Module.hs @@ -664,7 +664,7 @@ newtype InstalledUnitId = -- | The full hashed unit identifier, including the component id -- and the hash. installedUnitIdFS :: FastString - } + } deriving Show instance Binary InstalledUnitId where put_ bh (InstalledUnitId fs) = put_ bh fs diff --git a/compiler/coreSyn/CorePrep.hs b/compiler/coreSyn/CorePrep.hs index 19b6364e1e..9b320fa383 100644 --- a/compiler/coreSyn/CorePrep.hs +++ b/compiler/coreSyn/CorePrep.hs @@ -55,7 +55,6 @@ import Pair import Outputable import Platform import FastString -import Config import Name ( NamedThing(..), nameSrcSpan ) import SrcLoc ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc ) import Data.Bits diff --git a/compiler/ghc.mk b/compiler/ghc.mk index 8a4cc4317d..966d9eefbb 100644 --- a/compiler/ghc.mk +++ b/compiler/ghc.mk @@ -55,10 +55,6 @@ compiler/stage%/build/Config.hs : mk/config.mk mk/project.mk | $$(dir $$@)/. @echo >> $@ @echo '#include "ghc_boot_platform.h"' >> $@ @echo >> $@ - @echo 'data IntegerLibrary = IntegerGMP' >> $@ - @echo ' | IntegerSimple' >> $@ - @echo ' deriving Eq' >> $@ - @echo >> $@ @echo 'cBuildPlatformString :: String' >> $@ @echo 'cBuildPlatformString = BuildPlatform_NAME' >> $@ @echo 'cHostPlatformString :: String' >> $@ @@ -84,14 +80,6 @@ compiler/stage%/build/Config.hs : mk/config.mk mk/project.mk | $$(dir $$@)/. @echo 'cBooterVersion = "$(GhcVersion)"' >> $@ @echo 'cStage :: String' >> $@ @echo 'cStage = show (STAGE :: Int)' >> $@ - @echo 'cIntegerLibraryType :: IntegerLibrary' >> $@ -ifeq "$(INTEGER_LIBRARY)" "integer-gmp" - @echo 'cIntegerLibraryType = IntegerGMP' >> $@ -else ifeq "$(INTEGER_LIBRARY)" "integer-simple" - @echo 'cIntegerLibraryType = IntegerSimple' >> $@ -else ifneq "$(CLEANING)" "YES" -$(error Unknown integer library) -endif @echo 'cSupportsSplitObjs :: String' >> $@ @echo 'cSupportsSplitObjs = "$(SupportsSplitObjs)"' >> $@ @echo 'cGhcWithInterpreter :: String' >> $@ diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs index 0db74cb5cb..650a10eeb9 100644 --- a/compiler/ghci/Debugger.hs +++ b/compiler/ghci/Debugger.hs @@ -125,7 +125,7 @@ bindSuspensions t = do | (name,ty) <- zip names tys] new_ic = extendInteractiveContextWithIds ictxt ids fhvs <- liftIO $ mapM (mkFinalizedHValue hsc_env <=< mkRemoteRef) hvals - liftIO $ extendLinkEnv (zip names fhvs) + liftIO $ extendLinkEnv hsc_env (zip names fhvs) setSession hsc_env {hsc_IC = new_ic } return t' where @@ -179,8 +179,8 @@ showTerm term = do expr = "show " ++ showPpr dflags bname _ <- GHC.setSessionDynFlags dflags{log_action=noop_log} fhv <- liftIO $ mkFinalizedHValue hsc_env =<< mkRemoteRef val - txt_ <- withExtendedLinkEnv [(bname, fhv)] - (GHC.compileExpr expr) + txt_ <- withExtendedLinkEnv hsc_env [(bname, fhv)] + (GHC.compileExpr expr) let myprec = 10 -- application precedence. TODO Infix constructors let txt = unsafeCoerce# txt_ :: [a] if not (null txt) then diff --git a/compiler/ghci/GHCi.hs b/compiler/ghci/GHCi.hs index 472f0857cb..09c7e7161b 100644 --- a/compiler/ghci/GHCi.hs +++ b/compiler/ghci/GHCi.hs @@ -49,9 +49,7 @@ module GHCi import GhcPrelude import GHCi.Message -#if defined(GHCI) import GHCi.Run -#endif import GHCi.RemoteTypes import GHCi.ResolvedBCO import GHCi.BreakArray (BreakArray) @@ -154,12 +152,6 @@ Other Notes on Remote GHCi * Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs -} -#if !defined(GHCI) -needExtInt :: IO a -needExtInt = throwIO - (InstallationError "this operation requires -fexternal-interpreter") -#endif - -- | Run a command in the interpreter's context. With -- @-fexternal-interpreter@, the command is serialized and sent to an -- external iserv process, and the response is deserialized (hence the @@ -172,11 +164,7 @@ iservCmd hsc_env@HscEnv{..} msg uninterruptibleMask_ $ do -- Note [uninterruptibleMask_] iservCall iserv msg | otherwise = -- Just run it directly -#if defined(GHCI) run msg -#else - needExtInt -#endif -- Note [uninterruptibleMask_ and iservCmd] -- @@ -377,11 +365,7 @@ lookupSymbol hsc_env@HscEnv{..} str writeIORef iservLookupSymbolCache $! addToUFM cache str p return (Just p) | otherwise = -#if defined(GHCI) fmap fromRemotePtr <$> run (LookupSymbol (unpackFS str)) -#else - needExtInt -#endif lookupClosure :: HscEnv -> String -> IO (Maybe HValueRef) lookupClosure hsc_env str = @@ -627,15 +611,9 @@ wormholeRef :: DynFlags -> RemoteRef a -> IO a wormholeRef dflags _r | gopt Opt_ExternalInterpreter dflags = throwIO (InstallationError - "this operation requires -fno-external-interpreter") -#if defined(GHCI) + "wormholeRef: this operation requires -fno-external-interpreter") | otherwise = localRef _r -#else - | otherwise - = throwIO (InstallationError - "can't wormhole a value in a stage1 compiler") -#endif -- ----------------------------------------------------------------------------- -- Misc utils diff --git a/compiler/ghci/Linker.hs b/compiler/ghci/Linker.hs index 3b030be2d3..9dfcea53f4 100644 --- a/compiler/ghci/Linker.hs +++ b/compiler/ghci/Linker.hs @@ -13,7 +13,7 @@ module Linker ( getHValue, showLinkerState, linkExpr, linkDecls, unload, withExtendedLinkEnv, extendLinkEnv, deleteFromLinkEnv, - extendLoadedPkgs, +-- extendLoadedPkgs, linkPackages,initDynLinker,linkModule, linkCmdLineLibs ) where @@ -94,27 +94,46 @@ The PersistentLinkerState maps Names to actual closures (for interpreted code only), for use during linking. -} #if STAGE < 2 -GLOBAL_VAR_M(v_PersistentLinkerState, newMVar (panic "Dynamic linker not initialised"), MVar PersistentLinkerState) -GLOBAL_VAR(v_InitLinkerDone, False, Bool) -- Set True when dynamic linker is initialised +GLOBAL_VAR_M( v_PersistentLinkerState + , newMVar (Nothing, Nothing) + , MVar (PersistentLinkerStates)) #else SHARED_GLOBAL_VAR_M( v_PersistentLinkerState , getOrSetLibHSghcPersistentLinkerState , "getOrSetLibHSghcPersistentLinkerState" - , newMVar (panic "Dynamic linker not initialised") - , MVar PersistentLinkerState) --- Set True when dynamic linker is initialised -SHARED_GLOBAL_VAR( v_InitLinkerDone - , getOrSetLibHSghcInitLinkerDone - , "getOrSetLibHSghcInitLinkerDone" - , False - , Bool) + , newMVar (Nothing, Nothing) + , MVar (PersistentLinkerStates)) #endif -modifyPLS_ :: (PersistentLinkerState -> IO PersistentLinkerState) -> IO () -modifyPLS_ f = readIORef v_PersistentLinkerState >>= flip modifyMVar_ f +uninitialised :: a +uninitialised = panic "Dynamic linker not initialised" + +modifyPLS_ :: HscEnv -> (PersistentLinkerState -> IO PersistentLinkerState) -> IO () +modifyPLS_ hsc_env f = readIORef v_PersistentLinkerState + >>= flip modifyMVar_ (liftPLS (fmap pure . f . fromMaybe uninitialised)) + where liftPLS f (x,y) + | gopt Opt_ExternalInterpreter (hsc_dflags hsc_env) = liftM (\y' -> (x, y')) (f y) + | otherwise = liftM (\x' -> (x', y)) (f x) + +modifyPLS :: HscEnv -> (PersistentLinkerState -> IO (PersistentLinkerState, a)) -> IO a +modifyPLS hsc_env f = readIORef v_PersistentLinkerState + >>= flip modifyMVar (liftPLS (fmapFst pure . f . fromMaybe uninitialised)) + where fmapFst f = fmap (\(x, y) -> (f x, y)) + liftPLS f (x,y) + | gopt Opt_ExternalInterpreter (hsc_dflags hsc_env) = liftM (\(y',z) -> ((x, y'), z)) (f y) + | otherwise = liftM (\(x', z) -> ((x', y), z)) (f x) + +readPLS :: IO PersistentLinkerStates +readPLS = readIORef v_PersistentLinkerState + >>= readMVar + +modifyMbPLS_ + :: HscEnv -> (Maybe PersistentLinkerState -> IO (Maybe PersistentLinkerState)) -> IO () +modifyMbPLS_ hsc_env f = readIORef v_PersistentLinkerState >>= flip modifyMVar_ (liftPLS f) + where liftPLS f (x,y) + | gopt Opt_ExternalInterpreter (hsc_dflags hsc_env) = liftM (\y' -> (x, y')) (f y) + | otherwise = liftM (\x' -> (x', y)) (f x) -modifyPLS :: (PersistentLinkerState -> IO (PersistentLinkerState, a)) -> IO a -modifyPLS f = readIORef v_PersistentLinkerState >>= flip modifyMVar f data PersistentLinkerState = PersistentLinkerState { @@ -144,39 +163,42 @@ data PersistentLinkerState -- libraries so we can link them (see #10322) temp_sos :: ![(FilePath, String)] } +type PersistentLinkerStates + = (Maybe PersistentLinkerState, Maybe PersistentLinkerState) -- (Local, Remote) -emptyPLS :: DynFlags -> PersistentLinkerState -emptyPLS _ = PersistentLinkerState { - closure_env = emptyNameEnv, - itbl_env = emptyNameEnv, - pkgs_loaded = init_pkgs, - bcos_loaded = [], - objs_loaded = [], - temp_sos = [] } +emptyPLS :: DynFlags -> PersistentLinkerState +emptyPLS _ = linker_state -- Packages that don't need loading, because the compiler -- shares them with the interpreted program. -- -- The linker's symbol table is populated with RTS symbols using an -- explicit list. See rts/Linker.c for details. where init_pkgs = map toInstalledUnitId [rtsUnitId] - - -extendLoadedPkgs :: [InstalledUnitId] -> IO () -extendLoadedPkgs pkgs = - modifyPLS_ $ \s -> - return s{ pkgs_loaded = pkgs ++ pkgs_loaded s } - -extendLinkEnv :: [(Name,ForeignHValue)] -> IO () -extendLinkEnv new_bindings = - modifyPLS_ $ \pls -> do - let ce = closure_env pls - let new_ce = extendClosureEnv ce new_bindings - return pls{ closure_env = new_ce } - -deleteFromLinkEnv :: [Name] -> IO () -deleteFromLinkEnv to_remove = - modifyPLS_ $ \pls -> do + linker_state = PersistentLinkerState + { closure_env = emptyNameEnv + , itbl_env = emptyNameEnv + , pkgs_loaded = init_pkgs + , bcos_loaded = [] + , objs_loaded = [] + , temp_sos = [] + } + +-- extendLoadedPkgs :: [InstalledUnitId] -> IO () +-- extendLoadedPkgs pkgs = +-- modifyPLS_ $ \s -> +-- return s{ pkgs_loaded = pkgs ++ pkgs_loaded s } + +extendLinkEnv :: HscEnv -> [(Name,ForeignHValue)] -> IO () +extendLinkEnv hsc_env new_bindings = + modifyPLS_ hsc_env $ \pls@PersistentLinkerState{..} -> do + let new_ce = extendClosureEnv closure_env new_bindings + return $! pls{ closure_env = new_ce } + -- strictness is important for not retaining old copies of the pls + +deleteFromLinkEnv :: HscEnv -> [Name] -> IO () +deleteFromLinkEnv hsc_env to_remove = + modifyPLS_ hsc_env $ \pls -> do let ce = closure_env pls let new_ce = delListFromNameEnv ce to_remove return pls{ closure_env = new_ce } @@ -189,7 +211,7 @@ deleteFromLinkEnv to_remove = getHValue :: HscEnv -> Name -> IO ForeignHValue getHValue hsc_env name = do initDynLinker hsc_env - pls <- modifyPLS $ \pls -> do + pls <- modifyPLS hsc_env $ \pls -> do if (isExternalName name) then do (pls', ok) <- linkDependencies hsc_env pls noSrcSpan [nameModule name] @@ -233,9 +255,10 @@ linkDependencies hsc_env pls span needed_mods = do -- | Temporarily extend the linker state. withExtendedLinkEnv :: (ExceptionMonad m) => + HscEnv -> [(Name,ForeignHValue)] -> m a -> m a -withExtendedLinkEnv new_env action - = gbracket (liftIO $ extendLinkEnv new_env) +withExtendedLinkEnv hsc_env new_env action + = gbracket (liftIO $ extendLinkEnv hsc_env new_env) (\_ -> reset_old_env) (\_ -> action) where @@ -245,7 +268,7 @@ withExtendedLinkEnv new_env action -- package), so the reset action only removes the names we -- added earlier. reset_old_env = liftIO $ do - modifyPLS_ $ \pls -> + modifyPLS_ hsc_env $ \pls -> let cur = closure_env pls new = delListFromNameEnv cur (map fst new_env) in return pls{ closure_env = new } @@ -254,13 +277,18 @@ withExtendedLinkEnv new_env action -- | Display the persistent linker state. showLinkerState :: DynFlags -> IO () showLinkerState dflags - = do pls <- readIORef v_PersistentLinkerState >>= readMVar + = do (ls_local, ls_remote) <- readPLS putLogMsg dflags NoReason SevDump noSrcSpan (defaultDumpStyle dflags) - (vcat [text "----- Linker state -----", - text "Pkgs:" <+> ppr (pkgs_loaded pls), - text "Objs:" <+> ppr (objs_loaded pls), - text "BCOs:" <+> ppr (bcos_loaded pls)]) + (vcat [text "----- Linker state (local) -----", + text "Pkgs:" <+> ppr (fromMaybe [] $ pkgs_loaded <$> ls_local), + text "Objs:" <+> ppr (fromMaybe [] $ objs_loaded <$> ls_local), + text "BCOs:" <+> ppr (fromMaybe [] $ bcos_loaded <$> ls_local), + text "----- Linker state (remote) -----", + text "Pkgs:" <+> ppr (fromMaybe [] $ pkgs_loaded <$> ls_remote), + text "Objs:" <+> ppr (fromMaybe [] $ objs_loaded <$> ls_remote), + text "BCOs:" <+> ppr (fromMaybe [] $ bcos_loaded <$> ls_remote) + ]) {- ********************************************************************** @@ -289,11 +317,10 @@ showLinkerState dflags -- initDynLinker :: HscEnv -> IO () initDynLinker hsc_env = - modifyPLS_ $ \pls0 -> do - done <- readIORef v_InitLinkerDone - if done then return pls0 - else do writeIORef v_InitLinkerDone True - reallyInitDynLinker hsc_env + modifyMbPLS_ hsc_env $ \pls -> do + case pls of + Just _ -> return pls + Nothing -> Just <$> reallyInitDynLinker hsc_env reallyInitDynLinker :: HscEnv -> IO PersistentLinkerState reallyInitDynLinker hsc_env = do @@ -314,7 +341,7 @@ reallyInitDynLinker hsc_env = do linkCmdLineLibs :: HscEnv -> IO () linkCmdLineLibs hsc_env = do initDynLinker hsc_env - modifyPLS_ $ \pls -> do + modifyPLS_ hsc_env $ \pls -> do linkCmdLineLibs' hsc_env pls linkCmdLineLibs' :: HscEnv -> PersistentLinkerState -> IO PersistentLinkerState @@ -539,7 +566,7 @@ linkExpr hsc_env span root_ul_bco ; initDynLinker hsc_env -- Take lock for the actual work. - ; modifyPLS $ \pls0 -> do { + ; modifyPLS hsc_env $ \pls0 -> do { -- Link the packages and modules required ; (pls, ok) <- linkDependencies hsc_env pls0 span needed_mods @@ -769,7 +796,7 @@ linkDecls hsc_env span cbc@CompiledByteCode{..} = do initDynLinker hsc_env -- Take lock for the actual work. - modifyPLS $ \pls0 -> do + modifyPLS hsc_env $ \pls0 -> do -- Link the packages and modules required (pls, ok) <- linkDependencies hsc_env pls0 span needed_mods @@ -809,11 +836,13 @@ linkDecls hsc_env span cbc@CompiledByteCode{..} = do linkModule :: HscEnv -> Module -> IO () linkModule hsc_env mod = do + putStrLn "[linkModule] linking mod..." initDynLinker hsc_env - modifyPLS_ $ \pls -> do + modifyPLS_ hsc_env $ \pls -> do (pls', ok) <- linkDependencies hsc_env pls noSrcSpan [mod] if (failed ok) then throwGhcExceptionIO (ProgramError "could not link module") else return pls' + putStrLn "[linkModule] done." {- ********************************************************************** @@ -1075,7 +1104,7 @@ unload hsc_env linkables initDynLinker hsc_env new_pls - <- modifyPLS $ \pls -> do + <- modifyPLS hsc_env $ \pls -> do pls1 <- unload_wkr hsc_env linkables pls return (pls1, pls1) @@ -1213,7 +1242,7 @@ linkPackages hsc_env new_pkgs = do -- It's probably not safe to try to load packages concurrently, so we take -- a lock. initDynLinker hsc_env - modifyPLS_ $ \pls -> do + modifyPLS_ hsc_env $ \pls -> do linkPackages' hsc_env new_pkgs pls linkPackages' :: HscEnv -> [LinkerUnitId] -> PersistentLinkerState diff --git a/compiler/iface/LoadIface.hs b/compiler/iface/LoadIface.hs index 60a9bc9378..be2e893ffb 100644 --- a/compiler/iface/LoadIface.hs +++ b/compiler/iface/LoadIface.hs @@ -948,7 +948,7 @@ readIface wanted_mod file_path -- NB: This check is NOT just a sanity check, it is -- critical for correctness of recompilation checking -- (it lets us tell when -this-unit-id has changed.) - | wanted_mod == actual_mod + | wanted_mod == actual_mod || True -> return (Succeeded iface) | otherwise -> return (Failed err) where diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index d63c729058..1638cd5005 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -84,6 +84,7 @@ module DynFlags ( -- ** System tool settings and locations Settings(..), + integerLibrary, targetPlatformString, targetPlatform, programName, projectVersion, ghcUsagePath, ghciUsagePath, topDir, tmpDir, rawSettings, versionedAppDir, @@ -1229,6 +1230,12 @@ data Settings = Settings { sPlatformConstants :: PlatformConstants } +-- | IntegerGMP or IntegerSimple. Set at configure time, but may be overriden +-- by GHC-API users. See Note [The integer library] in PrelNames +integerLibrary :: DynFlags -> IntegerLibrary +integerLibrary = platformIntegerLibrary . targetPlatform +targetPlatformString :: DynFlags -> String +targetPlatformString = platformString . targetPlatform targetPlatform :: DynFlags -> Platform targetPlatform dflags = sTargetPlatform (settings dflags) programName :: DynFlags -> String @@ -3588,6 +3595,8 @@ package_flags_deps = [ ------- Packages ---------------------------------------------------- make_ord_flag defFlag "package-db" (HasArg (addPkgConfRef . PkgConfFile)) + , make_ord_flag defFlag "host-package-db" + (HasArg (addPkgConfRef . HostPkgConfFile)) , make_ord_flag defFlag "clear-package-db" (NoArg clearPkgConf) , make_ord_flag defFlag "no-global-package-db" (NoArg removeGlobalPkgConf) , make_ord_flag defFlag "no-user-package-db" (NoArg removeUserPkgConf) @@ -4881,6 +4890,7 @@ data PkgConfRef = GlobalPkgConf | UserPkgConf | PkgConfFile FilePath + | HostPkgConfFile FilePath -- ^ a package config file that specifies packages compiled for the same host as the compiler. deriving Eq addPkgConfRef :: PkgConfRef -> DynP () @@ -5080,6 +5090,10 @@ interpretPackageEnv dflags = do -- relative package dbs are interpreted relative to the env file where envdir = takeDirectory envfile db = drop 11 str + ("host-package-db": _) -> addPkgConfRef (HostPkgConfFile (envdir </> db)) + -- relative package dbs are interpreted relative to the env file + where envdir = takeDirectory envfile + db = drop 11 str ["clear-package-db"] -> clearPkgConf ["global-package-db"] -> addPkgConfRef GlobalPkgConf ["user-package-db"] -> addPkgConfRef UserPkgConf diff --git a/compiler/main/DynFlags.hs-boot b/compiler/main/DynFlags.hs-boot index 823fd22854..b6fae290e1 100644 --- a/compiler/main/DynFlags.hs-boot +++ b/compiler/main/DynFlags.hs-boot @@ -7,6 +7,7 @@ data DynFlags data DumpFlag data GeneralFlag +integerLibrary :: DynFlags -> IntegerLibrary targetPlatform :: DynFlags -> Platform pprUserLength :: DynFlags -> Int pprCols :: DynFlags -> Int diff --git a/compiler/main/DynamicLoading.hs b/compiler/main/DynamicLoading.hs index 764bf2dd41..f7d8cc1163 100644 --- a/compiler/main/DynamicLoading.hs +++ b/compiler/main/DynamicLoading.hs @@ -1,5 +1,5 @@ {-# LANGUAGE CPP, MagicHash #-} - +#define GHCI 1 -- | Dynamically lookup up values from modules and loading them. module DynamicLoading ( initializePlugins, @@ -27,6 +27,7 @@ module DynamicLoading ( import GhcPrelude import HscTypes ( HscEnv ) import DynFlags +import Platform #if defined(GHCI) import Linker ( linkModule, getHValue ) @@ -47,9 +48,9 @@ import HscTypes import GHCi.RemoteTypes ( HValue ) import Type ( Type, eqType, mkTyConTy, pprTyThingCategory ) import TyCon ( TyCon ) -import Name ( Name, nameModule_maybe ) +import Name ( Name, nameModule_maybe, nameStableString ) import Id ( idType ) -import Module ( Module, ModuleName ) +import Module ( Module, ModuleName, moduleNameString ) import Panic import FastString import ErrUtils @@ -97,10 +98,14 @@ initializePlugins hsc_env df loadPlugins :: HscEnv -> IO [LoadedPlugin] loadPlugins hsc_env - = do { unless (null to_load) $ - checkExternalInterpreter hsc_env + = do + putStrLn "[loadPlugins] loading plugins..." + ret <- do { -- unless (null to_load) $ + -- checkExternalInterpreter hsc_env ; plugins <- mapM loadPlugin to_load ; return $ zipWith attachOptions to_load plugins } + putStrLn "[loadPlugins] done." + return ret where dflags = hsc_dflags hsc_env to_load = pluginModNames dflags @@ -129,7 +134,9 @@ checkExternalInterpreter hsc_env = loadPlugin' :: OccName -> Name -> HscEnv -> ModuleName -> IO (a, ModIface) loadPlugin' occ_name plugin_name hsc_env mod_name - = do { let plugin_rdr_name = mkRdrQual mod_name occ_name + = do + ret <- do { putStrLn $ "[loadPlugin'] loading `" ++ nameStableString plugin_name ++ "' from `" ++ moduleNameString mod_name ++ "' ... " + ; let plugin_rdr_name = mkRdrQual mod_name occ_name dflags = hsc_dflags hsc_env ; mb_name <- lookupRdrNameInModuleForPlugins hsc_env mod_name plugin_rdr_name @@ -150,6 +157,8 @@ loadPlugin' occ_name plugin_name hsc_env mod_name , text "did not have the type" , ppr pluginTyConName, text "as required"]) Just plugin -> return (plugin, mod_iface) } } } + putStrLn "[loadPlugin'] done. " + return ret -- | Force the interfaces for the given modules to be loaded. The 'SDoc' parameter is used @@ -207,10 +216,11 @@ getValueSafely hsc_env val_name expected_type = do getHValueSafely :: HscEnv -> Name -> Type -> IO (Maybe HValue) getHValueSafely hsc_env val_name expected_type = do + putStrLn "[getHValueSafely]: loading ..." forceLoadNameModuleInterface hsc_env (text "contains a name used in an invocation of getHValueSafely") val_name -- Now look up the names for the value and type constructor in the type environment mb_val_thing <- lookupTypeHscEnv hsc_env val_name - case mb_val_thing of + ret <- case mb_val_thing of Nothing -> throwCmdLineErrorS dflags $ missingTyThingError val_name Just (AnId id) -> do -- Check the value type in the interface against the type recovered from the type constructor @@ -219,15 +229,40 @@ getHValueSafely hsc_env val_name expected_type = do then do -- Link in the module that contains the value, if it has such a module case nameModule_maybe val_name of - Just mod -> do linkModule hsc_env mod + Just mod -> do linkModule local_hsc_env mod return () Nothing -> return () -- Find the value that we just linked in and cast it given that we have proved it's type - hval <- getHValue hsc_env val_name >>= wormhole dflags + hval <- getHValue local_hsc_env val_name >>= wormhole local_dflags return (Just hval) else return Nothing Just val_thing -> throwCmdLineErrorS dflags $ wrongTyThingError val_name val_thing + putStrLn "[getHValueSafely]: done." + return ret where dflags = hsc_dflags hsc_env + -- unset Opt_ExternalInterpreter. This will ensure that + -- local_hsc_env and local_dflags go through the local linker. + -- if no -fexternal-interpreter is provided, this will be a no-op. + -- if however -fexteranl-interpreter is provided, we maintain two + -- linker states. The remote (iserv) one and the local one. + local_hsc_env = hsc_env + { hsc_dflags = (gopt_unset (hsc_dflags hsc_env) Opt_ExternalInterpreter) + { settings = (settings (hsc_dflags hsc_env)) + { sTargetPlatform = Platform + { platformArch = ArchX86_64 + , platformOS = OSDarwin + , platformWordSize = 8 + , platformUnregisterised = False + , platformHasGnuNonexecStack = error "platformGnuNonexecStack undefined" + , platformHasIdentDirective = error "platformHasIdentDirective undefined" + , platformHasSubsectionsViaSymbols = True + , platformIsCrossCompiling = True + , platformString = "x86_64-apple-darwin" + } + } + } + } + local_dflags = hsc_dflags local_hsc_env -- | Coerce a value as usual, but: -- diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index f80394efc2..ede8d712aa 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -579,11 +579,13 @@ checkBrokenTablesNextToCode' dflags -- setSessionDynFlags :: GhcMonad m => DynFlags -> m [InstalledUnitId] setSessionDynFlags dflags = do + liftIO $ putStrLn "[setSessionDynFlags]" dflags' <- checkNewDynFlags dflags (dflags'', preload) <- liftIO $ initPackages dflags' modifySession $ \h -> h{ hsc_dflags = dflags'' , hsc_IC = (hsc_IC h){ ic_dflags = dflags'' } } invalidateModSummaryCache + liftIO $ putStrLn "[/setSessionDynFlags]" return preload -- | Sets the program 'DynFlags'. Note: this invalidates the internal @@ -603,6 +605,7 @@ setLogAction action = do setProgramDynFlags_ :: GhcMonad m => Bool -> DynFlags -> m [InstalledUnitId] setProgramDynFlags_ invalidate_needed dflags = do + liftIO $ putStrLn "[setProgramDynFlags_]" dflags' <- checkNewDynFlags dflags dflags_prev <- getProgramDynFlags (dflags'', preload) <- @@ -611,6 +614,7 @@ setProgramDynFlags_ invalidate_needed dflags = do else return (dflags', []) modifySession $ \h -> h{ hsc_dflags = dflags'' } when invalidate_needed $ invalidateModSummaryCache + liftIO $ putStrLn "[/setProgramDynFlags_]" return preload diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index a80843965f..c0b41c2012 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -333,7 +333,7 @@ handleRunStatus step expr bindings final_ids status history = do hsc_env <- getSession let final_ic = extendInteractiveContextWithIds (hsc_IC hsc_env) final_ids final_names = map getName final_ids - liftIO $ Linker.extendLinkEnv (zip final_names hvals) + liftIO $ Linker.extendLinkEnv hsc_env (zip final_names hvals) hsc_env' <- liftIO $ rttiEnvironment hsc_env{hsc_IC=final_ic} setSession hsc_env' return (ExecComplete (Right final_names) allocs) @@ -372,7 +372,7 @@ resumeExec canLogSpan step new_names = [ n | thing <- ic_tythings ic , let n = getName thing , not (n `elem` old_names) ] - liftIO $ Linker.deleteFromLinkEnv new_names + liftIO $ Linker.deleteFromLinkEnv hsc_env new_names case r of Resume { resumeStmt = expr, resumeContext = fhv @@ -467,7 +467,7 @@ bindLocalsAtBreakpoint hsc_env apStack Nothing = do ictxt0 = hsc_IC hsc_env ictxt1 = extendInteractiveContextWithIds ictxt0 [exn_id] -- - Linker.extendLinkEnv [(exn_name, apStack)] + Linker.extendLinkEnv hsc_env [(exn_name, apStack)] return (hsc_env{ hsc_IC = ictxt1 }, [exn_name], span, "<exception thrown>") -- Just case: we stopped at a breakpoint, we have information about the location @@ -526,8 +526,8 @@ bindLocalsAtBreakpoint hsc_env apStack_fhv (Just BreakInfo{..}) = do names = map idName new_ids let fhvs = catMaybes mb_hValues - Linker.extendLinkEnv (zip names fhvs) - when result_ok $ Linker.extendLinkEnv [(result_name, apStack_fhv)] + Linker.extendLinkEnv hsc_env (zip names fhvs) + when result_ok $ Linker.extendLinkEnv hsc_env [(result_name, apStack_fhv)] hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 } return (hsc_env1, if result_ok then result_name:names else names, span, decl) where @@ -996,8 +996,12 @@ moduleIsBootOrNotObjectLinkable mod_summary = withSession $ \hsc_env -> -- RTTI primitives obtainTermFromVal :: HscEnv -> Int -> Bool -> Type -> a -> IO Term -obtainTermFromVal hsc_env bound force ty x = - cvObtainTerm hsc_env bound force ty (unsafeCoerce# x) +obtainTermFromVal hsc_env bound force ty x + | gopt Opt_ExternalInterpreter (hsc_dflags hsc_env) + = throwIO (InstallationError + "obtainTermFromVal: this operation requires -fno-external-interpreter") + | otherwise + = cvObtainTerm hsc_env bound force ty (unsafeCoerce# x) obtainTermFromId :: HscEnv -> Int -> Bool -> Id -> IO Term obtainTermFromId hsc_env bound force id = do diff --git a/compiler/main/Packages.hs b/compiler/main/Packages.hs index fa2db1964e..9068a3dd6d 100644 --- a/compiler/main/Packages.hs +++ b/compiler/main/Packages.hs @@ -82,7 +82,7 @@ import Maybes import System.Environment ( getEnv ) import FastString -import ErrUtils ( debugTraceMsg, MsgDoc, printInfoForUser ) +import ErrUtils ( debugTraceMsg, MsgDoc, printInfoForUser, dumpIfSet ) import Exception import System.Directory @@ -102,6 +102,8 @@ import qualified Data.Map.Strict as MapStrict import qualified Data.Set as Set import Data.Version +import Debug.Trace (traceShowId) + -- --------------------------------------------------------------------------- -- The Package state @@ -467,6 +469,7 @@ listPackageConfigMap dflags = eltsUDFM pkg_map -- link in. initPackages :: DynFlags -> IO (DynFlags, [PreloadUnitId]) initPackages dflags0 = do + putStrLn "[initPackages]" dflags <- interpretPackageEnv dflags0 pkg_db <- case pkgDatabase dflags of @@ -475,11 +478,26 @@ initPackages dflags0 = do -> (p, setBatchPackageFlags dflags pkgs)) db (pkg_state, preload, insts) <- mkPackageState dflags pkg_db [] + + dumpPkgState dflags pkg_state + + putStrLn "[/initPackages]" return (dflags{ pkgDatabase = Just pkg_db, pkgState = pkg_state, thisUnitIdInsts_ = insts }, preload) +dumpPkgState :: DynFlags -> PackageState -> IO () +dumpPkgState dflags pkgState = + let pkgs = map snd . udfmToList . unPackageConfigMap . pkgIdMap $ pkgState + in dumpIfSet dflags True "Package State" $ vcat (map pprPkg pkgs) + + where + pprPkg :: PackageConfig -> SDoc + pprPkg pkg = ppr (packageName pkg) <+> ppr (unitId pkg) + $+$ nest 2 (fsep (map ppr (depends pkg))) + + -- ----------------------------------------------------------------------------- -- Reading the package database(s) @@ -524,8 +542,12 @@ getPackageConfRefs dflags = do isNotGlobal GlobalPkgConf = False isNotGlobal _ = True -resolvePackageConfig :: DynFlags -> PkgConfRef -> IO (Maybe FilePath) -resolvePackageConfig dflags GlobalPkgConf = return $ Just (systemPackageConfig dflags) +targetPrefix, hostPrefix :: DynFlags -> String +targetPrefix dflags = "" +hostPrefix dflags = "x86_64-apple-darwin" + +resolvePackageConfig :: DynFlags -> PkgConfRef -> IO (Maybe (String, FilePath)) +resolvePackageConfig dflags GlobalPkgConf = return $ Just (targetPrefix dflags, systemPackageConfig dflags) -- NB: This logic is reimplemented in Cabal, so if you change it, -- make sure you update Cabal. (Or, better yet, dump it in the -- compiler info so Cabal can use the info.) @@ -533,11 +555,12 @@ resolvePackageConfig dflags UserPkgConf = runMaybeT $ do dir <- versionedAppDir dflags let pkgconf = dir </> "package.conf.d" exist <- tryMaybeT $ doesDirectoryExist pkgconf - if exist then return pkgconf else mzero -resolvePackageConfig _ (PkgConfFile name) = return $ Just name + if exist then return (targetPrefix dflags, pkgconf) else mzero +resolvePackageConfig dflags (PkgConfFile name) = return $ Just (targetPrefix dflags, name) +resolvePackageConfig dflags (HostPkgConfFile name) = return $ Just (hostPrefix dflags, name) -readPackageConfig :: DynFlags -> FilePath -> IO (FilePath, [PackageConfig]) -readPackageConfig dflags conf_file = do +readPackageConfig :: DynFlags -> (String, FilePath) -> IO (FilePath, [PackageConfig]) +readPackageConfig dflags (prefix, conf_file) = do isdir <- doesDirectoryExist conf_file proto_pkg_configs <- @@ -563,7 +586,8 @@ readPackageConfig dflags conf_file = do pkgroot = takeDirectory conf_file pkg_configs1 = map (mungePackageConfig top_dir pkgroot) proto_pkg_configs - pkg_configs2 = setBatchPackageFlags dflags pkg_configs1 + pkg_configs2 = setPackagePrefix dflags prefix + $ setBatchPackageFlags dflags pkg_configs1 -- return (conf_file, pkg_configs2) where @@ -617,6 +641,17 @@ readPackageConfig dflags conf_file = do else return (Just []) -- ghc-pkg will create it when it's updated else return Nothing +setPackagePrefix :: DynFlags -> String -> [PackageConfig] -> [PackageConfig] +setPackagePrefix dflags "" pkgs = pkgs +setPackagePrefix dflags prefix pkgs = map go pkgs + where go pkg = pkg + { unitId = addPrefix (unitId pkg) + , packageName = y (packageName pkg) + , depends = map addPrefix (depends pkg) + } + addPrefix = stringToInstalledUnitId . ((prefix ++ "-") ++) . installedUnitIdString + y (PackageName fs) = PackageName $ (fsLit (prefix ++ "-")) Semigroup.<> fs + setBatchPackageFlags :: DynFlags -> [PackageConfig] -> [PackageConfig] setBatchPackageFlags dflags pkgs = maybeDistrustAll pkgs where @@ -976,12 +1011,16 @@ findWiredInPackages dflags prec_map pkgs vis_map = do -- their canonical names (eg. base-1.0 ==> base), as described -- in Note [Wired-in packages] in Module let + targetPrefix = case targetPlatformString dflags of + "" -> "" + pfx -> pfx ++ "-" + matches :: PackageConfig -> WiredInUnitId -> Bool pc `matches` pid -- See Note [The integer library] in PrelNames | pid == unitIdString integerUnitId = packageNameString pc `elem` ["integer-gmp", "integer-simple"] - pc `matches` pid = packageNameString pc == pid + pc `matches` pid = packageNameString pc == traceShowId (targetPrefix ++ pid) -- find which package corresponds to each wired-in package -- delete any other packages with the same name @@ -1993,7 +2032,9 @@ getPreloadPackagesAnd dflags pkgids0 = preload = preloadPackages state pairs = zip pkgids (repeat Nothing) in do + putStrLn $ "[getPreloadPackagesAnd] pkgids0 = " ++ show pkgids0 all_pkgs <- throwErr dflags (foldM (add_package dflags pkg_map) preload pairs) + putStrLn $ "[getPreloadPacakgesAnd] all_pkgs = " ++ show all_pkgs return (map (getInstalledPackageDetails dflags) all_pkgs) -- Takes a list of packages, and returns the list with dependencies included, diff --git a/compiler/main/SysTools.hs b/compiler/main/SysTools.hs index d987d7dcd0..a63ae25195 100644 --- a/compiler/main/SysTools.hs +++ b/compiler/main/SysTools.hs @@ -8,7 +8,7 @@ ----------------------------------------------------------------------------- -} -{-# LANGUAGE CPP, MultiWayIf, ScopedTypeVariables #-} +{-# LANGUAGE CPP, MultiWayIf, ScopedTypeVariables, LambdaCase #-} module SysTools ( -- * Initialisation @@ -266,8 +266,13 @@ initSysTools mbMinusB lcc_prog <- getSetting "LLVM clang command" let iserv_prog = libexec "ghc-iserv" + integer_library <- getSetting "integer library" >>= \case + "gmp" -> pure IntegerGMP + "simple" -> pure IntegerSimple + x -> error $ "Unknown integer-library: " ++ x let platform = Platform { + platformIntegerLibrary = integer_library, platformArch = targetArch, platformOS = targetOS, platformWordSize = targetWordSize, @@ -275,7 +280,8 @@ initSysTools mbMinusB platformHasGnuNonexecStack = targetHasGnuNonexecStack, platformHasIdentDirective = targetHasIdentDirective, platformHasSubsectionsViaSymbols = targetHasSubsectionsViaSymbols, - platformIsCrossCompiling = crossCompiling + platformIsCrossCompiling = crossCompiling, + platformString = "" } return $ Settings { diff --git a/compiler/simplCore/SimplCore.hs b/compiler/simplCore/SimplCore.hs index d461b99c43..a73e7f3f41 100644 --- a/compiler/simplCore/SimplCore.hs +++ b/compiler/simplCore/SimplCore.hs @@ -462,11 +462,7 @@ doCorePass (CoreDoRuleCheck phase pat) = ruleCheckPass phase pat doCorePass CoreDoNothing = return doCorePass (CoreDoPasses passes) = runCorePasses passes -#if defined(GHCI) doCorePass (CoreDoPluginPass _ pass) = {-# SCC "Plugin" #-} pass -#else -doCorePass pass@CoreDoPluginPass {} = pprPanic "doCorePass" (ppr pass) -#endif doCorePass pass@CoreDesugar = pprPanic "doCorePass" (ppr pass) doCorePass pass@CoreDesugarOpt = pprPanic "doCorePass" (ppr pass) diff --git a/compiler/utils/Platform.hs b/compiler/utils/Platform.hs index 449a62a5b6..179449c603 100644 --- a/compiler/utils/Platform.hs +++ b/compiler/utils/Platform.hs @@ -9,6 +9,7 @@ module Platform ( ArmISAExt(..), ArmABI(..), PPC_64ABI(..), + IntegerLibrary(..), target32Bit, isARM, @@ -26,6 +27,7 @@ import GhcPrelude -- code for this platform. data Platform = Platform { + platformIntegerLibrary :: IntegerLibrary, platformArch :: Arch, platformOS :: OS, -- Word size in bytes (i.e. normally 4 or 8, @@ -35,10 +37,15 @@ data Platform platformHasGnuNonexecStack :: Bool, platformHasIdentDirective :: Bool, platformHasSubsectionsViaSymbols :: Bool, - platformIsCrossCompiling :: Bool + platformIsCrossCompiling :: Bool, + platformString :: String } deriving (Read, Show, Eq) +data IntegerLibrary = IntegerGMP + | IntegerSimple + deriving (Read, Show, Eq) + -- | Architectures that the native code generator knows about. -- TODO: It might be nice to extend these constructors with information @@ -159,4 +166,3 @@ platformUsesFrameworks = osUsesFrameworks . platformOS osSubsectionsViaSymbols :: OS -> Bool osSubsectionsViaSymbols OSDarwin = True osSubsectionsViaSymbols _ = False - diff --git a/configure.ac b/configure.ac index 11c2a3400f..91ca917b1e 100644 --- a/configure.ac +++ b/configure.ac @@ -988,6 +988,13 @@ dnl ################################################################ dnl Check for libraries dnl ################################################################ +# integer lib +AC_ARG_WITH([integer-library],[AC_HELP_STRING([--with-integer-library],[Integer library to use [default=gmp]])]) +AS_IF([test "x$with_integer_library" = "x"], + [SettingsIntegerLibrary="gmp"], + [SettingsIntegerLibrary="$with_integer_library"]) +AC_SUBST(SettingsIntegerLibrary) + # system libffi AC_ARG_WITH([system-libffi], diff --git a/ghc/Main.hs b/ghc/Main.hs index eda6a3d2a1..162b2176fd 100644 --- a/ghc/Main.hs +++ b/ghc/Main.hs @@ -30,12 +30,10 @@ import GHCi.UI ( interactiveUI, ghciWelcomeMsg, defaultGhciSettings ) #endif -- Frontend plugins -#if defined(GHCI) + import DynamicLoading ( loadFrontendPlugin ) import Plugins -#else -import DynamicLoading ( pluginError ) -#endif + import Module ( ModuleName ) @@ -834,15 +832,11 @@ dumpPackagesSimple dflags = putMsg dflags (pprPackagesSimple dflags) -- Frontend plugin support doFrontend :: ModuleName -> [(String, Maybe Phase)] -> Ghc () -#if !defined(GHCI) -doFrontend modname _ = pluginError [modname] -#else doFrontend modname srcs = do hsc_env <- getSession frontend_plugin <- liftIO $ loadFrontendPlugin hsc_env modname frontend frontend_plugin (reverse $ frontendPluginOpts (hsc_dflags hsc_env)) srcs -#endif -- ----------------------------------------------------------------------------- -- ABI hash support diff --git a/libraries/ghci/GHCi/BreakArray.hs b/libraries/ghci/GHCi/BreakArray.hs index bece43bdb9..f645fa95b3 100644 --- a/libraries/ghci/GHCi/BreakArray.hs +++ b/libraries/ghci/GHCi/BreakArray.hs @@ -15,7 +15,7 @@ -- 0 otherwise -- ------------------------------------------------------------------------------- - +#define GHCI module GHCi.BreakArray ( BreakArray diff --git a/libraries/ghci/GHCi/InfoTable.hsc b/libraries/ghci/GHCi/InfoTable.hsc index ca5757257c..c4b554bc73 100644 --- a/libraries/ghci/GHCi/InfoTable.hsc +++ b/libraries/ghci/GHCi/InfoTable.hsc @@ -3,6 +3,7 @@ -- Get definitions for the structs, constants & config etc. #include "Rts.h" +#define GHCI -- | -- Run-time info table support. This module provides support for -- creating and reading info tables /in the running program/. diff --git a/libraries/ghci/ghci.cabal.in b/libraries/ghci/ghci.cabal.in index 32ce79c013..0171cde829 100644 --- a/libraries/ghci/ghci.cabal.in +++ b/libraries/ghci/ghci.cabal.in @@ -48,12 +48,6 @@ library if flag(ghci) CPP-Options: -DGHCI - exposed-modules: - GHCi.Run - GHCi.CreateBCO - GHCi.ObjLink - GHCi.Signals - GHCi.TH exposed-modules: GHCi.BreakArray @@ -66,6 +60,11 @@ library GHCi.StaticPtrTable GHCi.TH.Binary SizedSeq + GHCi.Run + GHCi.CreateBCO + GHCi.ObjLink + GHCi.Signals + GHCi.TH Build-Depends: array == 0.5.*, diff --git a/settings.in b/settings.in index 30bfe7072b..019d360189 100644 --- a/settings.in +++ b/settings.in @@ -31,6 +31,6 @@ ("Unregisterised", "@Unregisterised@"), ("LLVM llc command", "@SettingsLlcCommand@"), ("LLVM opt command", "@SettingsOptCommand@"), - ("LLVM clang command", "@SettingsClangCommand@") + ("LLVM clang command", "@SettingsClangCommand@"), + ("integer library", "@SettingsIntegerLibrary@") ] - |