diff options
Diffstat (limited to 'compiler/main')
| -rw-r--r-- | compiler/main/Annotations.hs | 15 | ||||
| -rw-r--r-- | compiler/main/CodeOutput.lhs | 18 | ||||
| -rw-r--r-- | compiler/main/DriverPipeline.hs | 234 | ||||
| -rw-r--r-- | compiler/main/DynFlags.hs | 178 | ||||
| -rw-r--r-- | compiler/main/ErrUtils.lhs | 1 | ||||
| -rw-r--r-- | compiler/main/ErrUtils.lhs-boot | 1 | ||||
| -rw-r--r-- | compiler/main/GHC.hs | 14 | ||||
| -rw-r--r-- | compiler/main/GhcMake.hs | 3 | ||||
| -rw-r--r-- | compiler/main/HeaderInfo.hs | 61 | ||||
| -rw-r--r-- | compiler/main/HscMain.hs | 49 | ||||
| -rw-r--r-- | compiler/main/HscTypes.lhs | 222 | ||||
| -rw-r--r-- | compiler/main/InteractiveEval.hs | 4 | ||||
| -rw-r--r-- | compiler/main/Packages.lhs | 17 | ||||
| -rw-r--r-- | compiler/main/PprTyThing.hs | 33 | ||||
| -rw-r--r-- | compiler/main/StaticFlags.hs | 97 | ||||
| -rw-r--r-- | compiler/main/SysTools.lhs | 242 | ||||
| -rw-r--r-- | compiler/main/TidyPgm.lhs | 32 |
17 files changed, 814 insertions, 407 deletions
diff --git a/compiler/main/Annotations.hs b/compiler/main/Annotations.hs index 277c059b11..7de1a9914b 100644 --- a/compiler/main/Annotations.hs +++ b/compiler/main/Annotations.hs @@ -16,6 +16,7 @@ module Annotations ( deserializeAnns ) where +import Binary import Module ( Module ) import Name import Outputable @@ -23,6 +24,7 @@ import Serialized import UniqFM import Unique +import Control.Monad import Data.Maybe import Data.Typeable import Data.Word ( Word8 ) @@ -64,6 +66,19 @@ instance Outputable name => Outputable (AnnTarget name) where ppr (NamedTarget nm) = text "Named target" <+> ppr nm ppr (ModuleTarget mod) = text "Module target" <+> ppr mod +instance Binary name => Binary (AnnTarget name) where + put_ bh (NamedTarget a) = do + putByte bh 0 + put_ bh a + put_ bh (ModuleTarget a) = do + putByte bh 1 + put_ bh a + get bh = do + h <- getByte bh + case h of + 0 -> liftM NamedTarget $ get bh + _ -> liftM ModuleTarget $ get bh + instance Outputable Annotation where ppr ann = ppr (ann_target ann) diff --git a/compiler/main/CodeOutput.lhs b/compiler/main/CodeOutput.lhs index d6c096a595..b8b187241b 100644 --- a/compiler/main/CodeOutput.lhs +++ b/compiler/main/CodeOutput.lhs @@ -45,6 +45,7 @@ import System.IO \begin{code} codeOutput :: DynFlags -> Module + -> FilePath -> ModLocation -> ForeignStubs -> [PackageId] @@ -52,7 +53,7 @@ codeOutput :: DynFlags -> IO (FilePath, (Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-})) -codeOutput dflags this_mod location foreign_stubs pkg_deps cmm_stream +codeOutput dflags this_mod filenm location foreign_stubs pkg_deps cmm_stream = do { -- Lint each CmmGroup as it goes past @@ -72,10 +73,9 @@ codeOutput dflags this_mod location foreign_stubs pkg_deps cmm_stream } ; showPass dflags "CodeOutput" - ; let filenm = hscOutName dflags ; stubs_exist <- outputForeignStubs dflags this_mod location foreign_stubs ; case hscTarget dflags of { - HscAsm -> outputAsm dflags filenm linted_cmm_stream; + HscAsm -> outputAsm dflags this_mod filenm linted_cmm_stream; HscC -> outputC dflags filenm linted_cmm_stream pkg_deps; HscLlvm -> outputLlvm dflags filenm linted_cmm_stream; HscInterpreted -> panic "codeOutput: HscInterpreted"; @@ -140,8 +140,8 @@ outputC dflags filenm cmm_stream packages %************************************************************************ \begin{code} -outputAsm :: DynFlags -> FilePath -> Stream IO RawCmmGroup () -> IO () -outputAsm dflags filenm cmm_stream +outputAsm :: DynFlags -> Module -> FilePath -> Stream IO RawCmmGroup () -> IO () +outputAsm dflags this_mod filenm cmm_stream | cGhcWithNativeCodeGen == "YES" = do ncg_uniqs <- mkSplitUniqSupply 'n' @@ -149,7 +149,7 @@ outputAsm dflags filenm cmm_stream _ <- {-# SCC "OutputAsm" #-} doOutput filenm $ \h -> {-# SCC "NativeCodeGen" #-} - nativeCodeGen dflags h ncg_uniqs cmm_stream + nativeCodeGen dflags this_mod h ncg_uniqs cmm_stream return () | otherwise @@ -168,13 +168,9 @@ outputLlvm :: DynFlags -> FilePath -> Stream IO RawCmmGroup () -> IO () outputLlvm dflags filenm cmm_stream = do ncg_uniqs <- mkSplitUniqSupply 'n' - -- ToDo: make the LLVM backend consume the C-- incrementally, - -- by pushing the cmm_stream inside (c.f. nativeCodeGen) - rawcmms <- Stream.collect cmm_stream - {-# SCC "llvm_output" #-} doOutput filenm $ \f -> {-# SCC "llvm_CodeGen" #-} - llvmCodeGen dflags f ncg_uniqs rawcmms + llvmCodeGen dflags f ncg_uniqs cmm_stream \end{code} diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index bdc2e8e812..c005a46873 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -78,7 +78,7 @@ preprocess :: HscEnv -> IO (DynFlags, FilePath) preprocess hsc_env (filename, mb_phase) = ASSERT2(isJust mb_phase || isHaskellSrcFilename filename, text filename) - runPipeline anyHsc hsc_env (filename, mb_phase) + runPipeline anyHsc hsc_env (filename, fmap RealPhase mb_phase) Nothing Temporary Nothing{-no ModLocation-} Nothing{-no stub-} -- --------------------------------------------------------------------------- @@ -148,9 +148,7 @@ compileOne' m_tc_result mHscMessage output_fn <- getOutputFilename next_phase Temporary basename dflags next_phase (Just location) - let dflags' = dflags { hscOutName = output_fn, - extCoreName = basename ++ ".hcr" } - let hsc_env' = hsc_env { hsc_dflags = dflags' } + let extCore_filename = basename ++ ".hcr" -- -fforce-recomp should also work with --make let force_recomp = gopt Opt_ForceRecomp dflags @@ -166,12 +164,12 @@ compileOne' m_tc_result mHscMessage e <- genericHscCompileGetFrontendResult always_do_basic_recompilation_check m_tc_result mHscMessage - hsc_env' summary source_modified mb_old_iface (mod_index, nmods) + hsc_env summary source_modified mb_old_iface (mod_index, nmods) case e of Left iface -> do details <- genModDetails hsc_env iface - MASSERT (isJust maybe_old_linkable) + MASSERT(isJust maybe_old_linkable) return (HomeModInfo{ hm_details = details, hm_iface = iface, hm_linkable = maybe_old_linkable }) @@ -182,19 +180,19 @@ compileOne' m_tc_result mHscMessage HscInterpreted -> case ms_hsc_src summary of HsBootFile -> - do (iface, _changed, details) <- hscSimpleIface hsc_env' tc_result mb_old_hash + do (iface, _changed, details) <- hscSimpleIface hsc_env tc_result mb_old_hash return (HomeModInfo{ hm_details = details, hm_iface = iface, hm_linkable = maybe_old_linkable }) - _ -> do guts0 <- hscDesugar hsc_env' summary tc_result - guts <- hscSimplify hsc_env' guts0 - (iface, _changed, details, cgguts) <- hscNormalIface hsc_env' guts mb_old_hash - (hasStub, comp_bc, modBreaks) <- hscInteractive hsc_env' cgguts summary + _ -> do guts0 <- hscDesugar hsc_env summary tc_result + guts <- hscSimplify hsc_env guts0 + (iface, _changed, details, cgguts) <- hscNormalIface hsc_env extCore_filename guts mb_old_hash + (hasStub, comp_bc, modBreaks) <- hscInteractive hsc_env cgguts summary stub_o <- case hasStub of Nothing -> return [] Just stub_c -> do - stub_o <- compileStub hsc_env' stub_c + stub_o <- compileStub hsc_env stub_c return [DotO stub_o] let hs_unlinked = [BCOs comp_bc modBreaks] @@ -212,7 +210,7 @@ compileOne' m_tc_result mHscMessage hm_iface = iface, hm_linkable = Just linkable }) HscNothing -> - do (iface, _changed, details) <- hscSimpleIface hsc_env' tc_result mb_old_hash + do (iface, _changed, details) <- hscSimpleIface hsc_env tc_result mb_old_hash let linkable = if isHsBoot src_flavour then maybe_old_linkable else Just (LM (ms_hs_date summary) this_mod []) @@ -223,30 +221,27 @@ compileOne' m_tc_result mHscMessage _ -> case ms_hsc_src summary of HsBootFile -> - do (iface, changed, details) <- hscSimpleIface hsc_env' tc_result mb_old_hash - hscWriteIface dflags' iface changed summary - touchObjectFile dflags' object_filename + do (iface, changed, details) <- hscSimpleIface hsc_env tc_result mb_old_hash + hscWriteIface dflags iface changed summary + touchObjectFile dflags object_filename return (HomeModInfo{ hm_details = details, hm_iface = iface, hm_linkable = maybe_old_linkable }) - _ -> do guts0 <- hscDesugar hsc_env' summary tc_result - guts <- hscSimplify hsc_env' guts0 - (iface, changed, details, cgguts) <- hscNormalIface hsc_env' guts mb_old_hash - hscWriteIface dflags' iface changed summary - (_outputFilename, hasStub) <- hscGenHardCode hsc_env' cgguts summary + _ -> do guts0 <- hscDesugar hsc_env summary tc_result + guts <- hscSimplify hsc_env guts0 + (iface, changed, details, cgguts) <- hscNormalIface hsc_env extCore_filename guts mb_old_hash + hscWriteIface dflags iface changed summary -- We're in --make mode: finish the compilation pipeline. - maybe_stub_o <- case hasStub of - Nothing -> return Nothing - Just stub_c -> do - stub_o <- compileStub hsc_env' stub_c - return (Just stub_o) - _ <- runPipeline StopLn hsc_env' (output_fn,Nothing) + let mod_name = ms_mod_name summary + _ <- runPipeline StopLn hsc_env + (output_fn, + Just (HscOut src_flavour mod_name (HscRecomp cgguts summary))) (Just basename) Persistent (Just location) - maybe_stub_o + Nothing -- The object filename comes from the ModLocation o_time <- getModificationUTCTime object_filename let linkable = LM o_time this_mod [DotO object_filename] @@ -375,7 +370,7 @@ linkingNeeded dflags linkables pkg_deps = do Left _ -> return True Right t -> do -- first check object files and extra_ld_inputs - let extra_ld_inputs = ldInputs dflags + let extra_ld_inputs = [ f | FileOption _ f <- ldInputs dflags ] e_extra_times <- mapM (tryIO . getModificationUTCTime) extra_ld_inputs let (errs,extra_times) = splitEithers e_extra_times let obj_times = map linkableTime linkables ++ extra_times @@ -475,7 +470,7 @@ compileFile hsc_env stop_phase (src, mb_phase) = do _ -> stop_phase ( _, out_file) <- runPipeline stop_phase' hsc_env - (src, mb_phase) Nothing output + (src, fmap RealPhase mb_phase) Nothing output Nothing{-no ModLocation-} Nothing return out_file @@ -521,12 +516,12 @@ data PipelineOutput runPipeline :: Phase -- ^ When to stop -> HscEnv -- ^ Compilation environment - -> (FilePath,Maybe Phase) -- ^ Input filename (and maybe -x suffix) + -> (FilePath,Maybe PhasePlus) -- ^ Input filename (and maybe -x suffix) -> Maybe FilePath -- ^ original basename (if different from ^^^) -> PipelineOutput -- ^ Output filename -> Maybe ModLocation -- ^ A ModLocation, if this is a Haskell module -> Maybe FilePath -- ^ stub object, if we have one - -> IO (DynFlags, FilePath) -- ^ (final flags, output filename) + -> IO (DynFlags, FilePath) -- ^ (final flags, output filename) runPipeline stop_phase hsc_env0 (input_fn, mb_phase) mb_basename output maybe_loc maybe_stub_o @@ -543,13 +538,14 @@ runPipeline stop_phase hsc_env0 (input_fn, mb_phase) | otherwise = input_basename -- If we were given a -x flag, then use that phase to start from - start_phase = fromMaybe (startPhase suffix') mb_phase + start_phase = fromMaybe (RealPhase (startPhase suffix')) mb_phase - isHaskell (Unlit _) = True - isHaskell (Cpp _) = True - isHaskell (HsPp _) = True - isHaskell (Hsc _) = True - isHaskell _ = False + isHaskell (RealPhase (Unlit _)) = True + isHaskell (RealPhase (Cpp _)) = True + isHaskell (RealPhase (HsPp _)) = True + isHaskell (RealPhase (Hsc _)) = True + isHaskell (HscOut {}) = True + isHaskell _ = False isHaskellishFile = isHaskell start_phase @@ -568,10 +564,13 @@ runPipeline stop_phase hsc_env0 (input_fn, mb_phase) -- before B in a normal compilation pipeline. let happensBefore' = happensBefore dflags - when (not (start_phase `happensBefore'` stop_phase)) $ - throwGhcExceptionIO (UsageError - ("cannot compile this file to desired target: " - ++ input_fn)) + case start_phase of + RealPhase start_phase' -> + when (not (start_phase' `happensBefore'` stop_phase)) $ + throwGhcExceptionIO (UsageError + ("cannot compile this file to desired target: " + ++ input_fn)) + HscOut {} -> return () debugTraceMsg dflags 4 (text "Running the pipeline") r <- runPipeline' start_phase hsc_env env input_fn @@ -584,7 +583,7 @@ runPipeline stop_phase hsc_env0 (input_fn, mb_phase) when isHaskellishFile $ whenCannotGenerateDynamicToo dflags $ do debugTraceMsg dflags 4 (text "Running the pipeline again for -dynamic-too") - let dflags' = doDynamicToo dflags + let dflags' = dynamicTooMkDynamicDynFlags dflags hsc_env' <- newHscEnv dflags' _ <- runPipeline' start_phase hsc_env' env input_fn maybe_loc maybe_stub_o @@ -592,7 +591,7 @@ runPipeline stop_phase hsc_env0 (input_fn, mb_phase) return r runPipeline' - :: Phase -- ^ When to start + :: PhasePlus -- ^ When to start -> HscEnv -- ^ Compilation environment -> PipeEnv -> FilePath -- ^ Input filename @@ -605,7 +604,7 @@ runPipeline' start_phase hsc_env env input_fn -- Execute the pipeline... let state = PipeState{ hsc_env, maybe_loc, maybe_stub_o = maybe_stub_o } - evalP (pipeLoop (RealPhase start_phase) input_fn) env state + evalP (pipeLoop start_phase input_fn) env state -- ----------------------------------------------------------------------------- -- The pipeline uses a monad to carry around various bits of information @@ -722,12 +721,12 @@ pipeLoop phase input_fn = do (ptext (sLit "Running phase") <+> ppr phase) (next_phase, output_fn) <- runPhase phase input_fn dflags r <- pipeLoop next_phase output_fn - case next_phase of + case phase of HscOut {} -> whenGeneratingDynamicToo dflags $ do - setDynFlags $ doDynamicToo dflags + setDynFlags $ dynamicTooMkDynamicDynFlags dflags -- TODO shouldn't ignore result: - _ <- pipeLoop next_phase output_fn + _ <- pipeLoop phase input_fn return () _ -> return () @@ -801,7 +800,7 @@ instance Outputable PhasePlus where -- what the rest of the phases will be until part-way through the -- compilation: for example, an {-# OPTIONS -fasm #-} at the beginning -- of a source file can change the latter stages of the pipeline from --- taking the via-C route to using the native code generator. +-- taking the LLVM route to using the native code generator. -- runPhase :: PhasePlus -- ^ Run this phase -> FilePath -- ^ name of the input file @@ -821,9 +820,7 @@ runPhase (RealPhase (Unlit sf)) input_fn dflags = do output_fn <- phaseOutputFilename (Cpp sf) - let unlit_flags = getOpts dflags opt_L - flags = map SysTools.Option unlit_flags ++ - [ -- The -h option passes the file name for unlit to + let flags = [ -- The -h option passes the file name for unlit to -- put in a #line directive SysTools.Option "-h" , SysTools.Option $ escape $ normalise input_fn @@ -870,7 +867,7 @@ runPhase (RealPhase (Cpp sf)) input_fn dflags0 return (RealPhase (HsPp sf), input_fn) else do output_fn <- phaseOutputFilename (HsPp sf) - liftIO $ doCpp dflags1 True{-raw-} False{-no CC opts-} + liftIO $ doCpp dflags1 True{-raw-} input_fn output_fn -- re-read the pragmas now that we've preprocessed the file -- See #2464,#3457 @@ -896,7 +893,6 @@ runPhase (RealPhase (HsPp sf)) input_fn dflags -- to the next phase of the pipeline. return (RealPhase (Hsc sf), input_fn) else do - let hspp_opts = getOpts dflags opt_F PipeEnv{src_basename, src_suffix} <- getPipeEnv let orig_fn = src_basename <.> src_suffix output_fn <- phaseOutputFilename (Hsc sf) @@ -904,8 +900,7 @@ runPhase (RealPhase (HsPp sf)) input_fn dflags ( [ SysTools.Option orig_fn , SysTools.Option input_fn , SysTools.FileOption "" output_fn - ] ++ - map SysTools.Option hspp_opts + ] ) -- re-read pragmas now that we've parsed the file (see #3674) @@ -960,8 +955,6 @@ runPhase (RealPhase (Hsc src_flavour)) input_fn dflags0 let o_file = ml_obj_file location -- The real object file - setModLocation location - -- Figure out if the source has changed, for recompilation avoidance. -- -- Setting source_unchanged to True means that M.o seems @@ -986,9 +979,8 @@ runPhase (RealPhase (Hsc src_flavour)) input_fn dflags0 then return SourceUnmodified else return SourceModified - let dflags' = dflags { extCoreName = basename ++ ".hcr" } + let extCore_filename = basename ++ ".hcr" - setDynFlags dflags' PipeState{hsc_env=hsc_env'} <- getPipeState -- Tell the finder cache about this module @@ -1008,7 +1000,7 @@ runPhase (RealPhase (Hsc src_flavour)) input_fn dflags0 ms_srcimps = src_imps } -- run the compiler! - result <- liftIO $ hscCompileOneShot hsc_env' + result <- liftIO $ hscCompileOneShot hsc_env' extCore_filename mod_summary source_unchanged return (HscOut src_flavour mod_name result, @@ -1016,6 +1008,8 @@ runPhase (RealPhase (Hsc src_flavour)) input_fn dflags0 runPhase (HscOut src_flavour mod_name result) _ dflags = do location <- getLocation src_flavour mod_name + setModLocation location + let o_file = ml_obj_file location -- The real object file hsc_lang = hscTarget dflags next_phase = hscPostBackendPhase dflags src_flavour hsc_lang @@ -1038,11 +1032,9 @@ runPhase (HscOut src_flavour mod_name result) _ dflags = do HscRecomp cgguts mod_summary -> do output_fn <- phaseOutputFilename next_phase - let dflags' = dflags { hscOutName = output_fn } - setDynFlags dflags' PipeState{hsc_env=hsc_env'} <- getPipeState - (outputFilename, mStub) <- liftIO $ hscGenHardCode hsc_env' cgguts mod_summary + (outputFilename, mStub) <- liftIO $ hscGenHardCode hsc_env' cgguts mod_summary output_fn case mStub of Nothing -> return () Just stub_c -> @@ -1057,26 +1049,21 @@ runPhase (HscOut src_flavour mod_name result) _ dflags = do runPhase (RealPhase CmmCpp) input_fn dflags = do output_fn <- phaseOutputFilename Cmm - liftIO $ doCpp dflags False{-not raw-} True{-include CC opts-} + liftIO $ doCpp dflags False{-not raw-} input_fn output_fn return (RealPhase Cmm, output_fn) runPhase (RealPhase Cmm) input_fn dflags = do - PipeEnv{src_basename} <- getPipeEnv let hsc_lang = hscTarget dflags let next_phase = hscPostBackendPhase dflags HsSrcFile hsc_lang output_fn <- phaseOutputFilename next_phase - let dflags' = dflags { hscOutName = output_fn, - extCoreName = src_basename ++ ".hcr" } - - setDynFlags dflags' PipeState{hsc_env} <- getPipeState - liftIO $ hscCompileCmmFile hsc_env input_fn + liftIO $ hscCompileCmmFile hsc_env input_fn output_fn return (RealPhase next_phase, output_fn) @@ -1090,7 +1077,6 @@ runPhase (RealPhase cc_phase) input_fn dflags | any (cc_phase `eqPhase`) [Cc, Ccpp, HCc, Cobjc, Cobjcpp] = do let platform = targetPlatform dflags - cc_opts = getOpts dflags opt_c hcc = cc_phase `eqPhase` HCc let cmdline_include_paths = includePaths dflags @@ -1130,8 +1116,9 @@ runPhase (RealPhase cc_phase) input_fn dflags split_opt | hcc && split_objs = [ "-DUSE_SPLIT_MARKERS" ] | otherwise = [ ] - let cc_opt | optLevel dflags >= 2 = "-O2" - | otherwise = "-O" + let cc_opt | optLevel dflags >= 2 = [ "-O2" ] + | optLevel dflags >= 1 = [ "-O" ] + | otherwise = [] -- Decide next phase let next_phase = As @@ -1154,10 +1141,10 @@ runPhase (RealPhase cc_phase) input_fn dflags -- very weakly typed, being derived from C--. ["-fno-strict-aliasing"] - let gcc_lang_opt | cc_phase `eqPhase` Ccpp = "c++" - | cc_phase `eqPhase` Cobjc = "objective-c" + let gcc_lang_opt | cc_phase `eqPhase` Ccpp = "c++" + | cc_phase `eqPhase` Cobjc = "objective-c" | cc_phase `eqPhase` Cobjcpp = "objective-c++" - | otherwise = "c" + | otherwise = "c" liftIO $ SysTools.runCc dflags ( -- force the C compiler to interpret this file as C when -- compiling .hc files, by adding the -x c option. @@ -1201,10 +1188,10 @@ runPhase (RealPhase cc_phase) input_fn dflags then gcc_extra_viac_flags ++ more_hcc_opts else []) ++ verbFlags - ++ [ "-S", cc_opt ] + ++ [ "-S" ] + ++ cc_opt ++ [ "-D__GLASGOW_HASKELL__="++cProjectVersionInt ] ++ framework_paths - ++ cc_opts ++ split_opt ++ include_paths ++ pkg_extra_cc_opts @@ -1263,8 +1250,7 @@ runPhase (RealPhase As) input_fn dflags | otherwise = return SysTools.runAs as_prog <- whichAsProg - let as_opts = getOpts dflags opt_a - cmdline_include_paths = includePaths dflags + let cmdline_include_paths = includePaths dflags next_phase <- maybeMergeStub output_fn <- phaseOutputFilename next_phase @@ -1275,8 +1261,7 @@ runPhase (RealPhase As) input_fn dflags let runAssembler inputFilename outputFilename = liftIO $ as_prog dflags - (map SysTools.Option as_opts - ++ [ SysTools.Option ("-I" ++ p) | p <- cmdline_include_paths ] + ([ SysTools.Option ("-I" ++ p) | p <- cmdline_include_paths ] -- We only support SparcV9 and better because V8 lacks an atomic CAS -- instruction so we have to make sure that the assembler accepts the @@ -1322,8 +1307,6 @@ runPhase (RealPhase SplitAs) _input_fn dflags liftIO $ mapM_ removeFile $ map (split_odir </>) $ filter (osuf `isSuffixOf`) fs - let as_opts = getOpts dflags opt_a - let (split_s_prefix, n) = case splitInfo dflags of Nothing -> panic "No split info" Just x -> x @@ -1335,8 +1318,7 @@ runPhase (RealPhase SplitAs) _input_fn dflags takeFileName base_o ++ "__" ++ show n <.> osuf let assemble_file n - = SysTools.runAs dflags - (map SysTools.Option as_opts ++ + = SysTools.runAs dflags ( -- We only support SparcV9 and better because V8 lacks an atomic CAS -- instruction so we have to make sure that the assembler accepts the @@ -1392,14 +1374,13 @@ runPhase (RealPhase LlvmOpt) input_fn dflags = do ver <- liftIO $ readIORef (llvmVersion dflags) - let lo_opts = getOpts dflags opt_lo - opt_lvl = max 0 (min 2 $ optLevel dflags) + let opt_lvl = max 0 (min 2 $ optLevel dflags) -- don't specify anything if user has specified commands. We do this -- for opt but not llc since opt is very specifically for optimisation -- passes only, so if the user is passing us extra options we assume -- they know what they are doing and don't get in the way. - optFlag = if null lo_opts - then [SysTools.Option (llvmOpts !! opt_lvl)] + optFlag = if null (getOpts dflags opt_lo) + then map SysTools.Option $ words (llvmOpts !! opt_lvl) else [] tbaa | ver < 29 = "" -- no tbaa in 2.8 and earlier | gopt Opt_LlvmTBAA dflags = "--enable-tbaa=true" @@ -1413,14 +1394,13 @@ runPhase (RealPhase LlvmOpt) input_fn dflags SysTools.Option "-o", SysTools.FileOption "" output_fn] ++ optFlag - ++ [SysTools.Option tbaa] - ++ map SysTools.Option lo_opts) + ++ [SysTools.Option tbaa]) return (RealPhase LlvmLlc, output_fn) where -- we always (unless -optlo specified) run Opt since we rely on it to -- fix up some pretty big deficiencies in the code we generate - llvmOpts = ["-mem2reg", "-O1", "-O2"] + llvmOpts = ["-mem2reg -globalopt", "-O1", "-O2"] ----------------------------------------------------------------------------- -- LlvmLlc phase @@ -1429,8 +1409,7 @@ runPhase (RealPhase LlvmLlc) input_fn dflags = do ver <- liftIO $ readIORef (llvmVersion dflags) - let lc_opts = getOpts dflags opt_lc - opt_lvl = max 0 (min 2 $ optLevel dflags) + let opt_lvl = max 0 (min 2 $ optLevel dflags) -- iOS requires external references to be loaded indirectly from the -- DATA segment or dyld traps at runtime writing into TEXT: see #7722 rmodel | platformOS (targetPlatform dflags) == OSiOS = "dynamic-no-pic" @@ -1454,7 +1433,6 @@ runPhase (RealPhase LlvmLlc) input_fn dflags SysTools.Option $ "-relocation-model=" ++ rmodel, SysTools.FileOption "" input_fn, SysTools.Option "-o", SysTools.FileOption "" output_fn] - ++ map SysTools.Option lc_opts ++ [SysTools.Option tbaa] ++ map SysTools.Option fpOpts ++ map SysTools.Option abiOpts @@ -1607,7 +1585,6 @@ mkExtraObj dflags extn xs FileOption "" cFile, Option "-o", FileOption "" oFile] - ++ map SysTools.Option (getOpts dflags opt_c) -- see #5528 ++ map (FileOption "-I") (includeDirs rtsDetails)) return oFile @@ -1665,7 +1642,17 @@ mkNoteObjsToLinkIntoBinary dflags dep_packages = do text elfSectionNote, text "\n", - text "\t.ascii \"", info', text "\"\n" ] + text "\t.ascii \"", info', text "\"\n", + + -- ALL generated assembly must have this section to disable + -- executable stacks. See also + -- compiler/nativeGen/AsmCodeGen.lhs for another instance + -- where we need to do this. + (if platformHasGnuNonexecStack (targetPlatform dflags) + then text ".section .note.GNU-stack,\"\",@progbits\n" + else empty) + + ] where info' = text $ escape info @@ -1694,7 +1681,7 @@ getLinkInfo dflags dep_packages = do rtsOpts dflags, rtsOptsEnabled dflags, gopt Opt_NoHsMain dflags, - extra_ld_inputs, + map showOpt extra_ld_inputs, getOpts dflags opt_l) -- return (show link_info) @@ -1828,7 +1815,13 @@ linkBinary dflags o_files dep_packages = do extraLinkObj <- mkExtraObjToLinkIntoBinary dflags noteLinkObjs <- mkNoteObjsToLinkIntoBinary dflags dep_packages - pkg_link_opts <- getPackageLinkOpts dflags dep_packages + pkg_link_opts <- if platformBinariesAreStaticLibs platform + then -- If building an executable really means + -- making a static library (e.g. iOS), then + -- we don't want the options (like -lm) + -- that getPackageLinkOpts gives us. #7720 + return [] + else getPackageLinkOpts dflags dep_packages pkg_framework_path_opts <- if platformUsesFrameworks platform @@ -1860,9 +1853,6 @@ linkBinary dflags o_files dep_packages = do -- probably _stub.o files let extra_ld_inputs = ldInputs dflags - -- opts from -optl-<blah> (including -l<blah> options) - let extra_ld_opts = getOpts dflags opt_l - -- Here are some libs that need to be linked at the *end* of -- the command line, because they contain symbols that are referred to -- by the RTS. We can't therefore use the ordinary way opts for these. @@ -1926,10 +1916,10 @@ linkBinary dflags o_files dep_packages = do else []) ++ o_files + ++ lib_path_opts) ++ extra_ld_inputs - ++ lib_path_opts - ++ extra_ld_opts - ++ rc_objs + ++ map SysTools.Option ( + rc_objs ++ framework_path_opts ++ framework_opts ++ pkg_lib_path_opts @@ -1950,15 +1940,16 @@ linkBinary dflags o_files dep_packages = do exeFileName :: DynFlags -> FilePath exeFileName dflags | Just s <- outputFile dflags = - if platformOS (targetPlatform dflags) == OSMinGW32 - then if null (takeExtension s) - then s <.> "exe" - else s - else s + case platformOS (targetPlatform dflags) of + OSMinGW32 -> s <?.> "exe" + OSiOS -> s <?.> "a" + _ -> s | otherwise = if platformOS (targetPlatform dflags) == OSMinGW32 then "main.exe" else "a.out" + where s <?.> ext | null (takeExtension s) = s <.> ext + | otherwise = s maybeCreateManifest :: DynFlags @@ -2000,12 +1991,10 @@ maybeCreateManifest dflags exe_filename -- show is a bit hackish above, but we need to escape the -- backslashes in the path. - let wr_opts = getOpts dflags opt_windres runWindres dflags $ map SysTools.Option $ ["--input="++rc_filename, "--output="++rc_obj_filename, "--output-format=coff"] - ++ wr_opts -- no FileOptions here: windres doesn't like seeing -- backslashes, apparently @@ -2028,9 +2017,9 @@ linkDynLibCheck dflags o_files dep_packages -- ----------------------------------------------------------------------------- -- Running CPP -doCpp :: DynFlags -> Bool -> Bool -> FilePath -> FilePath -> IO () -doCpp dflags raw include_cc_opts input_fn output_fn = do - let hscpp_opts = getOpts dflags opt_P ++ picPOpts dflags +doCpp :: DynFlags -> Bool -> FilePath -> FilePath -> IO () +doCpp dflags raw input_fn output_fn = do + let hscpp_opts = picPOpts dflags let cmdline_include_paths = includePaths dflags pkg_include_dirs <- getPackageIncludePath dflags [] @@ -2039,10 +2028,6 @@ doCpp dflags raw include_cc_opts input_fn output_fn = do let verbFlags = getVerbFlags dflags - let cc_opts - | include_cc_opts = getOpts dflags opt_c - | otherwise = [] - let cpp_prog args | raw = SysTools.runCpp dflags args | otherwise = SysTools.runCc dflags (SysTools.Option "-E" : args) @@ -2069,10 +2054,13 @@ doCpp dflags raw include_cc_opts input_fn output_fn = do ++ map SysTools.Option target_defs ++ map SysTools.Option backend_defs ++ map SysTools.Option hscpp_opts - ++ map SysTools.Option cc_opts ++ map SysTools.Option sse_defs + -- Set the language mode to assembler-with-cpp when preprocessing. This + -- alleviates some of the C99 macro rules relating to whitespace and the hash + -- operator, which we tend to abuse. Clang in particular is not very happy + -- about this. ++ [ SysTools.Option "-x" - , SysTools.Option "c" + , SysTools.Option "assembler-with-cpp" , SysTools.Option input_fn -- We hackily use Option instead of FileOption here, so that the file -- name is not back-slashed on Windows. cpp is capable of diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index af4518f8dc..94a6697418 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -32,7 +32,7 @@ module DynFlags ( lang_set, whenGeneratingDynamicToo, ifGeneratingDynamicToo, whenCannotGenerateDynamicToo, - doDynamicToo, + dynamicTooMkDynamicDynFlags, DynFlags(..), HasDynFlags(..), ContainsDynFlags(..), RtsOptsEnabled(..), @@ -50,7 +50,7 @@ module DynFlags ( printOutputForUser, printInfoForUser, - Way(..), mkBuildTag, wayRTSOnly, updateWays, + Way(..), mkBuildTag, wayRTSOnly, addWay', updateWays, wayGeneralFlags, wayUnsetGeneralFlags, -- ** Safe Haskell @@ -79,6 +79,7 @@ module DynFlags ( defaultFatalMessager, defaultLogAction, defaultLogActionHPrintDoc, + defaultLogActionHPutStrDoc, defaultFlushOut, defaultFlushErr, @@ -129,6 +130,9 @@ module DynFlags ( -- * SSE isSse2Enabled, isSse4_2Enabled, + + -- * Linker information + LinkerInfo(..), ) where #include "HsVersions.h" @@ -274,6 +278,8 @@ data GeneralFlag -- optimisation opts | Opt_Strictness | Opt_LateDmdAnal + | Opt_KillAbsence + | Opt_KillOneShot | Opt_FullLaziness | Opt_FloatIn | Opt_Specialise @@ -350,6 +356,7 @@ data GeneralFlag | Opt_RPath | Opt_RelativeDynlibPaths | Opt_Hpc + | Opt_FlatCache -- PreInlining is on by default. The option is there just to see how -- bad things get if you turn it off! @@ -407,6 +414,8 @@ data WarningFlag = | Opt_WarnIncompletePatterns | Opt_WarnIncompleteUniPatterns | Opt_WarnIncompletePatternsRecUpd + | Opt_WarnOverflowedLiterals + | Opt_WarnEmptyEnumerations | Opt_WarnMissingFields | Opt_WarnMissingImportList | Opt_WarnMissingMethods @@ -527,6 +536,7 @@ data ExtensionFlag | Opt_MagicHash | Opt_EmptyDataDecls | Opt_KindSignatures + | Opt_RoleAnnotations | Opt_ParallelListComp | Opt_TransformListComp | Opt_MonadComprehensions @@ -551,6 +561,7 @@ data ExtensionFlag | Opt_LambdaCase | Opt_MultiWayIf | Opt_TypeHoles + | Opt_NegativeLiterals | Opt_EmptyCase deriving (Eq, Enum, Show) @@ -561,8 +572,6 @@ data DynFlags = DynFlags { ghcLink :: GhcLink, hscTarget :: HscTarget, settings :: Settings, - hscOutName :: String, -- ^ Name of the output file - extCoreName :: String, -- ^ Name of the .hcr output file verbosity :: Int, -- ^ Verbosity level: see Note [Verbosity levels] optLevel :: Int, -- ^ Optimisation level simplPhases :: Int, -- ^ Number of simplifier phases @@ -613,6 +622,14 @@ data DynFlags = DynFlags { dynObjectSuf :: String, dynHiSuf :: String, + -- Packages.isDllName needs to know whether a call is within a + -- single DLL or not. Normally it does this by seeing if the call + -- is to the same package, but for the ghc package, we split the + -- package between 2 DLLs. The dllSplit tells us which sets of + -- modules are in which package. + dllSplitFile :: Maybe FilePath, + dllSplit :: Maybe [Set String], + outputFile :: Maybe String, dynOutputFile :: Maybe String, outputHi :: Maybe String, @@ -626,7 +643,7 @@ data DynFlags = DynFlags { -- Set by @-ddump-file-prefix@ dumpPrefixForce :: Maybe FilePath, - ldInputs :: [String], + ldInputs :: [Option], includePaths :: [String], libraryPaths :: [String], @@ -735,7 +752,10 @@ data DynFlags = DynFlags { nextWrapperNum :: IORef Int, -- | Machine dependant flags (-m<blah> stuff) - sseVersion :: Maybe (Int, Int) -- (major, minor) + sseVersion :: Maybe (Int, Int), -- (major, minor) + + -- | Run-time linker information (what options we need, etc.) + rtldFlags :: IORef (Maybe LinkerInfo) } class HasDynFlags m where @@ -869,11 +889,6 @@ opt_lc dflags = sOpt_lc (settings dflags) -- 'HscNothing' can be used to avoid generating any output, however, note -- that: -- --- * This will not run the desugaring step, thus no warnings generated in --- this step will be output. In particular, this includes warnings related --- to pattern matching. You can run the desugarer manually using --- 'GHC.desugarModule'. --- -- * If a program uses Template Haskell the typechecker may try to run code -- from an imported module. This will fail if no code has been generated -- for this module. You can use 'GHC.needsTemplateHaskell' to detect @@ -1167,27 +1182,35 @@ generateDynamicTooConditional dflags canGen cannotGen notTryingToGen if b then canGen else cannotGen else notTryingToGen -doDynamicToo :: DynFlags -> DynFlags -doDynamicToo dflags0 = let dflags1 = addWay' WayDyn dflags0 - dflags2 = dflags1 { - outputFile = dynOutputFile dflags1, - hiSuf = dynHiSuf dflags1, - objectSuf = dynObjectSuf dflags1 - } - dflags3 = updateWays dflags2 - in dflags3 +dynamicTooMkDynamicDynFlags :: DynFlags -> DynFlags +dynamicTooMkDynamicDynFlags dflags0 + = let dflags1 = addWay' WayDyn dflags0 + dflags2 = dflags1 { + outputFile = dynOutputFile dflags1, + hiSuf = dynHiSuf dflags1, + objectSuf = dynObjectSuf dflags1 + } + dflags3 = updateWays dflags2 + dflags4 = gopt_unset dflags3 Opt_BuildDynamicToo + in dflags4 ----------------------------------------------------------------------------- -- | Used by 'GHC.newSession' to partially initialize a new 'DynFlags' value initDynFlags :: DynFlags -> IO DynFlags initDynFlags dflags = do - refCanGenerateDynamicToo <- newIORef True + let -- We can't build with dynamic-too on Windows, as labels before + -- the fork point are different depending on whether we are + -- building dynamically or not. + platformCanGenerateDynamicToo + = platformOS (targetPlatform dflags) /= OSMinGW32 + refCanGenerateDynamicToo <- newIORef platformCanGenerateDynamicToo refFilesToClean <- newIORef [] refDirsToClean <- newIORef Map.empty refFilesToNotIntermediateClean <- newIORef [] refGeneratedDumps <- newIORef Set.empty refLlvmVersion <- newIORef 28 + refRtldFlags <- newIORef Nothing wrapperNum <- newIORef 0 canUseUnicodeQuotes <- do let enc = localeEncoding str = "‛’" @@ -1203,7 +1226,8 @@ initDynFlags dflags = do generatedDumps = refGeneratedDumps, llvmVersion = refLlvmVersion, nextWrapperNum = wrapperNum, - useUnicodeQuotes = canUseUnicodeQuotes + useUnicodeQuotes = canUseUnicodeQuotes, + rtldFlags = refRtldFlags } -- | The normal 'DynFlags'. Note that they is not suitable for use in this form @@ -1214,8 +1238,6 @@ defaultDynFlags mySettings = ghcMode = CompManager, ghcLink = LinkBinary, hscTarget = defaultHscTarget (sTargetPlatform mySettings), - hscOutName = "", - extCoreName = "", verbosity = 0, optLevel = 0, simplPhases = 2, @@ -1254,6 +1276,9 @@ defaultDynFlags mySettings = dynObjectSuf = "dyn_" ++ phaseInputExt StopLn, dynHiSuf = "dyn_hi", + dllSplitFile = Nothing, + dllSplit = Nothing, + pluginModNames = [], pluginModNameOpts = [], @@ -1336,7 +1361,8 @@ defaultDynFlags mySettings = llvmVersion = panic "defaultDynFlags: No llvmVersion", interactivePrint = Nothing, nextWrapperNum = panic "defaultDynFlags: No nextWrapperNum", - sseVersion = Nothing + sseVersion = Nothing, + rtldFlags = panic "defaultDynFlags: no rtldFlags" } defaultWays :: Settings -> [Way] @@ -1360,17 +1386,20 @@ defaultFatalMessager = hPutStrLn stderr defaultLogAction :: LogAction defaultLogAction dflags severity srcSpan style msg = case severity of - SevOutput -> printSDoc msg style - SevDump -> printSDoc (msg $$ blankLine) style - SevInfo -> printErrs msg style - SevFatal -> printErrs msg style - _ -> do hPutChar stderr '\n' - printErrs (mkLocMessage severity srcSpan msg) style - -- careful (#2302): printErrs prints in UTF-8, whereas - -- converting to string first and using hPutStr would - -- just emit the low 8 bits of each unicode char. - where printSDoc = defaultLogActionHPrintDoc dflags stdout - printErrs = defaultLogActionHPrintDoc dflags stderr + SevOutput -> printSDoc msg style + SevDump -> printSDoc (msg $$ blankLine) style + SevInteractive -> putStrSDoc msg style + SevInfo -> printErrs msg style + SevFatal -> printErrs msg style + _ -> do hPutChar stderr '\n' + printErrs (mkLocMessage severity srcSpan msg) style + -- careful (#2302): printErrs prints in UTF-8, + -- whereas converting to string first and using + -- hPutStr would just emit the low 8 bits of + -- each unicode char. + where printSDoc = defaultLogActionHPrintDoc dflags stdout + printErrs = defaultLogActionHPrintDoc dflags stderr + putStrSDoc = defaultLogActionHPutStrDoc dflags stdout defaultLogActionHPrintDoc :: DynFlags -> Handle -> SDoc -> PprStyle -> IO () defaultLogActionHPrintDoc dflags h d sty @@ -1378,6 +1407,12 @@ defaultLogActionHPrintDoc dflags h d sty Pretty.printDoc Pretty.PageMode (pprCols dflags) h doc hFlush h +defaultLogActionHPutStrDoc :: DynFlags -> Handle -> SDoc -> PprStyle -> IO () +defaultLogActionHPutStrDoc dflags h d sty + = do let doc = runSDoc d (initSDocContext dflags sty) + hPutStr h (Pretty.render doc) + hFlush h + newtype FlushOut = FlushOut (IO ()) defaultFlushOut :: FlushOut @@ -1853,9 +1888,23 @@ parseDynamicFlagsFull activeFlags cmdline dflags0 args = do let (dflags4, consistency_warnings) = makeDynFlagsConsistent dflags3 - liftIO $ setUnsafeGlobalDynFlags dflags4 + dflags5 <- case dllSplitFile dflags4 of + Nothing -> return (dflags4 { dllSplit = Nothing }) + Just f -> + case dllSplit dflags4 of + Just _ -> + -- If dllSplit is out of date then it would have + -- been set to Nothing. As it's a Just, it must be + -- up-to-date. + return dflags4 + Nothing -> + do xs <- liftIO $ readFile f + let ss = map (Set.fromList . words) (lines xs) + return $ dflags4 { dllSplit = Just ss } + + liftIO $ setUnsafeGlobalDynFlags dflags5 - return (dflags4, leftover, consistency_warnings ++ sh_warns ++ warns) + return (dflags5, leftover, consistency_warnings ++ sh_warns ++ warns) updateWays :: DynFlags -> DynFlags updateWays dflags @@ -2034,10 +2083,12 @@ dynamic_flags = [ , Flag "shared" (noArg (\d -> d{ ghcLink=LinkDynLib })) , Flag "dynload" (hasArg parseDynLibLoaderMode) , Flag "dylib-install-name" (hasArg setDylibInstallName) + -- -dll-split is an internal flag, used only during the GHC build + , Flag "dll-split" (hasArg (\f d -> d{ dllSplitFile = Just f, dllSplit = Nothing })) ------- Libraries --------------------------------------------------- , Flag "L" (Prefix addLibraryPath) - , Flag "l" (hasArg (addOptl . ("-l" ++))) + , Flag "l" (hasArg (addLdInputs . Option . ("-l" ++))) ------- Frameworks -------------------------------------------------- -- -framework-path should really be -F ... @@ -2389,6 +2440,8 @@ fWarningFlags = [ ( "warn-dodgy-foreign-imports", Opt_WarnDodgyForeignImports, nop ), ( "warn-dodgy-exports", Opt_WarnDodgyExports, nop ), ( "warn-dodgy-imports", Opt_WarnDodgyImports, nop ), + ( "warn-overflowed-literals", Opt_WarnOverflowedLiterals, nop ), + ( "warn-empty-enumerations", Opt_WarnEmptyEnumerations, nop ), ( "warn-duplicate-exports", Opt_WarnDuplicateExports, nop ), ( "warn-duplicate-constraints", Opt_WarnDuplicateConstraints, nop ), ( "warn-hi-shadowing", Opt_WarnHiShadows, nop ), @@ -2508,7 +2561,10 @@ fFlags = [ ( "prof-cafs", Opt_AutoSccsOnIndividualCafs, nop ), ( "hpc", Opt_Hpc, nop ), ( "pre-inlining", Opt_SimplPreInlining, nop ), - ( "use-rpaths", Opt_RPath, nop ) + ( "flat-cache", Opt_FlatCache, nop ), + ( "use-rpaths", Opt_RPath, nop ), + ( "kill-absence", Opt_KillAbsence, nop), + ( "kill-one-shot", Opt_KillOneShot, nop) ] -- | These @-f\<blah\>@ flags can all be reversed with @-fno-\<blah\>@ @@ -2587,6 +2643,7 @@ xFlags = [ ( "MagicHash", Opt_MagicHash, nop ), ( "ExistentialQuantification", Opt_ExistentialQuantification, nop ), ( "KindSignatures", Opt_KindSignatures, nop ), + ( "RoleAnnotations", Opt_RoleAnnotations, nop ), ( "EmptyDataDecls", Opt_EmptyDataDecls, nop ), ( "ParallelListComp", Opt_ParallelListComp, nop ), ( "TransformListComp", Opt_TransformListComp, nop ), @@ -2679,6 +2736,7 @@ xFlags = [ ( "IncoherentInstances", Opt_IncoherentInstances, nop ), ( "PackageImports", Opt_PackageImports, nop ), ( "TypeHoles", Opt_TypeHoles, nop ), + ( "NegativeLiterals", Opt_NegativeLiterals, nop ), ( "EmptyCase", Opt_EmptyCase, nop ) ] @@ -2698,6 +2756,7 @@ defaultFlags settings Opt_HelpfulErrors, Opt_ProfCountEntries, Opt_SimplPreInlining, + Opt_FlatCache, Opt_RPath ] @@ -2775,6 +2834,7 @@ optLevelFlags , ([1,2], Opt_FullLaziness) , ([1,2], Opt_Specialise) , ([1,2], Opt_FloatIn) + , ([1,2], Opt_UnboxSmallStrictFields) , ([2], Opt_LiberateCase) , ([2], Opt_SpecConstr) @@ -2808,24 +2868,25 @@ optLevelFlags standardWarnings :: [WarningFlag] standardWarnings - = [ Opt_WarnWarningsDeprecations, + = [ Opt_WarnOverlappingPatterns, + Opt_WarnWarningsDeprecations, Opt_WarnDeprecatedFlags, Opt_WarnUnrecognisedPragmas, - Opt_WarnOverlappingPatterns, + Opt_WarnPointlessPragmas, + Opt_WarnDuplicateConstraints, + Opt_WarnDuplicateExports, + Opt_WarnOverflowedLiterals, + Opt_WarnEmptyEnumerations, Opt_WarnMissingFields, Opt_WarnMissingMethods, - Opt_WarnDuplicateExports, Opt_WarnLazyUnliftedBindings, - Opt_WarnDodgyForeignImports, Opt_WarnWrongDoBind, - Opt_WarnAlternativeLayoutRuleTransitional, - Opt_WarnPointlessPragmas, Opt_WarnUnsupportedCallingConventions, - Opt_WarnUnsupportedLlvmVersion, - Opt_WarnInlineRuleShadowing, - Opt_WarnDuplicateConstraints, + Opt_WarnDodgyForeignImports, + Opt_WarnTypeableInstances, Opt_WarnInlineRuleShadowing, - Opt_WarnTypeableInstances + Opt_WarnAlternativeLayoutRuleTransitional, + Opt_WarnUnsupportedLlvmVersion ] minusWOpts :: [WarningFlag] @@ -3184,6 +3245,9 @@ setMainIs arg where (main_mod, main_fn) = splitLongestPrefix arg (== '.') +addLdInputs :: Option -> DynFlags -> DynFlags +addLdInputs p dflags = dflags{ldInputs = ldInputs dflags ++ [p]} + ----------------------------------------------------------------------------- -- Paths & Libraries @@ -3359,6 +3423,7 @@ compilerInfo dflags ("Support SMP", cGhcWithSMP), ("Tables next to code", cGhcEnableTablesNextToCode), ("RTS ways", cGhcRTSWays), + ("Support dynamic-too", "YES"), ("Dynamic by default", if dYNAMIC_BY_DEFAULT dflags then "YES" else "NO"), ("GHC Dynamic", if cDYNAMIC_GHC_PROGRAMS @@ -3415,7 +3480,7 @@ makeDynFlagsConsistent dflags else let dflags' = dflags { hscTarget = HscLlvm } warn = "Compiler not unregisterised, so using LLVM rather than compiling via C" in loop dflags' warn - | hscTarget dflags /= HscC && hscTarget dflags /= HscLlvm && + | hscTarget dflags == HscAsm && platformUnregisterised (targetPlatform dflags) = loop (dflags { hscTarget = HscC }) "Compiler unregisterised, so compiling via C" @@ -3484,3 +3549,14 @@ isSse2Enabled dflags = case platformArch (targetPlatform dflags) of isSse4_2Enabled :: DynFlags -> Bool isSse4_2Enabled dflags = sseVersion dflags >= Just (4,2) + +-- ----------------------------------------------------------------------------- +-- Linker information + +-- LinkerInfo contains any extra options needed by the system linker. +data LinkerInfo + = GnuLD [Option] + | GnuGold [Option] + | DarwinLD [Option] + | UnknownLD + deriving Eq diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs index 3fd92ed473..f9f4387120 100644 --- a/compiler/main/ErrUtils.lhs +++ b/compiler/main/ErrUtils.lhs @@ -78,6 +78,7 @@ type MsgDoc = SDoc data Severity = SevOutput | SevDump + | SevInteractive | SevInfo | SevWarning | SevError diff --git a/compiler/main/ErrUtils.lhs-boot b/compiler/main/ErrUtils.lhs-boot index 6f4a373313..fc99c5afde 100644 --- a/compiler/main/ErrUtils.lhs-boot +++ b/compiler/main/ErrUtils.lhs-boot @@ -7,6 +7,7 @@ import SrcLoc (SrcSpan) data Severity = SevOutput | SevDump + | SevInteractive | SevInfo | SevWarning | SevError diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index c72f1f1be6..39e1e0a453 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -157,7 +157,7 @@ module GHC ( TyCon, tyConTyVars, tyConDataCons, tyConArity, isClassTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isFunTyCon, - isFamilyTyCon, tyConClass_maybe, + isFamilyTyCon, isOpenFamilyTyCon, tyConClass_maybe, synTyConRhs_maybe, synTyConDefn_maybe, synTyConResKind, -- ** Type variables @@ -182,7 +182,7 @@ module GHC ( pprInstance, pprInstanceHdr, pprFamInst, - FamInst, Branched, + FamInst, -- ** Types and Kinds Type, splitForAllTys, funResultTy, @@ -892,8 +892,10 @@ compileToCoreSimplified = compileCore True -- The resulting .o, .hi, and executable files, if any, are stored in the -- current directory, and named according to the module name. -- This has only so far been tested with a single self-contained module. -compileCoreToObj :: GhcMonad m => Bool -> CoreModule -> m () -compileCoreToObj simplify cm@(CoreModule{ cm_module = mName }) = do +compileCoreToObj :: GhcMonad m + => Bool -> CoreModule -> FilePath -> FilePath -> m () +compileCoreToObj simplify cm@(CoreModule{ cm_module = mName }) + output_fn extCore_filename = do dflags <- getSessionDynFlags currentTime <- liftIO $ getCurrentTime cwd <- liftIO $ getCurrentDirectory @@ -919,7 +921,7 @@ compileCoreToObj simplify cm@(CoreModule{ cm_module = mName }) = do } hsc_env <- getSession - liftIO $ hscCompileCore hsc_env simplify (cm_safe cm) modSum (cm_binds cm) + liftIO $ hscCompileCore hsc_env simplify (cm_safe cm) modSum (cm_binds cm) output_fn extCore_filename compileCore :: GhcMonad m => Bool -> FilePath -> m CoreModule @@ -1002,7 +1004,7 @@ getBindings = withSession $ \hsc_env -> return $ icInScopeTTs $ hsc_IC hsc_env -- | Return the instances for the current interactive session. -getInsts :: GhcMonad m => m ([ClsInst], [FamInst Branched]) +getInsts :: GhcMonad m => m ([ClsInst], [FamInst]) getInsts = withSession $ \hsc_env -> return $ ic_instances (hsc_IC hsc_env) diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs index 4970b6725e..c43b18a62a 100644 --- a/compiler/main/GhcMake.hs +++ b/compiler/main/GhcMake.hs @@ -332,8 +332,7 @@ load how_much = do liftIO $ intermediateCleanTempFiles dflags mods_to_keep hsc_env1 -- there should be no Nothings where linkables should be, now - ASSERT(all (isJust.hm_linkable) - (eltsUFM (hsc_HPT hsc_env))) do + ASSERT(all (isJust.hm_linkable) (eltsUFM (hsc_HPT hsc_env))) do -- Link everything together linkresult <- liftIO $ link (ghcLink dflags) dflags False hpt4 diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs index f7ae35ff55..2560db37f8 100644 --- a/compiler/main/HeaderInfo.hs +++ b/compiler/main/HeaderInfo.hs @@ -8,13 +8,6 @@ -- ----------------------------------------------------------------------------- -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module HeaderInfo ( getImports , mkPrelImports -- used by the renamer too , getOptionsFromFile, getOptions @@ -25,7 +18,7 @@ module HeaderInfo ( getImports import RdrName import HscTypes -import Parser ( parseHeader ) +import Parser ( parseHeader ) import Lexer import FastString import HsSyn @@ -39,7 +32,7 @@ import Util import Outputable import Pretty () import Maybes -import Bag ( emptyBag, listToBag, unitBag ) +import Bag ( emptyBag, listToBag, unitBag ) import MonadUtils import Exception @@ -74,23 +67,23 @@ getImports dflags buf filename source_filename = do if errorsFound dflags ms then throwIO $ mkSrcErr errs else - case rdr_module of - L _ (HsModule mb_mod _ imps _ _ _) -> - let + case rdr_module of + L _ (HsModule mb_mod _ imps _ _ _) -> + let main_loc = srcLocSpan (mkSrcLoc (mkFastString source_filename) 1 1) - mod = mb_mod `orElse` L main_loc mAIN_NAME - (src_idecls, ord_idecls) = partition (ideclSource.unLoc) imps + mod = mb_mod `orElse` L main_loc mAIN_NAME + (src_idecls, ord_idecls) = partition (ideclSource.unLoc) imps - -- GHC.Prim doesn't exist physically, so don't go looking for it. - ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc . ideclName . unLoc) - ord_idecls + -- GHC.Prim doesn't exist physically, so don't go looking for it. + ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc . ideclName . unLoc) + ord_idecls implicit_prelude = xopt Opt_ImplicitPrelude dflags implicit_imports = mkPrelImports (unLoc mod) main_loc implicit_prelude imps - in - return (src_idecls, implicit_imports ++ ordinary_imps, mod) + in + return (src_idecls, implicit_imports ++ ordinary_imps, mod) -mkPrelImports :: ModuleName +mkPrelImports :: ModuleName -> SrcSpan -- Attribute the "import Prelude" to this location -> Bool -> [LImportDecl RdrName] -> [LImportDecl RdrName] @@ -108,20 +101,20 @@ mkPrelImports this_mod loc implicit_prelude import_decls where explicit_prelude_import = notNull [ () | L _ (ImportDecl { ideclName = mod - , ideclPkgQual = Nothing }) + , ideclPkgQual = Nothing }) <- import_decls - , unLoc mod == pRELUDE_NAME ] + , unLoc mod == pRELUDE_NAME ] preludeImportDecl :: LImportDecl RdrName preludeImportDecl = L loc $ ImportDecl { ideclName = L loc pRELUDE_NAME, - ideclPkgQual = Nothing, - ideclSource = False, - ideclSafe = False, -- Not a safe import - ideclQualified = False, - ideclImplicit = True, -- Implicit! - ideclAs = Nothing, - ideclHiding = Nothing } + ideclPkgQual = Nothing, + ideclSource = False, + ideclSafe = False, -- Not a safe import + ideclQualified = False, + ideclImplicit = True, -- Implicit! + ideclAs = Nothing, + ideclHiding = Nothing } parseError :: DynFlags -> SrcSpan -> MsgDoc -> IO a parseError dflags span err = throwOneError $ mkPlainErrMsg dflags span err @@ -138,7 +131,7 @@ getOptionsFromFile :: DynFlags -> IO [Located String] -- ^ Parsed options, if any. getOptionsFromFile dflags filename = Exception.bracket - (openBinaryFile filename ReadMode) + (openBinaryFile filename ReadMode) (hClose) (\handle -> do opts <- fmap (getOptions' dflags) @@ -226,7 +219,7 @@ getOptions' :: DynFlags -> [Located String] -- Options. getOptions' dflags toks = parseToks toks - where + where getToken (L _loc tok) = tok getLoc (L loc _tok) = loc @@ -313,9 +306,9 @@ unsupportedExtnError dflags loc unsup = optionsErrorMsgs :: DynFlags -> [String] -> [Located String] -> FilePath -> Messages optionsErrorMsgs dflags unhandled_flags flags_lines _filename = (emptyBag, listToBag (map mkMsg unhandled_flags_lines)) - where unhandled_flags_lines = [ L l f | f <- unhandled_flags, - L l f' <- flags_lines, f == f' ] - mkMsg (L flagSpan flag) = + where unhandled_flags_lines = [ L l f | f <- unhandled_flags, + L l f' <- flags_lines, f == f' ] + mkMsg (L flagSpan flag) = ErrUtils.mkPlainErrMsg dflags flagSpan $ text "unknown flag in {-# OPTIONS_GHC #-} pragma:" <+> text flag diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index c97e3ec724..e884fe5bcf 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -303,7 +303,7 @@ hscTcRcLookupName hsc_env0 name = runInteractiveHsc hsc_env0 $ do -- "name not found", and the Maybe in the return type -- is used to indicate that. -hscTcRnGetInfo :: HscEnv -> Name -> IO (Maybe (TyThing, Fixity, [ClsInst], [FamInst Branched])) +hscTcRnGetInfo :: HscEnv -> Name -> IO (Maybe (TyThing, Fixity, [ClsInst], [FamInst])) hscTcRnGetInfo hsc_env0 name = runInteractiveHsc hsc_env0 $ do hsc_env <- getHscEnv ioMsgMaybe' $ tcRnGetInfo hsc_env name @@ -616,10 +616,11 @@ genericHscFrontend mod_summary -- Compile Haskell, boot and extCore in OneShot mode. hscCompileOneShot :: HscEnv + -> FilePath -> ModSummary -> SourceModified -> IO HscStatus -hscCompileOneShot hsc_env mod_summary src_changed +hscCompileOneShot hsc_env extCore_filename mod_summary src_changed = do -- One-shot mode needs a knot-tying mutable variable for interface -- files. See TcRnTypes.TcGblEnv.tcg_type_env_var. @@ -636,6 +637,7 @@ hscCompileOneShot hsc_env mod_summary src_changed compile mb_old_hash reason = runHsc hsc_env' $ do liftIO $ msg reason tc_result <- genericHscFrontend mod_summary + guts0 <- hscDesugar' (ms_location mod_summary) tc_result dflags <- getDynFlags case hscTarget dflags of HscNothing -> return HscNotGeneratingCode @@ -646,9 +648,8 @@ hscCompileOneShot hsc_env mod_summary src_changed liftIO $ hscWriteIface dflags iface changed mod_summary return HscUpdateBoot _ -> - do guts0 <- hscDesugar' (ms_location mod_summary) tc_result - guts <- hscSimplify' guts0 - (iface, changed, _details, cgguts) <- hscNormalIface' guts mb_old_hash + do guts <- hscSimplify' guts0 + (iface, changed, _details, cgguts) <- hscNormalIface' extCore_filename guts mb_old_hash liftIO $ hscWriteIface dflags iface changed mod_summary return $ HscRecomp cgguts mod_summary @@ -1082,16 +1083,18 @@ hscSimpleIface' tc_result mb_old_iface = do return (new_iface, no_change, details) hscNormalIface :: HscEnv + -> FilePath -> ModGuts -> Maybe Fingerprint -> IO (ModIface, Bool, ModDetails, CgGuts) -hscNormalIface hsc_env simpl_result mb_old_iface = - runHsc hsc_env $ hscNormalIface' simpl_result mb_old_iface +hscNormalIface hsc_env extCore_filename simpl_result mb_old_iface = + runHsc hsc_env $ hscNormalIface' extCore_filename simpl_result mb_old_iface -hscNormalIface' :: ModGuts +hscNormalIface' :: FilePath + -> ModGuts -> Maybe Fingerprint -> Hsc (ModIface, Bool, ModDetails, CgGuts) -hscNormalIface' simpl_result mb_old_iface = do +hscNormalIface' extCore_filename simpl_result mb_old_iface = do hsc_env <- getHscEnv (cg_guts, details) <- {-# SCC "CoreTidy" #-} liftIO $ tidyProgram hsc_env simpl_result @@ -1110,7 +1113,7 @@ hscNormalIface' simpl_result mb_old_iface = do -- This should definitely be here and not after CorePrep, -- because CorePrep produces unqualified constructor wrapper declarations, -- so its output isn't valid External Core (without some preprocessing). - liftIO $ emitExternalCore (hsc_dflags hsc_env) cg_guts + liftIO $ emitExternalCore (hsc_dflags hsc_env) extCore_filename cg_guts liftIO $ dumpIfaceStats hsc_env -- Return the prepared code. @@ -1132,13 +1135,13 @@ hscWriteIface dflags iface no_change mod_summary = do -- TODO: Should handle the dynamic hi filename properly let dynIfaceFile = replaceExtension ifaceFile (dynHiSuf dflags) dynIfaceFile' = addBootSuffix_maybe (mi_boot iface) dynIfaceFile - dynDflags = doDynamicToo dflags + dynDflags = dynamicTooMkDynamicDynFlags dflags writeIfaceFile dynDflags dynIfaceFile' iface -- | Compile to hard-code. -hscGenHardCode :: HscEnv -> CgGuts -> ModSummary +hscGenHardCode :: HscEnv -> CgGuts -> ModSummary -> FilePath -> IO (FilePath, Maybe FilePath) -- ^ @Just f@ <=> _stub.c is f -hscGenHardCode hsc_env cgguts mod_summary = do +hscGenHardCode hsc_env cgguts mod_summary output_filename = do let CgGuts{ -- This is the last use of the ModGuts in a compilation. -- From now on, we just use the bits we need. cg_module = this_mod, @@ -1184,8 +1187,8 @@ hscGenHardCode hsc_env cgguts mod_summary = do (output_filename, (_stub_h_exists, stub_c_exists)) <- {-# SCC "codeOutput" #-} - codeOutput dflags this_mod location foreign_stubs - dependencies rawcmms1 + codeOutput dflags this_mod output_filename location + foreign_stubs dependencies rawcmms1 return (output_filename, stub_c_exists) @@ -1226,8 +1229,8 @@ hscInteractive _ _ = panic "GHC not compiled with interpreter" ------------------------------ -hscCompileCmmFile :: HscEnv -> FilePath -> IO () -hscCompileCmmFile hsc_env filename = runHsc hsc_env $ do +hscCompileCmmFile :: HscEnv -> FilePath -> FilePath -> IO () +hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do let dflags = hsc_dflags hsc_env cmm <- ioMsgMaybe $ parseCmmFile dflags filename liftIO $ do @@ -1236,7 +1239,7 @@ hscCompileCmmFile hsc_env filename = runHsc hsc_env $ do dumpIfSet_dyn dflags Opt_D_dump_cmm "Parsed Cmm" (ppr cmm) (_, cmmgroup) <- cmmPipeline hsc_env initTopSRT cmm rawCmms <- cmmToRawCmm dflags (Stream.yield cmmgroup) - _ <- codeOutput dflags no_mod no_loc NoStubs [] rawCmms + _ <- codeOutput dflags no_mod output_filename no_loc NoStubs [] rawCmms return () where no_mod = panic "hscCmmFile: no_mod" @@ -1321,7 +1324,7 @@ myCoreToStg :: DynFlags -> Module -> CoreProgram myCoreToStg dflags this_mod prepd_binds = do stg_binds <- {-# SCC "Core2Stg" #-} - coreToStg dflags prepd_binds + coreToStg dflags this_mod prepd_binds (stg_binds2, cost_centre_info) <- {-# SCC "Stg2Stg" #-} @@ -1556,13 +1559,13 @@ hscParseThingWithLocation source linenumber parser str return thing hscCompileCore :: HscEnv -> Bool -> SafeHaskellMode -> ModSummary - -> CoreProgram -> IO () -hscCompileCore hsc_env simplify safe_mode mod_summary binds + -> CoreProgram -> FilePath -> FilePath -> IO () +hscCompileCore hsc_env simplify safe_mode mod_summary binds output_filename extCore_filename = runHsc hsc_env $ do guts <- maybe_simplify (mkModGuts (ms_mod mod_summary) safe_mode binds) - (iface, changed, _details, cgguts) <- hscNormalIface' guts Nothing + (iface, changed, _details, cgguts) <- hscNormalIface' extCore_filename guts Nothing liftIO $ hscWriteIface (hsc_dflags hsc_env) iface changed mod_summary - _ <- liftIO $ hscGenHardCode hsc_env cgguts mod_summary + _ <- liftIO $ hscGenHardCode hsc_env cgguts mod_summary output_filename return () where diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index d9fe88bb80..e022ae3eae 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -37,7 +37,7 @@ module HscTypes ( PackageInstEnv, PackageRuleBase, - mkSOName, soExt, + mkSOName, mkHsSOName, soExt, -- * Annotations prepareAnnotations, @@ -159,6 +159,7 @@ import StringBuffer ( StringBuffer ) import Fingerprint import MonadUtils import Bag +import Binary import ErrUtils import Platform import Util @@ -456,7 +457,7 @@ lookupIfaceByModule dflags hpt pit mod -- modules imported by this one, directly or indirectly, and are in the Home -- Package Table. This ensures that we don't see instances from modules @--make@ -- compiled before this one, but which are not below this one. -hptInstances :: HscEnv -> (ModuleName -> Bool) -> ([ClsInst], [FamInst Branched]) +hptInstances :: HscEnv -> (ModuleName -> Bool) -> ([ClsInst], [FamInst]) hptInstances hsc_env want_this_module = let (insts, famInsts) = unzip $ flip hptAllThings hsc_env $ \mod_info -> do guard (want_this_module (moduleName (mi_module (hm_iface mod_info)))) @@ -717,6 +718,113 @@ data ModIface -- See Note [RnNames . Trust Own Package] } +instance Binary ModIface where + put_ bh (ModIface { + mi_module = mod, + mi_boot = is_boot, + mi_iface_hash= iface_hash, + mi_mod_hash = mod_hash, + mi_flag_hash = flag_hash, + mi_orphan = orphan, + mi_finsts = hasFamInsts, + mi_deps = deps, + mi_usages = usages, + mi_exports = exports, + mi_exp_hash = exp_hash, + mi_used_th = used_th, + mi_fixities = fixities, + mi_warns = warns, + mi_anns = anns, + mi_decls = decls, + mi_insts = insts, + mi_fam_insts = fam_insts, + mi_rules = rules, + mi_orphan_hash = orphan_hash, + mi_vect_info = vect_info, + mi_hpc = hpc_info, + mi_trust = trust, + mi_trust_pkg = trust_pkg }) = do + put_ bh mod + put_ bh is_boot + put_ bh iface_hash + put_ bh mod_hash + put_ bh flag_hash + put_ bh orphan + put_ bh hasFamInsts + lazyPut bh deps + lazyPut bh usages + put_ bh exports + put_ bh exp_hash + put_ bh used_th + put_ bh fixities + lazyPut bh warns + lazyPut bh anns + put_ bh decls + put_ bh insts + put_ bh fam_insts + lazyPut bh rules + put_ bh orphan_hash + put_ bh vect_info + put_ bh hpc_info + put_ bh trust + put_ bh trust_pkg + + get bh = do + mod_name <- get bh + is_boot <- get bh + iface_hash <- get bh + mod_hash <- get bh + flag_hash <- get bh + orphan <- get bh + hasFamInsts <- get bh + deps <- lazyGet bh + usages <- {-# SCC "bin_usages" #-} lazyGet bh + exports <- {-# SCC "bin_exports" #-} get bh + exp_hash <- get bh + used_th <- get bh + fixities <- {-# SCC "bin_fixities" #-} get bh + warns <- {-# SCC "bin_warns" #-} lazyGet bh + anns <- {-# SCC "bin_anns" #-} lazyGet bh + decls <- {-# SCC "bin_tycldecls" #-} get bh + insts <- {-# SCC "bin_insts" #-} get bh + fam_insts <- {-# SCC "bin_fam_insts" #-} get bh + rules <- {-# SCC "bin_rules" #-} lazyGet bh + orphan_hash <- get bh + vect_info <- get bh + hpc_info <- get bh + trust <- get bh + trust_pkg <- get bh + return (ModIface { + mi_module = mod_name, + mi_boot = is_boot, + mi_iface_hash = iface_hash, + mi_mod_hash = mod_hash, + mi_flag_hash = flag_hash, + mi_orphan = orphan, + mi_finsts = hasFamInsts, + mi_deps = deps, + mi_usages = usages, + mi_exports = exports, + mi_exp_hash = exp_hash, + mi_used_th = used_th, + mi_anns = anns, + mi_fixities = fixities, + mi_warns = warns, + mi_decls = decls, + mi_globals = Nothing, + mi_insts = insts, + mi_fam_insts = fam_insts, + mi_rules = rules, + mi_orphan_hash = orphan_hash, + mi_vect_info = vect_info, + mi_hpc = hpc_info, + mi_trust = trust, + mi_trust_pkg = trust_pkg, + -- And build the cached values + mi_warn_fn = mkIfaceWarnCache warns, + mi_fix_fn = mkIfaceFixCache fixities, + mi_hash_fn = mkIfaceHashCache decls }) + -- | The original names declared of a certain module that are exported type IfaceExport = AvailInfo @@ -777,7 +885,7 @@ data ModDetails md_exports :: [AvailInfo], md_types :: !TypeEnv, -- ^ Local type environment for this particular module md_insts :: ![ClsInst], -- ^ 'DFunId's for the instances in this module - md_fam_insts :: ![FamInst Branched], + md_fam_insts :: ![FamInst], md_rules :: ![CoreRule], -- ^ Domain may include 'Id's from other modules md_anns :: ![Annotation], -- ^ Annotations present in this module: currently -- they only annotate things also declared in this module @@ -823,7 +931,7 @@ data ModGuts mg_tcs :: ![TyCon], -- ^ TyCons declared in this module -- (includes TyCons for classes) mg_insts :: ![ClsInst], -- ^ Class instances declared in this module - mg_fam_insts :: ![FamInst Branched], + mg_fam_insts :: ![FamInst], -- ^ Family instances declared in this module mg_rules :: ![CoreRule], -- ^ Before the core pipeline starts, contains -- See Note [Overall plumbing for rules] in Rules.lhs @@ -953,7 +1061,7 @@ data InteractiveContext -- ^ Variables defined automatically by the system (e.g. -- record field selectors). See Notes [ic_sys_vars] - ic_instances :: ([ClsInst], [FamInst Branched]), + ic_instances :: ([ClsInst], [FamInst]), -- ^ All instances and family instances created during -- this session. These are grabbed en masse after each -- update to be sure that proper overlapping is retained. @@ -1280,10 +1388,12 @@ implicitTyConThings tc extras_plus :: TyThing -> [TyThing] extras_plus thing = thing : implicitTyThings thing --- For newtypes (only) add the implicit coercion tycon +-- For newtypes and closed type families (only) add the implicit coercion tycon implicitCoTyCon :: TyCon -> [TyThing] implicitCoTyCon tc | Just co <- newTyConCo_maybe tc = [ACoAxiom $ toBranchedAxiom co] + | Just co <- isClosedSynFamilyTyCon_maybe tc + = [ACoAxiom co] | otherwise = [] -- | Returns @True@ if there should be no interface-file declaration @@ -1379,12 +1489,12 @@ mkTypeEnvWithImplicits things = `plusNameEnv` mkTypeEnv (concatMap implicitTyThings things) -typeEnvFromEntities :: [Id] -> [TyCon] -> [FamInst Branched] -> TypeEnv +typeEnvFromEntities :: [Id] -> [TyCon] -> [FamInst] -> TypeEnv typeEnvFromEntities ids tcs famInsts = mkTypeEnv ( map AnId ids ++ map ATyCon all_tcs ++ concatMap implicitTyConThings all_tcs - ++ map (ACoAxiom . famInstAxiom) famInsts + ++ map (ACoAxiom . toBranchedAxiom . famInstAxiom) famInsts ) where all_tcs = tcs ++ famInstsRepTyCons famInsts @@ -1525,6 +1635,24 @@ data Warnings -- a Name to its fixity declaration. deriving( Eq ) +instance Binary Warnings where + put_ bh NoWarnings = putByte bh 0 + put_ bh (WarnAll t) = do + putByte bh 1 + put_ bh t + put_ bh (WarnSome ts) = do + putByte bh 2 + put_ bh ts + + get bh = do + h <- getByte bh + case h of + 0 -> return NoWarnings + 1 -> do aa <- get bh + return (WarnAll aa) + _ -> do aa <- get bh + return (WarnSome aa) + -- | Constructs the cache for the 'mi_warn_fn' field of a 'ModIface' mkIfaceWarnCache :: Warnings -> Name -> Maybe WarningTxt mkIfaceWarnCache NoWarnings = \_ -> Nothing @@ -1623,6 +1751,19 @@ data Dependencies -- Equality used only for old/new comparison in MkIface.addFingerprints -- See 'TcRnTypes.ImportAvails' for details on dependencies. +instance Binary Dependencies where + put_ bh deps = do put_ bh (dep_mods deps) + put_ bh (dep_pkgs deps) + put_ bh (dep_orphs deps) + put_ bh (dep_finsts deps) + + get bh = do ms <- get bh + ps <- get bh + os <- get bh + fis <- get bh + return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os, + dep_finsts = fis }) + noDependencies :: Dependencies noDependencies = Deps [] [] [] [] @@ -1671,6 +1812,49 @@ data Usage -- import M() -- And of course, for modules that aren't imported directly we don't -- depend on their export lists + +instance Binary Usage where + put_ bh usg@UsagePackageModule{} = do + putByte bh 0 + put_ bh (usg_mod usg) + put_ bh (usg_mod_hash usg) + put_ bh (usg_safe usg) + + put_ bh usg@UsageHomeModule{} = do + putByte bh 1 + put_ bh (usg_mod_name usg) + put_ bh (usg_mod_hash usg) + put_ bh (usg_exports usg) + put_ bh (usg_entities usg) + put_ bh (usg_safe usg) + + put_ bh usg@UsageFile{} = do + putByte bh 2 + put_ bh (usg_file_path usg) + put_ bh (usg_mtime usg) + + get bh = do + h <- getByte bh + case h of + 0 -> do + nm <- get bh + mod <- get bh + safe <- get bh + return UsagePackageModule { usg_mod = nm, usg_mod_hash = mod, usg_safe = safe } + 1 -> do + nm <- get bh + mod <- get bh + exps <- get bh + ents <- get bh + safe <- get bh + return UsageHomeModule { usg_mod_name = nm, usg_mod_hash = mod, + usg_exports = exps, usg_entities = ents, usg_safe = safe } + 2 -> do + fp <- get bh + mtime <- get bh + return UsageFile { usg_file_path = fp, usg_mtime = mtime } + i -> error ("Binary.get(Usage): " ++ show i) + \end{code} @@ -1796,6 +1980,9 @@ mkSOName platform root OSMinGW32 -> root <.> "dll" _ -> ("lib" ++ root) <.> "so" +mkHsSOName :: Platform -> FilePath -> FilePath +mkHsSOName platform root = ("lib" ++ root) <.> soExt platform + soExt :: Platform -> FilePath soExt platform = case platformOS platform of @@ -2055,6 +2242,21 @@ instance Outputable VectInfo where , ptext (sLit "parallel vars :") <+> ppr (vectInfoParallelVars info) , ptext (sLit "parallel tycons :") <+> ppr (vectInfoParallelTyCons info) ] + +instance Binary IfaceVectInfo where + put_ bh (IfaceVectInfo a1 a2 a3 a4 a5) = do + put_ bh a1 + put_ bh a2 + put_ bh a3 + put_ bh a4 + put_ bh a5 + get bh = do + a1 <- get bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + return (IfaceVectInfo a1 a2 a3 a4 a5) \end{code} %************************************************************************ @@ -2106,6 +2308,10 @@ instance Outputable IfaceTrustInfo where ppr (TrustInfo Sf_Trustworthy) = ptext $ sLit "trustworthy" ppr (TrustInfo Sf_Safe) = ptext $ sLit "safe" ppr (TrustInfo Sf_SafeInferred) = ptext $ sLit "safe-inferred" + +instance Binary IfaceTrustInfo where + put_ bh iftrust = putByte bh $ trustInfoToNum iftrust + get bh = getByte bh >>= (return . numToTrustInfo) \end{code} %************************************************************************ diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index 391de5a42f..635c194a92 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -45,7 +45,7 @@ import HscMain import HsSyn import HscTypes import InstEnv -import FamInstEnv ( FamInst, Branched, orphNamesOfFamInst ) +import FamInstEnv ( FamInst, orphNamesOfFamInst ) import TyCon import Type hiding( typeKind ) import TcType hiding( typeKind ) @@ -890,7 +890,7 @@ moduleIsInterpreted modl = withSession $ \h -> -- are in scope (qualified or otherwise). Otherwise we list a whole lot too many! -- The exact choice of which ones to show, and which to hide, is a judgement call. -- (see Trac #1581) -getInfo :: GhcMonad m => Bool -> Name -> m (Maybe (TyThing,Fixity,[ClsInst],[FamInst Branched])) +getInfo :: GhcMonad m => Bool -> Name -> m (Maybe (TyThing,Fixity,[ClsInst],[FamInst])) getInfo allInfo name = withSession $ \hsc_env -> do mb_stuff <- liftIO $ hscTcRnGetInfo hsc_env name diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs index 54d9d1b66b..cc8dfe3eb7 100644 --- a/compiler/main/Packages.lhs +++ b/compiler/main/Packages.lhs @@ -1039,13 +1039,24 @@ missingDependencyMsg (Just parent) -- ----------------------------------------------------------------------------- -- | Will the 'Name' come from a dynamically linked library? -isDllName :: DynFlags -> PackageId -> Name -> Bool +isDllName :: DynFlags -> PackageId -> Module -> 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 dflags this_pkg name +isDllName dflags this_pkg this_mod name | gopt Opt_Static dflags = False - | Just mod <- nameModule_maybe name = modulePackageId mod /= this_pkg + | Just mod <- nameModule_maybe name + = if modulePackageId mod /= this_pkg + then True + else case dllSplit dflags of + Nothing -> False + Just ss -> + let findMod m = let modStr = moduleNameString (moduleName m) + in case find (modStr `Set.member`) ss of + Just i -> i + Nothing -> panic ("Can't find " ++ modStr ++ "in DLL split") + in findMod mod /= findMod this_mod + | otherwise = False -- no, it is not even an external name -- ----------------------------------------------------------------------------- diff --git a/compiler/main/PprTyThing.hs b/compiler/main/PprTyThing.hs index c14b853145..b95c69902a 100644 --- a/compiler/main/PprTyThing.hs +++ b/compiler/main/PprTyThing.hs @@ -29,9 +29,11 @@ import GHC ( TyThing(..) ) import DataCon import Id import TyCon -import Coercion( pprCoAxiom ) +import Coercion( pprCoAxiom, pprCoAxBranch ) +import CoAxiom( CoAxiom(..), brListMap ) import HscTypes( tyThingParent_maybe ) import Type( tidyTopType, tidyOpenType ) +import TypeRep( pprTvBndrs ) import TcType import Name import VarEnv( emptyTidyEnv ) @@ -106,6 +108,7 @@ ppr_ty_thing pefas _ (AnId id) = pprId pefas id ppr_ty_thing pefas _ (ADataCon dataCon) = pprDataConSig pefas dataCon ppr_ty_thing pefas ss (ATyCon tyCon) = pprTyCon pefas ss tyCon ppr_ty_thing _ _ (ACoAxiom ax) = pprCoAxiom ax + pprTyConHdr :: PrintExplicitForalls -> TyCon -> SDoc pprTyConHdr pefas tyCon | Just (fam_tc, tys) <- tyConFamInst_maybe tyCon @@ -113,7 +116,7 @@ pprTyConHdr pefas tyCon | Just cls <- tyConClass_maybe tyCon = pprClassHdr pefas cls | otherwise - = ptext keyword <+> opt_family <+> opt_stupid <+> ppr_bndr tyCon <+> hsep (map ppr vars) + = ptext keyword <+> opt_family <+> opt_stupid <+> ppr_bndr tyCon <+> pprTvBndrs vars where vars | GHC.isPrimTyCon tyCon || GHC.isFunTyCon tyCon = take (GHC.tyConArity tyCon) GHC.alphaTyVars @@ -138,10 +141,9 @@ pprDataConSig pefas dataCon pprClassHdr :: PrintExplicitForalls -> GHC.Class -> SDoc pprClassHdr _ cls = ptext (sLit "class") <+> - GHC.pprThetaArrowTy (GHC.classSCTheta cls) <+> - ppr_bndr cls <+> - hsep (map ppr tyVars) <+> - GHC.pprFundeps funDeps + sep [ GHC.pprThetaArrowTy (GHC.classSCTheta cls) + , ppr_bndr cls <+> pprTvBndrs tyVars + , GHC.pprFundeps funDeps ] where (tyVars, funDeps) = GHC.classTvsFds cls @@ -174,16 +176,25 @@ pprTyCon :: PrintExplicitForalls -> ShowSub -> TyCon -> SDoc pprTyCon pefas ss tyCon | Just syn_rhs <- GHC.synTyConRhs_maybe tyCon = case syn_rhs of - SynFamilyTyCon {} -> pprTyConHdr pefas tyCon <+> dcolon <+> - pprTypeForUser pefas (GHC.synTyConResKind tyCon) + OpenSynFamilyTyCon -> pprTyConHdr pefas tyCon <+> dcolon <+> + pprTypeForUser pefas (GHC.synTyConResKind tyCon) + ClosedSynFamilyTyCon (CoAxiom { co_ax_branches = branches }) -> + hang closed_family_header + 2 (vcat (brListMap (pprCoAxBranch tyCon) branches)) + AbstractClosedSynFamilyTyCon -> closed_family_header <+> ptext (sLit "..") SynonymTyCon rhs_ty -> hang (pprTyConHdr pefas tyCon <+> equals) - 2 (pprTypeForUser pefas rhs_ty) - + 2 (ppr rhs_ty) -- Don't suppress foralls on RHS type! + -- e.g. type T = forall a. a->a | Just cls <- GHC.tyConClass_maybe tyCon = pprClass pefas ss cls | otherwise = pprAlgTyCon pefas ss tyCon + where + closed_family_header + = pprTyConHdr pefas tyCon <+> dcolon <+> + pprTypeForUser pefas (GHC.synTyConResKind tyCon) <+> ptext (sLit "where") + pprAlgTyCon :: PrintExplicitForalls -> ShowSub -> TyCon -> SDoc pprAlgTyCon pefas ss tyCon | gadt = pprTyConHdr pefas tyCon <+> ptext (sLit "where") $$ @@ -228,7 +239,7 @@ pprDataConDecl pefas ss gadt_style dataCon user_ify bang = bang maybe_show_label (lbl,bty) - | showSub ss lbl = Just (ppr lbl <+> dcolon <+> pprBangTy bty) + | showSub ss lbl = Just (ppr_bndr lbl <+> dcolon <+> pprBangTy bty) | otherwise = Nothing ppr_fields [ty1, ty2] diff --git a/compiler/main/StaticFlags.hs b/compiler/main/StaticFlags.hs index c982d14b33..09d5772637 100644 --- a/compiler/main/StaticFlags.hs +++ b/compiler/main/StaticFlags.hs @@ -1,10 +1,3 @@ -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - {-# OPTIONS -fno-cse #-} -- -fno-cse is needed for GLOBAL_VAR's to behave properly @@ -23,27 +16,29 @@ module StaticFlags ( -- entry point parseStaticFlags, - staticFlags, + staticFlags, initStaticOpts, - -- Output style options - opt_PprStyle_Debug, + -- Output style options + opt_PprStyle_Debug, opt_NoDebugOutput, - -- language opts - opt_DictsStrict, + -- language opts + opt_DictsStrict, - -- optimisation opts - opt_NoStateHack, - opt_CprOff, - opt_NoOptCoercion, - opt_NoFlatCache, + -- optimisation opts + opt_NoStateHack, + opt_CprOff, + opt_NoOptCoercion, -- For the parser addOpt, removeOpt, v_opt_C_ready, -- Saving/restoring globals - saveStaticFlagGlobals, restoreStaticFlagGlobals + saveStaticFlagGlobals, restoreStaticFlagGlobals, + + -- For options autocompletion + flagsStatic, flagsStaticNames ) where #include "HsVersions.h" @@ -52,13 +47,13 @@ import CmdLineParser import FastString import SrcLoc import Util --- import Maybes ( firstJusts ) +-- import Maybes ( firstJusts ) import Panic import Control.Monad import Data.Char import Data.IORef -import System.IO.Unsafe ( unsafePerformIO ) +import System.IO.Unsafe ( unsafePerformIO ) ----------------------------------------------------------------------------- @@ -114,7 +109,7 @@ staticFlags = unsafePerformIO $ do -- All the static flags should appear in this list. It describes how each -- static flag should be processed. Two main purposes: -- (a) if a command-line flag doesn't appear in the list, GHC can complain --- (b) a command-line flag may remove, or add, other flags; e.g. the "-fno-X" +-- (b) a command-line flag may remove, or add, other flags; e.g. the "-fno-X" -- things -- -- The common (PassFlag addOpt) action puts the static flag into the bunch of @@ -147,18 +142,16 @@ flagsStatic = [ ] + isStaticFlag :: String -> Bool -isStaticFlag f = - f `elem` [ +isStaticFlag f = f `elem` flagsStaticNames + + +flagsStaticNames :: [String] +flagsStaticNames = [ "fdicts-strict", - "fspec-inline-join-points", - "fno-hi-version-check", - "dno-black-holing", "fno-state-hack", - "fruntime-types", "fno-opt-coercion", - "fno-flat-cache", - "fhardwire-lib-paths", "fcpr-off" ] @@ -198,10 +191,10 @@ opt_NoDebugOutput = lookUp (fsLit "-dno-debug-output") -- language opts opt_DictsStrict :: Bool -opt_DictsStrict = lookUp (fsLit "-fdicts-strict") +opt_DictsStrict = lookUp (fsLit "-fdicts-strict") opt_NoStateHack :: Bool -opt_NoStateHack = lookUp (fsLit "-fno-state-hack") +opt_NoStateHack = lookUp (fsLit "-fno-state-hack") -- Switch off CPR analysis in the new demand analyser opt_CprOff :: Bool @@ -210,9 +203,6 @@ opt_CprOff = lookUp (fsLit "-fcpr-off") opt_NoOptCoercion :: Bool opt_NoOptCoercion = lookUp (fsLit "-fno-opt-coercion") -opt_NoFlatCache :: Bool -opt_NoFlatCache = lookUp (fsLit "-fno-flat-cache") - ----------------------------------------------------------------------------- -- Convert sizes like "3.5M" into integers @@ -254,45 +244,28 @@ foreign import ccall unsafe "enableTimingStats" enableTimingStats :: IO () lookup_str :: String -> Maybe String lookup_str sw = case firstJusts (map (stripPrefix sw) staticFlags) of - Just ('=' : str) -> Just str - Just str -> Just str - Nothing -> Nothing + Just ('=' : str) -> Just str + Just str -> Just str + Nothing -> Nothing lookup_def_int :: String -> Int -> Int lookup_def_int sw def = case (lookup_str sw) of - Nothing -> def -- Use default - Just xx -> try_read sw xx + Nothing -> def -- Use default + Just xx -> try_read sw xx lookup_def_float :: String -> Float -> Float lookup_def_float sw def = case (lookup_str sw) of - Nothing -> def -- Use default - Just xx -> try_read sw xx + Nothing -> def -- Use default + Just xx -> try_read sw xx try_read :: Read a => String -> String -> a -- (try_read sw str) tries to read s; if it fails, it -- bleats about flag sw try_read sw str = case reads str of - ((x,_):_) -> x -- Be forgiving: ignore trailing goop, and alternative parses - [] -> throwGhcException (UsageError ("Malformed argument " ++ str ++ " for flag " ++ sw)) - -- ToDo: hack alert. We should really parse the arguments - -- and announce errors in a more civilised way. --} - - -{- - Putting the compiler options into temporary at-files - may turn out to be necessary later on if we turn hsc into - a pure Win32 application where I think there's a command-line - length limit of 255. unpacked_opts understands the @ option. - -unpacked_opts :: [String] -unpacked_opts = - concat $ - map (expandAts) $ - map unpackFS argv -- NOT ARGV any more: v_Static_hsc_opts - where - expandAts ('@':fname) = words (unsafePerformIO (readFile fname)) - expandAts l = [l] + ((x,_):_) -> x -- Be forgiving: ignore trailing goop, and alternative parses + [] -> throwGhcException (UsageError ("Malformed argument " ++ str ++ " for flag " ++ sw)) + -- ToDo: hack alert. We should really parse the arguments + -- and announce errors in a more civilised way. -} diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs index bacd53e937..d43826a046 100644 --- a/compiler/main/SysTools.lhs +++ b/compiler/main/SysTools.lhs @@ -24,6 +24,8 @@ module SysTools ( figureLlvmVersion, readElfSection, + getLinkerInfo, + linkDynLib, askCc, @@ -371,30 +373,35 @@ findTopDir Nothing \begin{code} runUnlit :: DynFlags -> [Option] -> IO () runUnlit dflags args = do - let p = pgm_L dflags - runSomething dflags "Literate pre-processor" p args + let prog = pgm_L dflags + opts = getOpts dflags opt_L + runSomething dflags "Literate pre-processor" prog + (map Option opts ++ args) runCpp :: DynFlags -> [Option] -> IO () runCpp dflags args = do let (p,args0) = pgm_P dflags - args1 = args0 ++ args + args1 = map Option (getOpts dflags opt_P) args2 = if gopt Opt_WarnIsError dflags - then Option "-Werror" : args1 - else args1 + then [Option "-Werror"] + else [] mb_env <- getGccEnv args2 - runSomethingFiltered dflags id "C pre-processor" p args2 mb_env + runSomethingFiltered dflags id "C pre-processor" p + (args0 ++ args1 ++ args2 ++ args) mb_env runPp :: DynFlags -> [Option] -> IO () runPp dflags args = do - let p = pgm_F dflags - runSomething dflags "Haskell pre-processor" p args + let prog = pgm_F dflags + opts = map Option (getOpts dflags opt_F) + runSomething dflags "Haskell pre-processor" prog (opts ++ args) runCc :: DynFlags -> [Option] -> IO () runCc dflags args = do let (p,args0) = pgm_c dflags - args1 = args0 ++ args - mb_env <- getGccEnv args1 - runSomethingFiltered dflags cc_filter "C Compiler" p args1 mb_env + args1 = map Option (getOpts dflags opt_c) + args2 = args0 ++ args1 ++ args + mb_env <- getGccEnv args2 + runSomethingFiltered dflags cc_filter "C Compiler" p args2 mb_env where -- discard some harmless warnings from gcc that we can't turn off cc_filter = unlines . doFilter . lines @@ -452,9 +459,10 @@ xs `isContainedIn` ys = any (xs `isPrefixOf`) (tails ys) askCc :: DynFlags -> [Option] -> IO String askCc dflags args = do let (p,args0) = pgm_c dflags - args1 = args0 ++ args - mb_env <- getGccEnv args1 - runSomethingWith dflags "gcc" p args1 $ \real_args -> + args1 = map Option (getOpts dflags opt_c) + args2 = args0 ++ args1 ++ args + mb_env <- getGccEnv args2 + runSomethingWith dflags "gcc" p args2 $ \real_args -> readCreateProcess (proc p real_args){ env = mb_env } -- Version of System.Process.readProcessWithExitCode that takes an environment @@ -507,21 +515,24 @@ runSplit dflags args = do runAs :: DynFlags -> [Option] -> IO () runAs dflags args = do let (p,args0) = pgm_a dflags - args1 = args0 ++ args - mb_env <- getGccEnv args1 - runSomethingFiltered dflags id "Assembler" p args1 mb_env + args1 = map Option (getOpts dflags opt_a) + args2 = args0 ++ args1 ++ args + mb_env <- getGccEnv args2 + runSomethingFiltered dflags id "Assembler" p args2 mb_env -- | Run the LLVM Optimiser runLlvmOpt :: DynFlags -> [Option] -> IO () runLlvmOpt dflags args = do let (p,args0) = pgm_lo dflags - runSomething dflags "LLVM Optimiser" p (args0++args) + args1 = map Option (getOpts dflags opt_lo) + runSomething dflags "LLVM Optimiser" p (args0 ++ args1 ++ args) -- | Run the LLVM Compiler runLlvmLlc :: DynFlags -> [Option] -> IO () runLlvmLlc dflags args = do let (p,args0) = pgm_lc dflags - runSomething dflags "LLVM Compiler" p (args0++args) + args1 = map Option (getOpts dflags opt_lc) + runSomething dflags "LLVM Compiler" p (args0 ++ args1 ++ args) -- | Run the clang compiler (used as an assembler for the LLVM -- backend on OS X as LLVM doesn't support the OS X system @@ -533,10 +544,11 @@ runClang dflags args = do -- be careful what options we call clang with -- see #5903 and #7617 for bugs caused by this. (_,args0) = pgm_a dflags - args1 = args0 ++ args - mb_env <- getGccEnv args1 + args1 = map Option (getOpts dflags opt_a) + args2 = args0 ++ args1 ++ args + mb_env <- getGccEnv args2 Exception.catch (do - runSomethingFiltered dflags id "Clang (Assembler)" clang args1 mb_env + runSomethingFiltered dflags id "Clang (Assembler)" clang args2 mb_env ) (\(err :: SomeException) -> do errorMsg dflags $ @@ -586,14 +598,124 @@ figureLlvmVersion dflags = do text "Make sure you have installed LLVM"] return Nothing) return ver - + + +{- Note [Run-time linker info] + +See also: Trac #5240, Trac #6063 + +Before 'runLink', we need to be sure to get the relevant information +about the linker we're using at runtime to see if we need any extra +options. For example, GNU ld requires '--reduce-memory-overheads' and +'--hash-size=31' in order to use reasonable amounts of memory (see +trac #5240.) But this isn't supported in GNU gold. + +Generally, the linker changing from what was detected at ./configure +time has always been possible using -pgml, but on Linux it can happen +'transparently' by installing packages like binutils-gold, which +change what /usr/bin/ld actually points to. + +Clang vs GCC notes: + +For gcc, 'gcc -Wl,--version' gives a bunch of output about how to +invoke the linker before the version information string. For 'clang', +the version information for 'ld' is all that's output. For this +reason, we typically need to slurp up all of the standard error output +and look through it. + +Other notes: + +We cache the LinkerInfo inside DynFlags, since clients may link +multiple times. The definition of LinkerInfo is there to avoid a +circular dependency. + +-} + + +neededLinkArgs :: LinkerInfo -> [Option] +neededLinkArgs (GnuLD o) = o +neededLinkArgs (GnuGold o) = o +neededLinkArgs (DarwinLD o) = o +neededLinkArgs UnknownLD = [] + +-- Grab linker info and cache it in DynFlags. +getLinkerInfo :: DynFlags -> IO LinkerInfo +getLinkerInfo dflags = do + info <- readIORef (rtldFlags dflags) + case info of + Just v -> return v + Nothing -> do + v <- getLinkerInfo' dflags + writeIORef (rtldFlags dflags) (Just v) + return v + +-- See Note [Run-time linker info]. +getLinkerInfo' :: DynFlags -> IO LinkerInfo +getLinkerInfo' dflags = do + let platform = targetPlatform dflags + os = platformOS platform + (pgm,_) = pgm_l dflags + + -- Try to grab the info from the process output. + parseLinkerInfo stdo _stde _exitc + | any ("GNU ld" `isPrefixOf`) stdo = + -- GNU ld specifically needs to use less memory. This especially + -- hurts on small object files. Trac #5240. + return (GnuLD $ map Option ["-Wl,--hash-size=31", + "-Wl,--reduce-memory-overheads"]) + + | any ("GNU gold" `isPrefixOf`) stdo = + -- GNU gold does not require any special arguments. + return (GnuGold []) + + -- Unknown linker. + | otherwise = fail "invalid --version output, or linker is unsupported" + + -- Process the executable call + info <- catchIO (do + case os of + OSDarwin -> + -- Darwin has neither GNU Gold or GNU LD, but a strange linker + -- that doesn't support --version. We can just assume that's + -- what we're using. + return $ DarwinLD [] + OSMinGW32 -> + -- GHC doesn't support anything but GNU ld on Windows anyway. + -- Process creation is also fairly expensive on win32, so + -- we short-circuit here. + return $ GnuLD $ map Option ["-Wl,--hash-size=31", + "-Wl,--reduce-memory-overheads"] + _ -> do + -- In practice, we use the compiler as the linker here. Pass + -- -Wl,--version to get linker version info. + (exitc, stdo, stde) <- readProcessWithExitCode pgm + ["-Wl,--version"] "" + -- Split the output by lines to make certain kinds + -- of processing easier. In particular, 'clang' and 'gcc' + -- have slightly different outputs for '-Wl,--version', but + -- it's still easy to figure out. + parseLinkerInfo (lines stdo) (lines stde) exitc + ) + (\err -> do + debugTraceMsg dflags 2 + (text "Error (figuring out linker information):" <+> + text (show err)) + errorMsg dflags $ hang (text "Warning:") 9 $ + text "Couldn't figure out linker information!" $$ + text "Make sure you're using GNU ld, GNU gold" <+> + text "or the built in OS X linker, etc." + return UnknownLD) + return info runLink :: DynFlags -> [Option] -> IO () runLink dflags args = do + -- See Note [Run-time linker info] + linkargs <- neededLinkArgs `fmap` getLinkerInfo dflags let (p,args0) = pgm_l dflags - args1 = args0 ++ args - mb_env <- getGccEnv args1 - runSomethingFiltered dflags id "Linker" p args1 mb_env + args1 = map Option (getOpts dflags opt_l) + args2 = args0 ++ args1 ++ args ++ linkargs + mb_env <- getGccEnv args2 + runSomethingFiltered dflags id "Linker" p args2 mb_env runMkDLL :: DynFlags -> [Option] -> IO () runMkDLL dflags args = do @@ -606,6 +728,7 @@ runWindres :: DynFlags -> [Option] -> IO () runWindres dflags args = do let (gcc, gcc_args) = pgm_c dflags windres = pgm_windres dflags + opts = map Option (getOpts dflags opt_windres) quote x = "\"" ++ x ++ "\"" args' = -- If windres.exe and gcc.exe are in a directory containing -- spaces then windres fails to run gcc. We therefore need @@ -613,6 +736,7 @@ runWindres dflags args = do Option ("--preprocessor=" ++ unwords (map quote (gcc : map showOpt gcc_args ++ + map showOpt opts ++ ["-E", "-xc", "-DRC_INVOKED"]))) -- ...but if we do that then if windres calls popen then -- it can't understand the quoting, so we have to use @@ -1051,10 +1175,22 @@ linesPlatform xs = #endif linkDynLib :: DynFlags -> [String] -> [PackageId] -> IO () -linkDynLib dflags o_files dep_packages +linkDynLib dflags0 o_files dep_packages = do - let verbFlags = getVerbFlags dflags - let o_file = outputFile dflags + let -- This is a rather ugly hack to fix dynamically linked + -- GHC on Windows. If GHC is linked with -threaded, then + -- it links against libHSrts_thr. But if base is linked + -- against libHSrts, then both end up getting loaded, + -- and things go wrong. We therefore link the libraries + -- with the same RTS flags that we link GHC with. + dflags1 = if cGhcThreaded then addWay' WayThreaded dflags0 + else dflags0 + dflags2 = if cGhcDebugged then addWay' WayDebug dflags1 + else dflags1 + dflags = updateWays dflags2 + + verbFlags = getVerbFlags dflags + o_file = outputFile dflags pkgs <- getPreloadPackagesAnd dflags dep_packages @@ -1089,8 +1225,6 @@ linkDynLib dflags o_files dep_packages -- probably _stub.o files let extra_ld_inputs = ldInputs dflags - let extra_ld_opts = getOpts dflags opt_l - case os of OSMinGW32 -> do ------------------------------------------------------------- @@ -1110,15 +1244,14 @@ linkDynLib dflags o_files dep_packages | gopt Opt_SharedImplib dflags ] ++ map (FileOption "") o_files - ++ map Option ( -- Permit the linker to auto link _symbol to _imp_symbol -- This lets us link against DLLs without needing an "import library" - ["-Wl,--enable-auto-import"] + ++ [Option "-Wl,--enable-auto-import"] ++ extra_ld_inputs - ++ lib_path_opts - ++ extra_ld_opts + ++ map Option ( + lib_path_opts ++ pkg_lib_path_opts ++ pkg_link_opts )) @@ -1169,19 +1302,19 @@ linkDynLib dflags o_files dep_packages , Option "-o" , FileOption "" output_fn ] - ++ map Option ( - o_files - ++ [ "-undefined", "dynamic_lookup", "-single_module" ] + ++ map Option o_files + ++ [ Option "-undefined", + Option "dynamic_lookup", + Option "-single_module" ] ++ (if platformArch platform == ArchX86_64 then [ ] - else [ "-Wl,-read_only_relocs,suppress" ]) - ++ [ "-install_name", instName ] + else [ Option "-Wl,-read_only_relocs,suppress" ]) + ++ [ Option "-install_name", Option instName ] + ++ map Option lib_path_opts ++ extra_ld_inputs - ++ lib_path_opts - ++ extra_ld_opts - ++ pkg_lib_path_opts - ++ pkg_link_opts - )) + ++ map Option pkg_lib_path_opts + ++ map Option pkg_link_opts + ) _ -> do ------------------------------------------------------------------- -- Making a DSO @@ -1202,18 +1335,15 @@ linkDynLib dflags o_files dep_packages ++ [ Option "-o" , FileOption "" output_fn ] - ++ map Option ( - o_files - ++ [ "-shared" ] - ++ bsymbolicFlag + ++ map Option o_files + ++ [ Option "-shared" ] + ++ map Option bsymbolicFlag -- Set the library soname. We use -h rather than -soname as -- Solaris 10 doesn't support the latter: - ++ [ "-Wl,-h," ++ takeFileName output_fn ] + ++ [ Option ("-Wl,-h," ++ takeFileName output_fn) ] + ++ map Option lib_path_opts ++ extra_ld_inputs - ++ lib_path_opts - ++ extra_ld_opts - ++ pkg_lib_path_opts - ++ pkg_link_opts - )) - + ++ map Option pkg_lib_path_opts + ++ map Option pkg_link_opts + ) \end{code} diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index 8d152d78fe..7b3695dbed 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -36,7 +36,6 @@ import Name hiding (varName) import NameSet import NameEnv import Avail -import PrelNames import IfaceEnv import TcEnv import TcRnMonad @@ -153,7 +152,7 @@ mkBootModDetailsTc hsc_env } where -mkBootTypeEnv :: NameSet -> [Id] -> [TyCon] -> [FamInst Branched] -> TypeEnv +mkBootTypeEnv :: NameSet -> [Id] -> [TyCon] -> [FamInst] -> TypeEnv mkBootTypeEnv exports ids tcs fam_insts = tidyTypeEnv True $ typeEnvFromEntities final_ids tcs fam_insts @@ -328,7 +327,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod -- See Note [Which rules to expose] ; (tidy_env, tidy_binds) - <- tidyTopBinds hsc_env unfold_env tidy_occ_env binds + <- tidyTopBinds hsc_env mod unfold_env tidy_occ_env binds ; let { final_ids = [ id | id <- bindersOfBinds tidy_binds, isExternalName (idName id)] @@ -818,7 +817,8 @@ dffvLetBndr vanilla_unfold id | otherwise -> return () _ -> dffvExpr rhs - go_unf (DFunUnfolding _ _ args) = mapM_ dffvExpr (dfunArgExprs args) + go_unf (DFunUnfolding { df_bndrs = bndrs, df_args = args }) + = extendScopeList bndrs $ mapM_ dffvExpr args go_unf _ = return () go_rule (BuiltinRule {}) = return () @@ -974,14 +974,14 @@ rules are externalised (see init_ext_ids in function -- * subst_env: A Var->Var mapping that substitutes the new Var for the old tidyTopBinds :: HscEnv + -> Module -> UnfoldEnv -> TidyOccEnv -> CoreProgram -> IO (TidyEnv, CoreProgram) -tidyTopBinds hsc_env unfold_env init_occ_env binds - = do mkIntegerId <- liftM tyThingId - $ initTcForLookup hsc_env (tcLookupGlobal mkIntegerName) +tidyTopBinds hsc_env this_mod unfold_env init_occ_env binds + = do mkIntegerId <- lookupMkIntegerName dflags hsc_env return $ tidy mkIntegerId init_env binds where dflags = hsc_dflags hsc_env @@ -991,7 +991,7 @@ tidyTopBinds hsc_env unfold_env init_occ_env binds this_pkg = thisPackage dflags tidy _ env [] = (env, []) - tidy mkIntegerId env (b:bs) = let (env1, b') = tidyTopBind dflags this_pkg mkIntegerId unfold_env env b + tidy mkIntegerId env (b:bs) = let (env1, b') = tidyTopBind dflags this_pkg this_mod mkIntegerId unfold_env env b (env2, bs') = tidy mkIntegerId env1 bs in (env2, b':bs') @@ -999,22 +999,23 @@ tidyTopBinds hsc_env unfold_env init_occ_env binds ------------------------ tidyTopBind :: DynFlags -> PackageId + -> Module -> Id -> UnfoldEnv -> TidyEnv -> CoreBind -> (TidyEnv, CoreBind) -tidyTopBind dflags this_pkg mkIntegerId unfold_env (occ_env,subst1) (NonRec bndr rhs) +tidyTopBind dflags this_pkg this_mod 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 dflags this_pkg (mkIntegerId, subst1) (idArity bndr) rhs + caf_info = hasCafRefs dflags this_pkg this_mod (mkIntegerId, subst1) (idArity bndr) rhs (bndr', rhs') = tidyTopPair dflags show_unfold tidy_env2 caf_info name' (bndr, rhs) subst2 = extendVarEnv subst1 bndr bndr' tidy_env2 = (occ_env, subst2) -tidyTopBind dflags this_pkg mkIntegerId unfold_env (occ_env,subst1) (Rec prs) +tidyTopBind dflags this_pkg this_mod mkIntegerId unfold_env (occ_env,subst1) (Rec prs) = (tidy_env2, Rec prs') where prs' = [ tidyTopPair dflags show_unfold tidy_env2 caf_info name' (id,rhs) @@ -1031,7 +1032,7 @@ tidyTopBind dflags 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 dflags this_pkg (mkIntegerId, subst1) (idArity bndr) rhs) + | or [ mayHaveCafRefs (hasCafRefs dflags this_pkg this_mod (mkIntegerId, subst1) (idArity bndr) rhs) | (bndr,rhs) <- prs ] = MayHaveCafRefs | otherwise = NoCafRefs @@ -1167,14 +1168,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 :: DynFlags -> PackageId -> (Id, VarEnv Var) -> Arity -> CoreExpr +hasCafRefs :: DynFlags -> PackageId -> Module + -> (Id, VarEnv Var) -> Arity -> CoreExpr -> CafInfo -hasCafRefs dflags this_pkg p arity expr +hasCafRefs dflags this_pkg this_mod p arity expr | is_caf || mentions_cafs = MayHaveCafRefs | otherwise = NoCafRefs where mentions_cafs = isFastTrue (cafRefsE dflags p expr) - is_dynamic_name = isDllName dflags this_pkg + is_dynamic_name = isDllName dflags this_pkg this_mod is_caf = not (arity > 0 || rhsIsStatic (targetPlatform dflags) is_dynamic_name expr) -- NB. we pass in the arity of the expression, which is expected |