diff options
Diffstat (limited to 'compiler/main')
| -rw-r--r-- | compiler/main/DriverPipeline.hs | 97 | ||||
| -rw-r--r-- | compiler/main/DynFlags.hs | 32 | ||||
| -rw-r--r-- | compiler/main/GhcMake.hs | 2 | ||||
| -rw-r--r-- | compiler/main/GhcMonad.hs | 8 | ||||
| -rw-r--r-- | compiler/main/HscTypes.lhs | 34 | ||||
| -rw-r--r-- | compiler/main/Packages.lhs | 17 | ||||
| -rw-r--r-- | compiler/main/SysTools.lhs | 17 | ||||
| -rw-r--r-- | compiler/main/TidyPgm.lhs | 5 |
8 files changed, 145 insertions, 67 deletions
diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index c5bcdc7a65..8fc44ed81f 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -295,6 +295,9 @@ link NoLink _ _ _ link LinkBinary dflags batch_attempt_linking hpt = link' dflags batch_attempt_linking hpt +link LinkStaticLib dflags batch_attempt_linking hpt + = link' dflags batch_attempt_linking hpt + link LinkDynLib dflags batch_attempt_linking hpt = link' dflags batch_attempt_linking hpt @@ -311,6 +314,10 @@ link' dflags batch_attempt_linking hpt | batch_attempt_linking = do let + staticLink = case ghcLink dflags of + LinkStaticLib -> True + _ -> platformBinariesAreStaticLibs (targetPlatform dflags) + home_mod_infos = eltsUFM hpt -- the packages we depend on @@ -330,9 +337,9 @@ link' dflags batch_attempt_linking hpt let getOfiles (LM _ _ us) = map nameOfObject (filter isObject us) obj_files = concatMap getOfiles linkables - exe_file = exeFileName dflags + exe_file = exeFileName staticLink dflags - linking_needed <- linkingNeeded dflags linkables pkg_deps + linking_needed <- linkingNeeded dflags staticLink linkables pkg_deps if not (gopt Opt_ForceRecomp dflags) && not linking_needed then do debugTraceMsg dflags 2 (text exe_file <+> ptext (sLit "is up to date, linking not required.")) @@ -343,9 +350,10 @@ link' dflags batch_attempt_linking hpt -- Don't showPass in Batch mode; doLink will do that for us. let link = case ghcLink dflags of - LinkBinary -> linkBinary - LinkDynLib -> linkDynLibCheck - other -> panicBadLink other + LinkBinary -> linkBinary + LinkStaticLib -> linkStaticLibCheck + LinkDynLib -> linkDynLibCheck + other -> panicBadLink other link dflags obj_files pkg_deps debugTraceMsg dflags 3 (text "link: done") @@ -359,12 +367,12 @@ link' dflags batch_attempt_linking hpt return Succeeded -linkingNeeded :: DynFlags -> [Linkable] -> [PackageId] -> IO Bool -linkingNeeded dflags linkables pkg_deps = do +linkingNeeded :: DynFlags -> Bool -> [Linkable] -> [PackageId] -> IO Bool +linkingNeeded dflags staticLink linkables pkg_deps = do -- if the modification time on the executable is later than the -- modification times on all of the objects and libraries, then omit -- linking (unless the -fforce-recomp flag was given). - let exe_file = exeFileName dflags + let exe_file = exeFileName staticLink dflags e_exe_time <- tryIO $ getModificationUTCTime exe_file case e_exe_time of Left _ -> return True @@ -482,10 +490,11 @@ doLink dflags stop_phase o_files | otherwise = case ghcLink dflags of - NoLink -> return () - LinkBinary -> linkBinary dflags o_files [] - LinkDynLib -> linkDynLibCheck dflags o_files [] - other -> panicBadLink other + NoLink -> return () + LinkBinary -> linkBinary dflags o_files [] + LinkStaticLib -> linkStaticLibCheck dflags o_files [] + LinkDynLib -> linkDynLibCheck dflags o_files [] + other -> panicBadLink other -- --------------------------------------------------------------------------- @@ -1116,8 +1125,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 @@ -1187,7 +1197,8 @@ 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 ++ split_opt @@ -1768,11 +1779,14 @@ getHCFilePackages filename = -- the packages. linkBinary :: DynFlags -> [FilePath] -> [PackageId] -> IO () -linkBinary dflags o_files dep_packages = do +linkBinary = linkBinary' False + +linkBinary' :: Bool -> DynFlags -> [FilePath] -> [PackageId] -> IO () +linkBinary' staticLink dflags o_files dep_packages = do let platform = targetPlatform dflags mySettings = settings dflags verbFlags = getVerbFlags dflags - output_fn = exeFileName dflags + output_fn = exeFileName staticLink dflags -- get the full list of packages to link with, by combining the -- explicit packages with the auto packages and all of their @@ -1813,13 +1827,15 @@ linkBinary dflags o_files dep_packages = do extraLinkObj <- mkExtraObjToLinkIntoBinary dflags noteLinkObjs <- mkNoteObjsToLinkIntoBinary 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_link_opts <- do + (package_hs_libs, extra_libs, other_flags) <- getPackageLinkOpts dflags dep_packages + return $ if staticLink + then package_hs_libs -- If building an executable really means making a static + -- library (e.g. iOS), then we only keep the -l options for + -- HS packages, because libtool doesn't accept other options. + -- In the case of iOS these need to be added by hand to the + -- final link in Xcode. + else package_hs_libs ++ extra_libs ++ other_flags pkg_framework_path_opts <- if platformUsesFrameworks platform @@ -1867,14 +1883,17 @@ linkBinary dflags o_files dep_packages = do let os = platformOS (targetPlatform dflags) in if os == OSOsf3 then ["-lpthread", "-lexc"] else if os `elem` [OSMinGW32, OSFreeBSD, OSOpenBSD, - OSNetBSD, OSHaiku, OSQNXNTO] + OSNetBSD, OSHaiku, OSQNXNTO, OSiOS] then [] else ["-lpthread"] | otherwise = [] rc_objs <- maybeCreateManifest dflags output_fn - SysTools.runLink dflags ( + let link = if staticLink + then SysTools.runLibtool + else SysTools.runLink + link dflags ( map SysTools.Option verbFlags ++ [ SysTools.Option "-o" , SysTools.FileOption "" output_fn @@ -1897,6 +1916,7 @@ linkBinary dflags o_files dep_packages = do -- ld: warning: could not create compact unwind for .LFB3: non-standard register 5 being saved in prolog -- on x86. ++ (if sLdSupportsCompactUnwind mySettings && + not staticLink && platformOS platform == OSDarwin && platformArch platform `elem` [ArchX86, ArchX86_64] then ["-Wl,-no_compact_unwind"] @@ -1909,7 +1929,8 @@ linkBinary dflags o_files dep_packages = do -- whether this is something we ought to fix, but -- for now this flags silences them. ++ (if platformOS platform == OSDarwin && - platformArch platform == ArchX86 + platformArch platform == ArchX86 && + not staticLink then ["-Wl,-read_only_relocs,suppress"] else []) @@ -1935,17 +1956,20 @@ linkBinary dflags o_files dep_packages = do throwGhcExceptionIO (InstallationError ("cannot move binary")) -exeFileName :: DynFlags -> FilePath -exeFileName dflags +exeFileName :: Bool -> DynFlags -> FilePath +exeFileName staticLink dflags | Just s <- outputFile dflags = - case platformOS (targetPlatform dflags) of + case platformOS (targetPlatform dflags) of OSMinGW32 -> s <?.> "exe" - OSiOS -> s <?.> "a" - _ -> s + _ -> if staticLink + then s <?.> "a" + else s | otherwise = if platformOS (targetPlatform dflags) == OSMinGW32 then "main.exe" - else "a.out" + else if staticLink + then "liba.a" + else "a.out" where s <?.> ext | null (takeExtension s) = s <.> ext | otherwise = s @@ -2012,6 +2036,13 @@ linkDynLibCheck dflags o_files dep_packages linkDynLib dflags o_files dep_packages +linkStaticLibCheck :: DynFlags -> [String] -> [PackageId] -> IO () +linkStaticLibCheck dflags o_files dep_packages + = do + when (platformOS (targetPlatform dflags) `notElem` [OSiOS, OSDarwin]) $ + throwGhcExceptionIO (ProgramError "Static archive creation only supported on Darwin/OS X/iOS") + linkBinary' True dflags o_files dep_packages + -- ----------------------------------------------------------------------------- -- Running CPP diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 64ec8be612..e80cf656d3 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -66,7 +66,7 @@ module DynFlags ( ghcUsagePath, ghciUsagePath, topDir, tmpDir, rawSettings, extraGccViaCFlags, systemPackageConfig, pgm_L, pgm_P, pgm_F, pgm_c, pgm_s, pgm_a, pgm_l, pgm_dll, pgm_T, - pgm_sysman, pgm_windres, pgm_lo, pgm_lc, + pgm_sysman, pgm_windres, pgm_libtool, pgm_lo, pgm_lc, opt_L, opt_P, opt_F, opt_c, opt_a, opt_l, opt_windres, opt_lo, opt_lc, @@ -101,6 +101,7 @@ module DynFlags ( flagsPackage, supportedLanguagesAndExtensions, + languageExtensions, -- ** DynFlags C compiler options picCCOpts, picPOpts, @@ -277,6 +278,7 @@ data GeneralFlag -- optimisation opts | Opt_Strictness + | Opt_LateDmdAnal | Opt_KillAbsence | Opt_KillOneShot | Opt_FullLaziness @@ -500,6 +502,7 @@ data ExtensionFlag | Opt_TypeFamilies | Opt_OverloadedStrings | Opt_OverloadedLists + | Opt_NumDecimals | Opt_DisambiguateRecordFields | Opt_RecordWildCards | Opt_RecordPuns @@ -513,7 +516,7 @@ data ExtensionFlag | Opt_PolyKinds -- Kind polymorphism | Opt_DataKinds -- Datatype promotion | Opt_InstanceSigs - + | Opt_StandaloneDeriving | Opt_DeriveDataTypeable | Opt_AutoDeriveTypeable -- Automatic derivation of Typeable @@ -579,6 +582,8 @@ data DynFlags = DynFlags { ruleCheck :: Maybe String, strictnessBefore :: [Int], -- ^ Additional demand analysis + maxRelevantBinds :: Maybe Int, -- ^ Maximum number of bindings from the type envt + -- to show in type error messages simplTickFactor :: Int, -- ^ Multiplier for simplifier ticks specConstrThreshold :: Maybe Int, -- ^ Threshold for SpecConstr specConstrCount :: Maybe Int, -- ^ Max number of specialisations for any one function @@ -587,6 +592,7 @@ data DynFlags = DynFlags { liberateCaseThreshold :: Maybe Int, -- ^ Threshold for LiberateCase floatLamArgs :: Maybe Int, -- ^ Arg count for lambda floating -- See CoreMonad.FloatOutSwitches + historySize :: Int, cmdlineHcIncludes :: [String], -- ^ @\-\#includes@ @@ -798,6 +804,7 @@ data Settings = Settings { sPgm_T :: String, sPgm_sysman :: String, sPgm_windres :: String, + sPgm_libtool :: String, sPgm_lo :: (String,[Option]), -- LLVM: opt llvm optimiser sPgm_lc :: (String,[Option]), -- LLVM: llc static compiler -- options for particular phases @@ -853,6 +860,8 @@ pgm_sysman :: DynFlags -> String pgm_sysman dflags = sPgm_sysman (settings dflags) pgm_windres :: DynFlags -> String pgm_windres dflags = sPgm_windres (settings dflags) +pgm_libtool :: DynFlags -> String +pgm_libtool dflags = sPgm_libtool (settings dflags) pgm_lo :: DynFlags -> (String,[Option]) pgm_lo dflags = sPgm_lo (settings dflags) pgm_lc :: DynFlags -> (String,[Option]) @@ -948,6 +957,7 @@ data GhcLink | LinkInMemory -- ^ Use the in-memory dynamic linker (works for both -- bytecode and object code). | LinkDynLib -- ^ Link objects into a dynamic lib (DLL on Windows, DSO on ELF platforms) + | LinkStaticLib -- ^ Link objects into a static lib deriving (Eq, Show) isNoLink :: GhcLink -> Bool @@ -1242,12 +1252,14 @@ defaultDynFlags mySettings = maxSimplIterations = 4, shouldDumpSimplPhase = Nothing, ruleCheck = Nothing, + maxRelevantBinds = Just 6, simplTickFactor = 100, specConstrThreshold = Just 2000, specConstrCount = Just 3, specConstrRecursive = 3, liberateCaseThreshold = Just 2000, floatLamArgs = Just 0, -- Default: float only if no fvs + historySize = 20, strictnessBefore = [], @@ -1671,7 +1683,7 @@ setObjectDir, setHiDir, setStubDir, setDumpDir, setOutputDir, setDylibInstallName, setObjectSuf, setHiSuf, setHcSuf, parseDynLibLoaderMode, setPgmP, addOptl, addOptc, addOptP, - addCmdlineFramework, addHaddockOpts, addGhciScript, + addCmdlineFramework, addHaddockOpts, addGhciScript, setInteractivePrint :: String -> DynFlags -> DynFlags setOutputFile, setDynOutputFile, setOutputHi, setDumpPrefixForce @@ -1956,7 +1968,7 @@ safeFlagCheck cmdl dflags = apFix f = if safeInferOn dflags then id else f - safeFailure loc str + safeFailure loc str = [L loc $ str ++ " is not allowed in Safe Haskell; ignoring " ++ str] {- ********************************************************************** @@ -2044,6 +2056,7 @@ dynamic_flags = [ , Flag "pgml" (hasArg (\f -> alterSettings (\s -> s { sPgm_l = (f,[])}))) , Flag "pgmdll" (hasArg (\f -> alterSettings (\s -> s { sPgm_dll = (f,[])}))) , Flag "pgmwindres" (hasArg (\f -> alterSettings (\s -> s { sPgm_windres = f}))) + , Flag "pgmlibtool" (hasArg (\f -> alterSettings (\s -> s { sPgm_libtool = f}))) -- need to appear before -optl/-opta to be parsed as LLVM flags. , Flag "optlo" (hasArg (\f -> alterSettings (\s -> s { sOpt_lo = f : sOpt_lo s}))) @@ -2078,6 +2091,7 @@ dynamic_flags = [ -------- Linking ---------------------------------------------------- , Flag "no-link" (noArg (\d -> d{ ghcLink=NoLink })) , Flag "shared" (noArg (\d -> d{ ghcLink=LinkDynLib })) + , Flag "staticlib" (noArg (\d -> d{ ghcLink=LinkStaticLib })) , Flag "dynload" (hasArg parseDynLibLoaderMode) , Flag "dylib-install-name" (hasArg setDylibInstallName) -- -dll-split is an internal flag, used only during the GHC build @@ -2281,6 +2295,9 @@ dynamic_flags = [ , Flag "O" (optIntSuffixM (\mb_n -> setOptLevel (mb_n `orElse` 1))) -- If the number is missing, use 1 + + , Flag "fmax-relevant-binds" (intSuffix (\n d -> d{ maxRelevantBinds = Just n })) + , Flag "fno-max-relevant-binds" (noArg (\d -> d{ maxRelevantBinds = Nothing })) , Flag "fsimplifier-phases" (intSuffix (\n d -> d{ simplPhases = n })) , Flag "fmax-simplifier-iterations" (intSuffix (\n d -> d{ maxSimplIterations = n })) , Flag "fsimpl-tick-factor" (intSuffix (\n d -> d{ simplTickFactor = n })) @@ -2296,6 +2313,7 @@ dynamic_flags = [ , Flag "fstrictness-before" (intSuffix (\n d -> d{ strictnessBefore = n : strictnessBefore d })) , Flag "ffloat-lam-args" (intSuffix (\n d -> d{ floatLamArgs = Just n })) , Flag "ffloat-all-lams" (noArg (\d -> d{ floatLamArgs = Nothing })) + , Flag "fhistory-size" (intSuffix (\n d -> d{ historySize = n })) , Flag "funfolding-creation-threshold" (intSuffix (\n d -> d {ufCreationThreshold = n})) @@ -2500,6 +2518,7 @@ fFlags = [ ( "error-spans", Opt_ErrorSpans, nop ), ( "print-explicit-foralls", Opt_PrintExplicitForalls, nop ), ( "strictness", Opt_Strictness, nop ), + ( "late-dmd-anal", Opt_LateDmdAnal, nop ), ( "specialise", Opt_Specialise, nop ), ( "float-in", Opt_FloatIn, nop ), ( "static-argument-transformation", Opt_StaticArgumentTransformation, nop ), @@ -2566,7 +2585,7 @@ fFlags = [ fLangFlags :: [FlagSpec ExtensionFlag] fLangFlags = [ ( "th", Opt_TemplateHaskell, - \on -> deprecatedForExtension "TemplateHaskell" on + \on -> deprecatedForExtension "TemplateHaskell" on >> checkTemplateHaskellOk on ), ( "fi", Opt_ForeignFunctionInterface, deprecatedForExtension "ForeignFunctionInterface" ), @@ -2658,7 +2677,7 @@ xFlags = [ ( "TypeOperators", Opt_TypeOperators, nop ), ( "ExplicitNamespaces", Opt_ExplicitNamespaces, nop ), ( "RecursiveDo", Opt_RecursiveDo, nop ), -- Enables 'mdo' and 'rec' - ( "DoRec", Opt_RecursiveDo, + ( "DoRec", Opt_RecursiveDo, deprecatedForExtension "RecursiveDo" ), ( "Arrows", Opt_Arrows, nop ), ( "ParallelArrays", Opt_ParallelArrays, nop ), @@ -2671,6 +2690,7 @@ xFlags = [ deprecatedForExtension "NamedFieldPuns" ), ( "DisambiguateRecordFields", Opt_DisambiguateRecordFields, nop ), ( "OverloadedStrings", Opt_OverloadedStrings, nop ), + ( "NumDecimals", Opt_NumDecimals, nop), ( "OverloadedLists", Opt_OverloadedLists, nop), ( "GADTs", Opt_GADTs, nop ), ( "GADTSyntax", Opt_GADTSyntax, nop ), diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs index c43b18a62a..8a14a0c132 100644 --- a/compiler/main/GhcMake.hs +++ b/compiler/main/GhcMake.hs @@ -294,7 +294,7 @@ load how_much = do let main_mod = mainModIs dflags a_root_is_Main = any ((==main_mod).ms_mod) mod_graph - do_linking = a_root_is_Main || no_hs_main || ghcLink dflags == LinkDynLib + do_linking = a_root_is_Main || no_hs_main || ghcLink dflags == LinkDynLib || ghcLink dflags == LinkStaticLib when (ghcLink dflags == LinkBinary && isJust ofile && not do_linking) $ diff --git a/compiler/main/GhcMonad.hs b/compiler/main/GhcMonad.hs index 66034e0b50..68b4e2b2a2 100644 --- a/compiler/main/GhcMonad.hs +++ b/compiler/main/GhcMonad.hs @@ -97,6 +97,10 @@ data Session = Session !(IORef HscEnv) instance Functor Ghc where fmap f m = Ghc $ \s -> f `fmap` unGhc m s +instance Applicative Ghc where + pure = return + g <*> m = do f <- g; a <- m; return (f a) + instance Monad Ghc where return a = Ghc $ \_ -> return a m >>= g = Ghc $ \s -> do a <- unGhc m s; unGhc (g a) s @@ -157,6 +161,10 @@ liftGhcT m = GhcT $ \_ -> m instance Functor m => Functor (GhcT m) where fmap f m = GhcT $ \s -> f `fmap` unGhcT m s +instance Applicative m => Applicative (GhcT m) where + pure x = GhcT $ \_ -> pure x + g <*> m = GhcT $ \s -> unGhcT g s <*> unGhcT m s + instance Monad m => Monad (GhcT m) where return x = GhcT $ \_ -> return x m >>= k = GhcT $ \s -> do a <- unGhcT m s; unGhcT (k a) s diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index e022ae3eae..33dbba2c21 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -931,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], + 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 @@ -1071,7 +1071,7 @@ data InteractiveContext ic_fix_env :: FixityEnv, -- ^ Fixities declared in let statements - + ic_int_print :: Name, -- ^ The function that is used for printing results -- of expressions in ghci and -e mode. @@ -1534,7 +1534,7 @@ lookupType dflags hpt pte name return x | otherwise = lookupNameEnv pte name - where + where mod = ASSERT2( isExternalName name, ppr name ) nameModule name this_pkg = thisPackage dflags @@ -1794,10 +1794,19 @@ data Usage usg_safe :: IsSafeImport -- ^ Was this module imported as a safe import } -- ^ Module from the current package + -- | A file upon which the module depends, e.g. a CPP #include, or using TH's + -- 'addDependentFile' | UsageFile { usg_file_path :: FilePath, - usg_mtime :: UTCTime - -- ^ External file dependency. From a CPP #include or TH addDependentFile. Should be absolute. + -- ^ External file dependency. From a CPP #include or TH + -- addDependentFile. Should be absolute. + usg_file_hash :: Fingerprint + -- ^ 'Fingerprint' of the file contents. + + -- Note: We don't consider things like modification timestamps + -- here, because there's no reason to recompile if the actual + -- contents don't change. This previously lead to odd + -- recompilation behaviors; see #8114 } deriving( Eq ) -- The export list field is (Just v) if we depend on the export list: @@ -1814,13 +1823,13 @@ data Usage -- depend on their export lists instance Binary Usage where - put_ bh usg@UsagePackageModule{} = do + 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 + put_ bh usg@UsageHomeModule{} = do putByte bh 1 put_ bh (usg_mod_name usg) put_ bh (usg_mod_hash usg) @@ -1828,10 +1837,10 @@ instance Binary Usage where put_ bh (usg_entities usg) put_ bh (usg_safe usg) - put_ bh usg@UsageFile{} = do + put_ bh usg@UsageFile{} = do putByte bh 2 put_ bh (usg_file_path usg) - put_ bh (usg_mtime usg) + put_ bh (usg_file_hash usg) get bh = do h <- getByte bh @@ -1850,9 +1859,9 @@ instance Binary Usage where 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 } + fp <- get bh + hash <- get bh + return UsageFile { usg_file_path = fp, usg_file_hash = hash } i -> error ("Binary.get(Usage): " ++ show i) \end{code} @@ -2457,4 +2466,3 @@ emptyModBreaks = ModBreaks , modBreaks_decls = array (0,-1) [] } \end{code} - diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs index cc8dfe3eb7..fb832ff2e3 100644 --- a/compiler/main/Packages.lhs +++ b/compiler/main/Packages.lhs @@ -867,16 +867,19 @@ getPackageLibraryPath dflags pkgs = collectLibraryPaths :: [PackageConfig] -> [FilePath] collectLibraryPaths ps = nub (filter notNull (concatMap libraryDirs ps)) --- | Find all the link options in these and the preload packages -getPackageLinkOpts :: DynFlags -> [PackageId] -> IO [String] +-- | Find all the link options in these and the preload packages, +-- returning (package hs lib options, extra library options, other flags) +getPackageLinkOpts :: DynFlags -> [PackageId] -> IO ([String], [String], [String]) getPackageLinkOpts dflags pkgs = collectLinkOpts dflags `fmap` getPreloadPackagesAnd dflags pkgs -collectLinkOpts :: DynFlags -> [PackageConfig] -> [String] -collectLinkOpts dflags ps = concat (map all_opts ps) - where - libs p = packageHsLibs dflags p ++ extraLibraries p - all_opts p = map ("-l" ++) (libs p) ++ ldOptions p +collectLinkOpts :: DynFlags -> [PackageConfig] -> ([String], [String], [String]) +collectLinkOpts dflags ps = + ( + concatMap (map ("-l" ++) . packageHsLibs dflags) ps, + concatMap (map ("-l" ++) . extraLibraries) ps, + concatMap ldOptions ps + ) packageHsLibs :: DynFlags -> PackageConfig -> [String] packageHsLibs dflags p = map (mkDynName . addSuffix) (hsLibraries p) diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs index d43826a046..6fe29a99c4 100644 --- a/compiler/main/SysTools.lhs +++ b/compiler/main/SysTools.lhs @@ -15,7 +15,7 @@ module SysTools ( runUnlit, runCpp, runCc, -- [Option] -> IO () runPp, -- [Option] -> IO () runSplit, -- [Option] -> IO () - runAs, runLink, -- [Option] -> IO () + runAs, runLink, runLibtool, -- [Option] -> IO () runMkDLL, runWindres, runLlvmOpt, @@ -261,6 +261,7 @@ initSysTools mbMinusB split_script = installed cGHC_SPLIT_PGM windres_path <- getSetting "windres command" + libtool_path <- getSetting "libtool command" tmpdir <- getTemporaryDirectory @@ -331,6 +332,7 @@ initSysTools mbMinusB sPgm_T = touch_path, sPgm_sysman = top_dir ++ "/ghc/rts/parallel/SysMan", sPgm_windres = windres_path, + sPgm_libtool = libtool_path, sPgm_lo = (lo_prog,[]), sPgm_lc = (lc_prog,[]), -- Hans: this isn't right in general, but you can @@ -717,6 +719,15 @@ runLink dflags args = do mb_env <- getGccEnv args2 runSomethingFiltered dflags id "Linker" p args2 mb_env +runLibtool :: DynFlags -> [Option] -> IO () +runLibtool dflags args = do + linkargs <- neededLinkArgs `fmap` getLinkerInfo dflags + let args1 = map Option (getOpts dflags opt_l) + args2 = [Option "-static"] ++ args1 ++ args ++ linkargs + libtool = pgm_libtool dflags + mb_env <- getGccEnv args2 + runSomethingFiltered dflags id "Linker" libtool args2 mb_env + runMkDLL :: DynFlags -> [Option] -> IO () runMkDLL dflags args = do let (p,args0) = pgm_dll dflags @@ -1220,7 +1231,8 @@ linkDynLib dflags0 o_files dep_packages pkgs _ -> filter ((/= rtsPackageId) . packageConfigId) pkgs - let pkg_link_opts = collectLinkOpts dflags pkgs_no_rts + let pkg_link_opts = let (package_hs_libs, extra_libs, other_flags) = collectLinkOpts dflags pkgs_no_rts + in package_hs_libs ++ extra_libs ++ other_flags -- probably _stub.o files let extra_ld_inputs = ldInputs dflags @@ -1315,6 +1327,7 @@ linkDynLib dflags0 o_files dep_packages ++ map Option pkg_lib_path_opts ++ map Option pkg_link_opts ) + OSiOS -> throwGhcExceptionIO (ProgramError "dynamic libraries are not supported on iOS target") _ -> do ------------------------------------------------------------------- -- Making a DSO diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index be4c683276..7b3695dbed 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -815,12 +815,7 @@ dffvLetBndr vanilla_unfold id = case src of InlineRhs | vanilla_unfold -> dffvExpr rhs | otherwise -> return () - InlineWrapper v -> insert v _ -> dffvExpr rhs - -- For a wrapper, externalise the wrapper id rather than the - -- fvs of the rhs. The two usually come down to the same thing - -- but I've seen cases where we had a wrapper id $w but a - -- rhs where $w had been inlined; see Trac #3922 go_unf (DFunUnfolding { df_bndrs = bndrs, df_args = args }) = extendScopeList bndrs $ mapM_ dffvExpr args |