1{-# LANGUAGE FlexibleContexts #-} 2{-# LANGUAGE RankNTypes #-} 3{-# LANGUAGE TupleSections #-} 4{-# LANGUAGE CPP #-} 5 6module Distribution.Simple.GHCJS ( 7 getGhcInfo, 8 configure, 9 getInstalledPackages, 10 getInstalledPackagesMonitorFiles, 11 getPackageDBContents, 12 buildLib, buildFLib, buildExe, 13 replLib, replFLib, replExe, 14 startInterpreter, 15 installLib, installFLib, installExe, 16 libAbiHash, 17 hcPkgInfo, 18 registerPackage, 19 componentGhcOptions, 20 componentCcGhcOptions, 21 getLibDir, 22 isDynamic, 23 getGlobalPackageDB, 24 pkgRoot, 25 runCmd, 26 -- * Constructing and deconstructing GHC environment files 27 Internal.GhcEnvironmentFileEntry(..), 28 Internal.simpleGhcEnvironmentFile, 29 Internal.renderGhcEnvironmentFile, 30 Internal.writeGhcEnvironmentFile, 31 Internal.ghcPlatformAndVersionString, 32 readGhcEnvironmentFile, 33 parseGhcEnvironmentFile, 34 ParseErrorExc(..), 35 -- * Version-specific implementation quirks 36 getImplInfo, 37 GhcImplInfo(..) 38 ) where 39 40import Prelude () 41import Distribution.Compat.Prelude 42 43import qualified Distribution.Simple.GHC.Internal as Internal 44import Distribution.Simple.GHC.ImplInfo 45import Distribution.Simple.GHC.EnvironmentParser 46import Distribution.PackageDescription.Utils (cabalBug) 47import Distribution.PackageDescription as PD 48import Distribution.InstalledPackageInfo (InstalledPackageInfo) 49import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo 50import Distribution.Simple.PackageIndex (InstalledPackageIndex) 51import qualified Distribution.Simple.PackageIndex as PackageIndex 52import Distribution.Simple.LocalBuildInfo 53import Distribution.Types.ComponentLocalBuildInfo 54import qualified Distribution.Simple.Hpc as Hpc 55import Distribution.Simple.BuildPaths 56import Distribution.Simple.Utils 57import Distribution.Package 58import qualified Distribution.ModuleName as ModuleName 59import Distribution.ModuleName (ModuleName) 60import Distribution.Simple.Program 61import qualified Distribution.Simple.Program.HcPkg as HcPkg 62import qualified Distribution.Simple.Program.Strip as Strip 63import Distribution.Simple.Program.GHC 64import Distribution.Simple.Setup 65import qualified Distribution.Simple.Setup as Cabal 66import Distribution.Simple.Compiler hiding (Flag) 67import Distribution.Version 68import Distribution.System 69import Distribution.Verbosity 70import Distribution.Pretty 71import Distribution.Types.ForeignLib 72import Distribution.Types.ForeignLibType 73import Distribution.Types.ForeignLibOption 74import Distribution.Types.UnqualComponentName 75import Distribution.Utils.NubList 76 77import Control.Monad (msum) 78import Data.Char (isLower) 79import qualified Data.Map as Map 80import System.Directory 81 ( doesFileExist, getAppUserDataDirectory, createDirectoryIfMissing 82 , canonicalizePath, removeFile, renameFile ) 83import System.FilePath ( (</>), (<.>), takeExtension 84 , takeDirectory, replaceExtension 85 ,isRelative ) 86import qualified System.Info 87 88-- ----------------------------------------------------------------------------- 89-- Configuring 90 91configure :: Verbosity -> Maybe FilePath -> Maybe FilePath 92 -> ProgramDb 93 -> IO (Compiler, Maybe Platform, ProgramDb) 94configure verbosity hcPath hcPkgPath conf0 = do 95 96 (ghcjsProg, ghcjsVersion, progdb1) <- 97 requireProgramVersion verbosity ghcjsProgram 98 (orLaterVersion (mkVersion [0,1])) 99 (userMaybeSpecifyPath "ghcjs" hcPath conf0) 100 101 Just ghcjsGhcVersion <- findGhcjsGhcVersion verbosity (programPath ghcjsProg) 102 unless (ghcjsGhcVersion < mkVersion [8,8]) $ 103 warn verbosity $ 104 "Unknown/unsupported 'ghc' version detected " 105 ++ "(Cabal " ++ prettyShow cabalVersion ++ " supports 'ghc' version < 8.8): " 106 ++ programPath ghcjsProg ++ " is is based on GHC version " ++ 107 prettyShow ghcjsGhcVersion 108 109 let implInfo = ghcjsVersionImplInfo ghcjsVersion ghcjsGhcVersion 110 111 -- This is slightly tricky, we have to configure ghc first, then we use the 112 -- location of ghc to help find ghc-pkg in the case that the user did not 113 -- specify the location of ghc-pkg directly: 114 (ghcjsPkgProg, ghcjsPkgVersion, progdb2) <- 115 requireProgramVersion verbosity ghcjsPkgProgram { 116 programFindLocation = guessGhcjsPkgFromGhcjsPath ghcjsProg 117 } 118 anyVersion (userMaybeSpecifyPath "ghcjs-pkg" hcPkgPath progdb1) 119 120 Just ghcjsPkgGhcjsVersion <- findGhcjsPkgGhcjsVersion 121 verbosity (programPath ghcjsPkgProg) 122 123 when (ghcjsVersion /= ghcjsPkgGhcjsVersion) $ die' verbosity $ 124 "Version mismatch between ghcjs and ghcjs-pkg: " 125 ++ programPath ghcjsProg ++ " is version " ++ prettyShow ghcjsVersion ++ " " 126 ++ programPath ghcjsPkgProg ++ " is version " ++ prettyShow ghcjsPkgGhcjsVersion 127 128 when (ghcjsGhcVersion /= ghcjsPkgVersion) $ die' verbosity $ 129 "Version mismatch between ghcjs and ghcjs-pkg: " 130 ++ programPath ghcjsProg 131 ++ " was built with GHC version " ++ prettyShow ghcjsGhcVersion ++ " " 132 ++ programPath ghcjsPkgProg 133 ++ " was built with GHC version " ++ prettyShow ghcjsPkgVersion 134 135 136 -- Likewise we try to find the matching hsc2hs and haddock programs. 137 let hsc2hsProgram' = hsc2hsProgram { 138 programFindLocation = 139 guessHsc2hsFromGhcjsPath ghcjsProg 140 } 141 haddockProgram' = haddockProgram { 142 programFindLocation = 143 guessHaddockFromGhcjsPath ghcjsProg 144 } 145 hpcProgram' = hpcProgram { 146 programFindLocation = guessHpcFromGhcjsPath ghcjsProg 147 } 148 {- 149 runghcProgram' = runghcProgram { 150 programFindLocation = guessRunghcFromGhcjsPath ghcjsProg 151 } -} 152 progdb3 = addKnownProgram haddockProgram' $ 153 addKnownProgram hsc2hsProgram' $ 154 addKnownProgram hpcProgram' $ 155 {- addKnownProgram runghcProgram' -} progdb2 156 157 languages <- Internal.getLanguages verbosity implInfo ghcjsProg 158 extensions <- Internal.getExtensions verbosity implInfo ghcjsProg 159 160 ghcjsInfo <- Internal.getGhcInfo verbosity implInfo ghcjsProg 161 let ghcInfoMap = Map.fromList ghcjsInfo 162 163 let comp = Compiler { 164 compilerId = CompilerId GHCJS ghcjsVersion, 165 compilerAbiTag = AbiTag $ 166 "ghc" ++ intercalate "_" (map show . versionNumbers $ ghcjsGhcVersion), 167 compilerCompat = [CompilerId GHC ghcjsGhcVersion], 168 compilerLanguages = languages, 169 compilerExtensions = extensions, 170 compilerProperties = ghcInfoMap 171 } 172 compPlatform = Internal.targetPlatform ghcjsInfo 173 return (comp, compPlatform, progdb3) 174 175guessGhcjsPkgFromGhcjsPath :: ConfiguredProgram -> Verbosity 176 -> ProgramSearchPath -> IO (Maybe (FilePath, [FilePath])) 177guessGhcjsPkgFromGhcjsPath = guessToolFromGhcjsPath ghcjsPkgProgram 178 179guessHsc2hsFromGhcjsPath :: ConfiguredProgram -> Verbosity 180 -> ProgramSearchPath -> IO (Maybe (FilePath, [FilePath])) 181guessHsc2hsFromGhcjsPath = guessToolFromGhcjsPath hsc2hsProgram 182 183guessHaddockFromGhcjsPath :: ConfiguredProgram -> Verbosity 184 -> ProgramSearchPath -> IO (Maybe (FilePath, [FilePath])) 185guessHaddockFromGhcjsPath = guessToolFromGhcjsPath haddockProgram 186 187guessHpcFromGhcjsPath :: ConfiguredProgram 188 -> Verbosity -> ProgramSearchPath 189 -> IO (Maybe (FilePath, [FilePath])) 190guessHpcFromGhcjsPath = guessToolFromGhcjsPath hpcProgram 191 192 193guessToolFromGhcjsPath :: Program -> ConfiguredProgram 194 -> Verbosity -> ProgramSearchPath 195 -> IO (Maybe (FilePath, [FilePath])) 196guessToolFromGhcjsPath tool ghcjsProg verbosity searchpath 197 = do let toolname = programName tool 198 given_path = programPath ghcjsProg 199 given_dir = takeDirectory given_path 200 real_path <- canonicalizePath given_path 201 let real_dir = takeDirectory real_path 202 versionSuffix path = takeVersionSuffix (dropExeExtension path) 203 given_suf = versionSuffix given_path 204 real_suf = versionSuffix real_path 205 guessNormal dir = dir </> toolname <.> exeExtension buildPlatform 206 guessGhcjs dir = dir </> (toolname ++ "-ghcjs") 207 <.> exeExtension buildPlatform 208 guessGhcjsVersioned dir suf = dir </> (toolname ++ "-ghcjs" ++ suf) 209 <.> exeExtension buildPlatform 210 guessVersioned dir suf = dir </> (toolname ++ suf) 211 <.> exeExtension buildPlatform 212 mkGuesses dir suf | null suf = [guessGhcjs dir, guessNormal dir] 213 | otherwise = [guessGhcjsVersioned dir suf, 214 guessVersioned dir suf, 215 guessGhcjs dir, 216 guessNormal dir] 217 guesses = mkGuesses given_dir given_suf ++ 218 if real_path == given_path 219 then [] 220 else mkGuesses real_dir real_suf 221 info verbosity $ "looking for tool " ++ toolname 222 ++ " near compiler in " ++ given_dir 223 debug verbosity $ "candidate locations: " ++ show guesses 224 exists <- traverse doesFileExist guesses 225 case [ file | (file, True) <- zip guesses exists ] of 226 -- If we can't find it near ghc, fall back to the usual 227 -- method. 228 [] -> programFindLocation tool verbosity searchpath 229 (fp:_) -> do info verbosity $ "found " ++ toolname ++ " in " ++ fp 230 let lookedAt = map fst 231 . takeWhile (\(_file, exist) -> not exist) 232 $ zip guesses exists 233 return (Just (fp, lookedAt)) 234 235 where takeVersionSuffix :: FilePath -> String 236 takeVersionSuffix = takeWhileEndLE isSuffixChar 237 238 isSuffixChar :: Char -> Bool 239 isSuffixChar c = isDigit c || c == '.' || c == '-' 240 241getGhcInfo :: Verbosity -> ConfiguredProgram -> IO [(String, String)] 242getGhcInfo verbosity ghcjsProg = Internal.getGhcInfo verbosity implInfo ghcjsProg 243 where 244 Just version = programVersion ghcjsProg 245 implInfo = ghcVersionImplInfo version 246 247-- | Given a single package DB, return all installed packages. 248getPackageDBContents :: Verbosity -> PackageDB -> ProgramDb 249 -> IO InstalledPackageIndex 250getPackageDBContents verbosity packagedb progdb = do 251 pkgss <- getInstalledPackages' verbosity [packagedb] progdb 252 toPackageIndex verbosity pkgss progdb 253 254-- | Given a package DB stack, return all installed packages. 255getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramDb 256 -> IO InstalledPackageIndex 257getInstalledPackages verbosity packagedbs progdb = do 258 checkPackageDbEnvVar verbosity 259 checkPackageDbStack verbosity packagedbs 260 pkgss <- getInstalledPackages' verbosity packagedbs progdb 261 index <- toPackageIndex verbosity pkgss progdb 262 return $! index 263 264toPackageIndex :: Verbosity 265 -> [(PackageDB, [InstalledPackageInfo])] 266 -> ProgramDb 267 -> IO InstalledPackageIndex 268toPackageIndex verbosity pkgss progdb = do 269 -- On Windows, various fields have $topdir/foo rather than full 270 -- paths. We need to substitute the right value in so that when 271 -- we, for example, call gcc, we have proper paths to give it. 272 topDir <- getLibDir' verbosity ghcjsProg 273 let indices = [ PackageIndex.fromList (map (Internal.substTopDir topDir) pkgs) 274 | (_, pkgs) <- pkgss ] 275 return $! (mconcat indices) 276 277 where 278 Just ghcjsProg = lookupProgram ghcjsProgram progdb 279 280getLibDir :: Verbosity -> LocalBuildInfo -> IO FilePath 281getLibDir verbosity lbi = 282 dropWhileEndLE isSpace `fmap` 283 getDbProgramOutput verbosity ghcjsProgram 284 (withPrograms lbi) ["--print-libdir"] 285 286getLibDir' :: Verbosity -> ConfiguredProgram -> IO FilePath 287getLibDir' verbosity ghcjsProg = 288 dropWhileEndLE isSpace `fmap` 289 getProgramOutput verbosity ghcjsProg ["--print-libdir"] 290 291 292-- | Return the 'FilePath' to the global GHC package database. 293getGlobalPackageDB :: Verbosity -> ConfiguredProgram -> IO FilePath 294getGlobalPackageDB verbosity ghcProg = 295 dropWhileEndLE isSpace `fmap` 296 getProgramOutput verbosity ghcProg ["--print-global-package-db"] 297 298-- | Return the 'FilePath' to the per-user GHC package database. 299getUserPackageDB :: Verbosity -> ConfiguredProgram -> Platform -> NoCallStackIO FilePath 300getUserPackageDB _verbosity ghcjsProg platform = do 301 -- It's rather annoying that we have to reconstruct this, because ghc 302 -- hides this information from us otherwise. But for certain use cases 303 -- like change monitoring it really can't remain hidden. 304 appdir <- getAppUserDataDirectory "ghcjs" 305 return (appdir </> platformAndVersion </> packageConfFileName) 306 where 307 platformAndVersion = Internal.ghcPlatformAndVersionString 308 platform ghcjsVersion 309 packageConfFileName = "package.conf.d" 310 Just ghcjsVersion = programVersion ghcjsProg 311 312checkPackageDbEnvVar :: Verbosity -> IO () 313checkPackageDbEnvVar verbosity = 314 Internal.checkPackageDbEnvVar verbosity "GHCJS" "GHCJS_PACKAGE_PATH" 315 316checkPackageDbStack :: Verbosity -> PackageDBStack -> IO () 317checkPackageDbStack _ (GlobalPackageDB:rest) 318 | GlobalPackageDB `notElem` rest = return () 319checkPackageDbStack verbosity rest 320 | GlobalPackageDB `notElem` rest = 321 die' verbosity $ "With current ghc versions the global package db is always used " 322 ++ "and must be listed first. This ghc limitation may be lifted in " 323 ++ "future, see http://ghc.haskell.org/trac/ghc/ticket/5977" 324checkPackageDbStack verbosity _ = 325 die' verbosity $ "If the global package db is specified, it must be " 326 ++ "specified first and cannot be specified multiple times" 327 328getInstalledPackages' :: Verbosity -> [PackageDB] -> ProgramDb 329 -> IO [(PackageDB, [InstalledPackageInfo])] 330getInstalledPackages' verbosity packagedbs progdb = 331 sequenceA 332 [ do pkgs <- HcPkg.dump (hcPkgInfo progdb) verbosity packagedb 333 return (packagedb, pkgs) 334 | packagedb <- packagedbs ] 335 336-- | Get the packages from specific PackageDBs, not cumulative. 337-- 338getInstalledPackagesMonitorFiles :: Verbosity -> Platform 339 -> ProgramDb 340 -> [PackageDB] 341 -> IO [FilePath] 342getInstalledPackagesMonitorFiles verbosity platform progdb = 343 traverse getPackageDBPath 344 where 345 getPackageDBPath :: PackageDB -> IO FilePath 346 getPackageDBPath GlobalPackageDB = 347 selectMonitorFile =<< getGlobalPackageDB verbosity ghcjsProg 348 349 getPackageDBPath UserPackageDB = 350 selectMonitorFile =<< getUserPackageDB verbosity ghcjsProg platform 351 352 getPackageDBPath (SpecificPackageDB path) = selectMonitorFile path 353 354 -- GHC has old style file dbs, and new style directory dbs. 355 -- Note that for dir style dbs, we only need to monitor the cache file, not 356 -- the whole directory. The ghc program itself only reads the cache file 357 -- so it's safe to only monitor this one file. 358 selectMonitorFile path = do 359 isFileStyle <- doesFileExist path 360 if isFileStyle then return path 361 else return (path </> "package.cache") 362 363 Just ghcjsProg = lookupProgram ghcjsProgram progdb 364 365 366toJSLibName :: String -> String 367toJSLibName lib 368 | takeExtension lib `elem` [".dll",".dylib",".so"] 369 = replaceExtension lib "js_so" 370 | takeExtension lib == ".a" = replaceExtension lib "js_a" 371 | otherwise = lib <.> "js_a" 372 373-- ----------------------------------------------------------------------------- 374-- Building a library 375 376buildLib :: Verbosity -> Cabal.Flag (Maybe Int) -> PackageDescription 377 -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo 378 -> IO () 379buildLib = buildOrReplLib Nothing 380 381replLib :: [String] -> Verbosity 382 -> Cabal.Flag (Maybe Int) -> PackageDescription 383 -> LocalBuildInfo -> Library 384 -> ComponentLocalBuildInfo -> IO () 385replLib = buildOrReplLib . Just 386 387buildOrReplLib :: Maybe [String] -> Verbosity 388 -> Cabal.Flag (Maybe Int) -> PackageDescription 389 -> LocalBuildInfo -> Library 390 -> ComponentLocalBuildInfo -> IO () 391buildOrReplLib mReplFlags verbosity numJobs pkg_descr lbi lib clbi = do 392 let uid = componentUnitId clbi 393 libTargetDir = componentBuildDir lbi clbi 394 whenVanillaLib forceVanilla = 395 when (forceVanilla || withVanillaLib lbi) 396 whenProfLib = when (withProfLib lbi) 397 whenSharedLib forceShared = 398 when (forceShared || withSharedLib lbi) 399 whenStaticLib forceStatic = 400 when (forceStatic || withStaticLib lbi) 401 -- whenGHCiLib = when (withGHCiLib lbi) 402 forRepl = maybe False (const True) mReplFlags 403 -- ifReplLib = when forRepl 404 comp = compiler lbi 405 implInfo = getImplInfo comp 406 platform@(Platform _hostArch _hostOS) = hostPlatform lbi 407 has_code = not (componentIsIndefinite clbi) 408 409 (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram (withPrograms lbi) 410 let runGhcjsProg = runGHC verbosity ghcjsProg comp platform 411 412 let libBi = libBuildInfo lib 413 414 -- fixme flags shouldn't depend on ghcjs being dynamic or not 415 let isGhcjsDynamic = isDynamic comp 416 dynamicTooSupported = supportsDynamicToo comp 417 doingTH = usesTemplateHaskellOrQQ libBi 418 forceVanillaLib = doingTH && not isGhcjsDynamic 419 forceSharedLib = doingTH && isGhcjsDynamic 420 -- TH always needs default libs, even when building for profiling 421 422 -- Determine if program coverage should be enabled and if so, what 423 -- '-hpcdir' should be. 424 let isCoverageEnabled = libCoverage lbi 425 -- TODO: Historically HPC files have been put into a directory which 426 -- has the package name. I'm going to avoid changing this for 427 -- now, but it would probably be better for this to be the 428 -- component ID instead... 429 pkg_name = prettyShow (PD.package pkg_descr) 430 distPref = fromFlag $ configDistPref $ configFlags lbi 431 hpcdir way 432 | forRepl = mempty -- HPC is not supported in ghci 433 | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way pkg_name 434 | otherwise = mempty 435 436 createDirectoryIfMissingVerbose verbosity True libTargetDir 437 -- TODO: do we need to put hs-boot files into place for mutually recursive 438 -- modules? 439 let cLikeFiles = fromNubListR $ toNubListR (cSources libBi) <> toNubListR (cxxSources libBi) 440 jsSrcs = jsSources libBi 441 cObjs = map (`replaceExtension` objExtension) cLikeFiles 442 baseOpts = componentGhcOptions verbosity lbi libBi clbi libTargetDir 443 linkJsLibOpts = mempty { 444 ghcOptExtra = 445 [ "-link-js-lib" , getHSLibraryName uid 446 , "-js-lib-outputdir", libTargetDir ] ++ 447 jsSrcs 448 } 449 vanillaOptsNoJsLib = baseOpts `mappend` mempty { 450 ghcOptMode = toFlag GhcModeMake, 451 ghcOptNumJobs = numJobs, 452 ghcOptInputModules = toNubListR $ allLibModules lib clbi, 453 ghcOptHPCDir = hpcdir Hpc.Vanilla 454 } 455 vanillaOpts = vanillaOptsNoJsLib `mappend` linkJsLibOpts 456 457 profOpts = adjustExts "p_hi" "p_o" vanillaOpts `mappend` mempty { 458 ghcOptProfilingMode = toFlag True, 459 ghcOptProfilingAuto = Internal.profDetailLevelFlag True 460 (withProfLibDetail lbi), 461 -- ghcOptHiSuffix = toFlag "p_hi", 462 -- ghcOptObjSuffix = toFlag "p_o", 463 ghcOptExtra = hcProfOptions GHC libBi, 464 ghcOptHPCDir = hpcdir Hpc.Prof 465 } 466 467 sharedOpts = adjustExts "dyn_hi" "dyn_o" vanillaOpts `mappend` mempty { 468 ghcOptDynLinkMode = toFlag GhcDynamicOnly, 469 ghcOptFPic = toFlag True, 470 -- ghcOptHiSuffix = toFlag "dyn_hi", 471 -- ghcOptObjSuffix = toFlag "dyn_o", 472 ghcOptExtra = hcSharedOptions GHC libBi, 473 ghcOptHPCDir = hpcdir Hpc.Dyn 474 } 475 476 vanillaSharedOpts = vanillaOpts `mappend` mempty { 477 ghcOptDynLinkMode = toFlag GhcStaticAndDynamic, 478 ghcOptDynHiSuffix = toFlag "js_dyn_hi", 479 ghcOptDynObjSuffix = toFlag "js_dyn_o", 480 ghcOptHPCDir = hpcdir Hpc.Dyn 481 } 482 483 unless (forRepl || null (allLibModules lib clbi) && null jsSrcs && null cObjs) $ 484 do let vanilla = whenVanillaLib forceVanillaLib (runGhcjsProg vanillaOpts) 485 shared = whenSharedLib forceSharedLib (runGhcjsProg sharedOpts) 486 useDynToo = dynamicTooSupported && 487 (forceVanillaLib || withVanillaLib lbi) && 488 (forceSharedLib || withSharedLib lbi) && 489 null (hcSharedOptions GHC libBi) 490 if not has_code 491 then vanilla 492 else 493 if useDynToo 494 then do 495 runGhcjsProg vanillaSharedOpts 496 case (hpcdir Hpc.Dyn, hpcdir Hpc.Vanilla) of 497 (Cabal.Flag dynDir, Cabal.Flag vanillaDir) -> 498 -- When the vanilla and shared library builds are done 499 -- in one pass, only one set of HPC module interfaces 500 -- are generated. This set should suffice for both 501 -- static and dynamically linked executables. We copy 502 -- the modules interfaces so they are available under 503 -- both ways. 504 copyDirectoryRecursive verbosity dynDir vanillaDir 505 _ -> return () 506 else if isGhcjsDynamic 507 then do shared; vanilla 508 else do vanilla; shared 509 whenProfLib (runGhcjsProg profOpts) 510 511 -- Build any C++ sources separately. 512 {- 513 unless (not has_code || null (cxxSources libBi) || not nativeToo) $ do 514 info verbosity "Building C++ Sources..." 515 sequence_ 516 [ do let baseCxxOpts = Internal.componentCxxGhcOptions verbosity implInfo 517 lbi libBi clbi libTargetDir filename 518 vanillaCxxOpts = if isGhcjsDynamic 519 then baseCxxOpts { ghcOptFPic = toFlag True } 520 else baseCxxOpts 521 profCxxOpts = vanillaCxxOpts `mappend` mempty { 522 ghcOptProfilingMode = toFlag True, 523 ghcOptObjSuffix = toFlag "p_o" 524 } 525 sharedCxxOpts = vanillaCxxOpts `mappend` mempty { 526 ghcOptFPic = toFlag True, 527 ghcOptDynLinkMode = toFlag GhcDynamicOnly, 528 ghcOptObjSuffix = toFlag "dyn_o" 529 } 530 odir = fromFlag (ghcOptObjDir vanillaCxxOpts) 531 createDirectoryIfMissingVerbose verbosity True odir 532 let runGhcProgIfNeeded cxxOpts = do 533 needsRecomp <- checkNeedsRecompilation filename cxxOpts 534 when needsRecomp $ runGhcjsProg cxxOpts 535 runGhcProgIfNeeded vanillaCxxOpts 536 unless forRepl $ 537 whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedCxxOpts) 538 unless forRepl $ whenProfLib (runGhcProgIfNeeded profCxxOpts) 539 | filename <- cxxSources libBi] 540 541 ifReplLib $ do 542 when (null (allLibModules lib clbi)) $ warn verbosity "No exposed modules" 543 ifReplLib (runGhcjsProg replOpts) 544-} 545 -- build any C sources 546 -- TODO: Add support for S and CMM files. 547 {- 548 unless (not has_code || null (cSources libBi) || not nativeToo) $ do 549 info verbosity "Building C Sources..." 550 sequence_ 551 [ do let baseCcOpts = Internal.componentCcGhcOptions verbosity implInfo 552 lbi libBi clbi libTargetDir filename 553 vanillaCcOpts = if isGhcjsDynamic 554 -- Dynamic GHC requires C sources to be built 555 -- with -fPIC for REPL to work. See #2207. 556 then baseCcOpts { ghcOptFPic = toFlag True } 557 else baseCcOpts 558 profCcOpts = vanillaCcOpts `mappend` mempty { 559 ghcOptProfilingMode = toFlag True, 560 ghcOptObjSuffix = toFlag "p_o" 561 } 562 sharedCcOpts = vanillaCcOpts `mappend` mempty { 563 ghcOptFPic = toFlag True, 564 ghcOptDynLinkMode = toFlag GhcDynamicOnly, 565 ghcOptObjSuffix = toFlag "dyn_o" 566 } 567 odir = fromFlag (ghcOptObjDir vanillaCcOpts) 568 createDirectoryIfMissingVerbose verbosity True odir 569 let runGhcProgIfNeeded ccOpts = do 570 needsRecomp <- checkNeedsRecompilation filename ccOpts 571 when needsRecomp $ runGhcjsProg ccOpts 572 runGhcProgIfNeeded vanillaCcOpts 573 unless forRepl $ 574 whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedCcOpts) 575 unless forRepl $ whenProfLib (runGhcProgIfNeeded profCcOpts) 576 | filename <- cSources libBi] 577-} 578 -- TODO: problem here is we need the .c files built first, so we can load them 579 -- with ghci, but .c files can depend on .h files generated by ghc by ffi 580 -- exports. 581 582 -- link: 583 584 when has_code . when False {- fixme nativeToo -} . unless forRepl $ do 585 info verbosity "Linking..." 586 let cSharedObjs = map (`replaceExtension` ("dyn_" ++ objExtension)) 587 (cSources libBi ++ cxxSources libBi) 588 compiler_id = compilerId (compiler lbi) 589 sharedLibFilePath = libTargetDir </> mkSharedLibName (hostPlatform lbi) compiler_id uid 590 staticLibFilePath = libTargetDir </> mkStaticLibName (hostPlatform lbi) compiler_id uid 591 592 let stubObjs = [] 593 stubSharedObjs = [] 594 595{- 596 stubObjs <- catMaybes <$> sequenceA 597 [ findFileWithExtension [objExtension] [libTargetDir] 598 (ModuleName.toFilePath x ++"_stub") 599 | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files 600 , x <- allLibModules lib clbi ] 601 stubProfObjs <- catMaybes <$> sequenceA 602 [ findFileWithExtension ["p_" ++ objExtension] [libTargetDir] 603 (ModuleName.toFilePath x ++"_stub") 604 | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files 605 , x <- allLibModules lib clbi ] 606 stubSharedObjs <- catMaybes <$> sequenceA 607 [ findFileWithExtension ["dyn_" ++ objExtension] [libTargetDir] 608 (ModuleName.toFilePath x ++"_stub") 609 | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files 610 , x <- allLibModules lib clbi ] 611-} 612 hObjs <- Internal.getHaskellObjects implInfo lib lbi clbi 613 libTargetDir objExtension True 614 hSharedObjs <- 615 if withSharedLib lbi 616 then Internal.getHaskellObjects implInfo lib lbi clbi 617 libTargetDir ("dyn_" ++ objExtension) False 618 else return [] 619 620 unless (null hObjs && null cObjs && null stubObjs) $ do 621 rpaths <- getRPaths lbi clbi 622 623 let staticObjectFiles = 624 hObjs 625 ++ map (libTargetDir </>) cObjs 626 ++ stubObjs 627 dynamicObjectFiles = 628 hSharedObjs 629 ++ map (libTargetDir </>) cSharedObjs 630 ++ stubSharedObjs 631 -- After the relocation lib is created we invoke ghc -shared 632 -- with the dependencies spelled out as -package arguments 633 -- and ghc invokes the linker with the proper library paths 634 ghcSharedLinkArgs = 635 mempty { 636 ghcOptShared = toFlag True, 637 ghcOptDynLinkMode = toFlag GhcDynamicOnly, 638 ghcOptInputFiles = toNubListR dynamicObjectFiles, 639 ghcOptOutputFile = toFlag sharedLibFilePath, 640 ghcOptExtra = hcSharedOptions GHC libBi, 641 -- For dynamic libs, Mac OS/X needs to know the install location 642 -- at build time. This only applies to GHC < 7.8 - see the 643 -- discussion in #1660. 644 {- 645 ghcOptDylibName = if hostOS == OSX 646 && ghcVersion < mkVersion [7,8] 647 then toFlag sharedLibInstallPath 648 else mempty, -} 649 ghcOptHideAllPackages = toFlag True, 650 ghcOptNoAutoLinkPackages = toFlag True, 651 ghcOptPackageDBs = withPackageDB lbi, 652 ghcOptThisUnitId = case clbi of 653 LibComponentLocalBuildInfo { componentCompatPackageKey = pk } 654 -> toFlag pk 655 _ -> mempty, 656 ghcOptThisComponentId = case clbi of 657 LibComponentLocalBuildInfo { componentInstantiatedWith = insts } -> 658 if null insts 659 then mempty 660 else toFlag (componentComponentId clbi) 661 _ -> mempty, 662 ghcOptInstantiatedWith = case clbi of 663 LibComponentLocalBuildInfo { componentInstantiatedWith = insts } 664 -> insts 665 _ -> [], 666 ghcOptPackages = toNubListR $ 667 Internal.mkGhcOptPackages clbi , 668 ghcOptLinkLibs = extraLibs libBi, 669 ghcOptLinkLibPath = toNubListR $ extraLibDirs libBi, 670 ghcOptLinkFrameworks = toNubListR $ PD.frameworks libBi, 671 ghcOptLinkFrameworkDirs = 672 toNubListR $ PD.extraFrameworkDirs libBi, 673 ghcOptRPaths = rpaths 674 } 675 ghcStaticLinkArgs = 676 mempty { 677 ghcOptStaticLib = toFlag True, 678 ghcOptInputFiles = toNubListR staticObjectFiles, 679 ghcOptOutputFile = toFlag staticLibFilePath, 680 ghcOptExtra = hcStaticOptions GHC libBi, 681 ghcOptHideAllPackages = toFlag True, 682 ghcOptNoAutoLinkPackages = toFlag True, 683 ghcOptPackageDBs = withPackageDB lbi, 684 ghcOptThisUnitId = case clbi of 685 LibComponentLocalBuildInfo { componentCompatPackageKey = pk } 686 -> toFlag pk 687 _ -> mempty, 688 ghcOptThisComponentId = case clbi of 689 LibComponentLocalBuildInfo { componentInstantiatedWith = insts } -> 690 if null insts 691 then mempty 692 else toFlag (componentComponentId clbi) 693 _ -> mempty, 694 ghcOptInstantiatedWith = case clbi of 695 LibComponentLocalBuildInfo { componentInstantiatedWith = insts } 696 -> insts 697 _ -> [], 698 ghcOptPackages = toNubListR $ 699 Internal.mkGhcOptPackages clbi , 700 ghcOptLinkLibs = extraLibs libBi, 701 ghcOptLinkLibPath = toNubListR $ extraLibDirs libBi 702 } 703 704 info verbosity (show (ghcOptPackages ghcSharedLinkArgs)) 705{- 706 whenVanillaLib False $ do 707 Ar.createArLibArchive verbosity lbi vanillaLibFilePath staticObjectFiles 708 whenGHCiLib $ do 709 (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi) 710 Ld.combineObjectFiles verbosity lbi ldProg 711 ghciLibFilePath staticObjectFiles 712 -} 713{- 714 whenProfLib $ do 715 Ar.createArLibArchive verbosity lbi profileLibFilePath profObjectFiles 716 whenGHCiLib $ do 717 (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi) 718 Ld.combineObjectFiles verbosity lbi ldProg 719 ghciProfLibFilePath profObjectFiles 720-} 721 whenSharedLib False $ 722 runGhcjsProg ghcSharedLinkArgs 723 724 whenStaticLib False $ 725 runGhcjsProg ghcStaticLinkArgs 726 727-- | Start a REPL without loading any source files. 728startInterpreter :: Verbosity -> ProgramDb -> Compiler -> Platform 729 -> PackageDBStack -> IO () 730startInterpreter verbosity progdb comp platform packageDBs = do 731 let replOpts = mempty { 732 ghcOptMode = toFlag GhcModeInteractive, 733 ghcOptPackageDBs = packageDBs 734 } 735 checkPackageDbStack verbosity packageDBs 736 (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram progdb 737 runGHC verbosity ghcjsProg comp platform replOpts 738 739-- ----------------------------------------------------------------------------- 740-- Building an executable or foreign library 741 742-- | Build a foreign library 743buildFLib 744 :: Verbosity -> Cabal.Flag (Maybe Int) 745 -> PackageDescription -> LocalBuildInfo 746 -> ForeignLib -> ComponentLocalBuildInfo -> IO () 747buildFLib v njobs pkg lbi = gbuild v njobs pkg lbi . GBuildFLib 748 749replFLib 750 :: [String] -> Verbosity 751 -> Cabal.Flag (Maybe Int) -> PackageDescription 752 -> LocalBuildInfo -> ForeignLib 753 -> ComponentLocalBuildInfo -> IO () 754replFLib replFlags v njobs pkg lbi = 755 gbuild v njobs pkg lbi . GReplFLib replFlags 756 757-- | Build an executable with GHC. 758-- 759buildExe 760 :: Verbosity -> Cabal.Flag (Maybe Int) 761 -> PackageDescription -> LocalBuildInfo 762 -> Executable -> ComponentLocalBuildInfo -> IO () 763buildExe v njobs pkg lbi = gbuild v njobs pkg lbi . GBuildExe 764 765replExe 766 :: [String] -> Verbosity 767 -> Cabal.Flag (Maybe Int) -> PackageDescription 768 -> LocalBuildInfo -> Executable 769 -> ComponentLocalBuildInfo -> IO () 770replExe replFlags v njobs pkg lbi = 771 gbuild v njobs pkg lbi . GReplExe replFlags 772 773-- | Building an executable, starting the REPL, and building foreign 774-- libraries are all very similar and implemented in 'gbuild'. The 775-- 'GBuildMode' distinguishes between the various kinds of operation. 776data GBuildMode = 777 GBuildExe Executable 778 | GReplExe [String] Executable 779 | GBuildFLib ForeignLib 780 | GReplFLib [String] ForeignLib 781 782gbuildInfo :: GBuildMode -> BuildInfo 783gbuildInfo (GBuildExe exe) = buildInfo exe 784gbuildInfo (GReplExe _ exe) = buildInfo exe 785gbuildInfo (GBuildFLib flib) = foreignLibBuildInfo flib 786gbuildInfo (GReplFLib _ flib) = foreignLibBuildInfo flib 787 788gbuildName :: GBuildMode -> String 789gbuildName (GBuildExe exe) = unUnqualComponentName $ exeName exe 790gbuildName (GReplExe _ exe) = unUnqualComponentName $ exeName exe 791gbuildName (GBuildFLib flib) = unUnqualComponentName $ foreignLibName flib 792gbuildName (GReplFLib _ flib) = unUnqualComponentName $ foreignLibName flib 793 794gbuildTargetName :: LocalBuildInfo -> GBuildMode -> String 795gbuildTargetName lbi (GBuildExe exe) = exeTargetName (hostPlatform lbi) exe 796gbuildTargetName lbi (GReplExe _ exe) = exeTargetName (hostPlatform lbi) exe 797gbuildTargetName lbi (GBuildFLib flib) = flibTargetName lbi flib 798gbuildTargetName lbi (GReplFLib _ flib) = flibTargetName lbi flib 799 800exeTargetName :: Platform -> Executable -> String 801exeTargetName platform exe = unUnqualComponentName (exeName exe) `withExt` exeExtension platform 802 803-- | Target name for a foreign library (the actual file name) 804-- 805-- We do not use mkLibName and co here because the naming for foreign libraries 806-- is slightly different (we don't use "_p" or compiler version suffices, and we 807-- don't want the "lib" prefix on Windows). 808-- 809-- TODO: We do use `dllExtension` and co here, but really that's wrong: they 810-- use the OS used to build cabal to determine which extension to use, rather 811-- than the target OS (but this is wrong elsewhere in Cabal as well). 812flibTargetName :: LocalBuildInfo -> ForeignLib -> String 813flibTargetName lbi flib = 814 case (os, foreignLibType flib) of 815 (Windows, ForeignLibNativeShared) -> nm <.> "dll" 816 (Windows, ForeignLibNativeStatic) -> nm <.> "lib" 817 (Linux, ForeignLibNativeShared) -> "lib" ++ nm <.> versionedExt 818 (_other, ForeignLibNativeShared) -> "lib" ++ nm <.> dllExtension (hostPlatform lbi) 819 (_other, ForeignLibNativeStatic) -> "lib" ++ nm <.> staticLibExtension (hostPlatform lbi) 820 (_any, ForeignLibTypeUnknown) -> cabalBug "unknown foreign lib type" 821 where 822 nm :: String 823 nm = unUnqualComponentName $ foreignLibName flib 824 825 os :: OS 826 os = let (Platform _ os') = hostPlatform lbi 827 in os' 828 829 -- If a foreign lib foo has lib-version-info 5:1:2 or 830 -- lib-version-linux 3.2.1, it should be built as libfoo.so.3.2.1 831 -- Libtool's version-info data is translated into library versions in a 832 -- nontrivial way: so refer to libtool documentation. 833 versionedExt :: String 834 versionedExt = 835 let nums = foreignLibVersion flib os 836 in foldl (<.>) "so" (map show nums) 837 838-- | Name for the library when building. 839-- 840-- If the `lib-version-info` field or the `lib-version-linux` field of 841-- a foreign library target is set, we need to incorporate that 842-- version into the SONAME field. 843-- 844-- If a foreign library foo has lib-version-info 5:1:2, it should be 845-- built as libfoo.so.3.2.1. We want it to get soname libfoo.so.3. 846-- However, GHC does not allow overriding soname by setting linker 847-- options, as it sets a soname of its own (namely the output 848-- filename), after the user-supplied linker options. Hence, we have 849-- to compile the library with the soname as its filename. We rename 850-- the compiled binary afterwards. 851-- 852-- This method allows to adjust the name of the library at build time 853-- such that the correct soname can be set. 854flibBuildName :: LocalBuildInfo -> ForeignLib -> String 855flibBuildName lbi flib 856 -- On linux, if a foreign-library has version data, the first digit is used 857 -- to produce the SONAME. 858 | (os, foreignLibType flib) == 859 (Linux, ForeignLibNativeShared) 860 = let nums = foreignLibVersion flib os 861 in "lib" ++ nm <.> foldl (<.>) "so" (map show (take 1 nums)) 862 | otherwise = flibTargetName lbi flib 863 where 864 os :: OS 865 os = let (Platform _ os') = hostPlatform lbi 866 in os' 867 868 nm :: String 869 nm = unUnqualComponentName $ foreignLibName flib 870 871gbuildIsRepl :: GBuildMode -> Bool 872gbuildIsRepl (GBuildExe _) = False 873gbuildIsRepl (GReplExe _ _) = True 874gbuildIsRepl (GBuildFLib _) = False 875gbuildIsRepl (GReplFLib _ _) = True 876 877gbuildNeedDynamic :: LocalBuildInfo -> GBuildMode -> Bool 878gbuildNeedDynamic lbi bm = 879 case bm of 880 GBuildExe _ -> withDynExe lbi 881 GReplExe _ _ -> withDynExe lbi 882 GBuildFLib flib -> withDynFLib flib 883 GReplFLib _ flib -> withDynFLib flib 884 where 885 withDynFLib flib = 886 case foreignLibType flib of 887 ForeignLibNativeShared -> 888 ForeignLibStandalone `notElem` foreignLibOptions flib 889 ForeignLibNativeStatic -> 890 False 891 ForeignLibTypeUnknown -> 892 cabalBug "unknown foreign lib type" 893 894gbuildModDefFiles :: GBuildMode -> [FilePath] 895gbuildModDefFiles (GBuildExe _) = [] 896gbuildModDefFiles (GReplExe _ _) = [] 897gbuildModDefFiles (GBuildFLib flib) = foreignLibModDefFile flib 898gbuildModDefFiles (GReplFLib _ flib) = foreignLibModDefFile flib 899 900-- | "Main" module name when overridden by @ghc-options: -main-is ...@ 901-- or 'Nothing' if no @-main-is@ flag could be found. 902-- 903-- In case of 'Nothing', 'Distribution.ModuleName.main' can be assumed. 904exeMainModuleName :: Executable -> Maybe ModuleName 905exeMainModuleName Executable{buildInfo = bnfo} = 906 -- GHC honors the last occurrence of a module name updated via -main-is 907 -- 908 -- Moreover, -main-is when parsed left-to-right can update either 909 -- the "Main" module name, or the "main" function name, or both, 910 -- see also 'decodeMainIsArg'. 911 msum $ reverse $ map decodeMainIsArg $ findIsMainArgs ghcopts 912 where 913 ghcopts = hcOptions GHC bnfo 914 915 findIsMainArgs [] = [] 916 findIsMainArgs ("-main-is":arg:rest) = arg : findIsMainArgs rest 917 findIsMainArgs (_:rest) = findIsMainArgs rest 918 919-- | Decode argument to '-main-is' 920-- 921-- Returns 'Nothing' if argument set only the function name. 922-- 923-- This code has been stolen/refactored from GHC's DynFlags.setMainIs 924-- function. The logic here is deliberately imperfect as it is 925-- intended to be bug-compatible with GHC's parser. See discussion in 926-- https://github.com/haskell/cabal/pull/4539#discussion_r118981753. 927decodeMainIsArg :: String -> Maybe ModuleName 928decodeMainIsArg arg 929 | not (null main_fn) && isLower (head main_fn) 930 -- The arg looked like "Foo.Bar.baz" 931 = Just (ModuleName.fromString main_mod) 932 | isUpper (head arg) -- The arg looked like "Foo" or "Foo.Bar" 933 = Just (ModuleName.fromString arg) 934 | otherwise -- The arg looked like "baz" 935 = Nothing 936 where 937 (main_mod, main_fn) = splitLongestPrefix arg (== '.') 938 939 splitLongestPrefix :: String -> (Char -> Bool) -> (String,String) 940 splitLongestPrefix str pred' 941 | null r_pre = (str, []) 942 | otherwise = (reverse (tail r_pre), reverse r_suf) 943 -- 'tail' drops the char satisfying 'pred' 944 where (r_suf, r_pre) = break pred' (reverse str) 945 946 947-- | A collection of: 948-- * C input files 949-- * C++ input files 950-- * GHC input files 951-- * GHC input modules 952-- 953-- Used to correctly build and link sources. 954data BuildSources = BuildSources { 955 cSourcesFiles :: [FilePath], 956 cxxSourceFiles :: [FilePath], 957 inputSourceFiles :: [FilePath], 958 inputSourceModules :: [ModuleName] 959 } 960 961-- | Locate and return the 'BuildSources' required to build and link. 962gbuildSources :: Verbosity 963 -> Version -- ^ specVersion 964 -> FilePath 965 -> GBuildMode 966 -> IO BuildSources 967gbuildSources verbosity specVer tmpDir bm = 968 case bm of 969 GBuildExe exe -> exeSources exe 970 GReplExe _ exe -> exeSources exe 971 GBuildFLib flib -> return $ flibSources flib 972 GReplFLib _ flib -> return $ flibSources flib 973 where 974 exeSources :: Executable -> IO BuildSources 975 exeSources exe@Executable{buildInfo = bnfo, modulePath = modPath} = do 976 main <- findFileEx verbosity (tmpDir : hsSourceDirs bnfo) modPath 977 let mainModName = fromMaybe ModuleName.main $ exeMainModuleName exe 978 otherModNames = exeModules exe 979 980 if isHaskell main 981 then 982 if specVer < mkVersion [2] && (mainModName `elem` otherModNames) 983 then do 984 -- The cabal manual clearly states that `other-modules` is 985 -- intended for non-main modules. However, there's at least one 986 -- important package on Hackage (happy-1.19.5) which 987 -- violates this. We workaround this here so that we don't 988 -- invoke GHC with e.g. 'ghc --make Main src/Main.hs' which 989 -- would result in GHC complaining about duplicate Main 990 -- modules. 991 -- 992 -- Finally, we only enable this workaround for 993 -- specVersion < 2, as 'cabal-version:>=2.0' cabal files 994 -- have no excuse anymore to keep doing it wrong... ;-) 995 warn verbosity $ "Enabling workaround for Main module '" 996 ++ prettyShow mainModName 997 ++ "' listed in 'other-modules' illegally!" 998 999 return BuildSources { 1000 cSourcesFiles = cSources bnfo, 1001 cxxSourceFiles = cxxSources bnfo, 1002 inputSourceFiles = [main], 1003 inputSourceModules = filter (/= mainModName) $ exeModules exe 1004 } 1005 1006 else return BuildSources { 1007 cSourcesFiles = cSources bnfo, 1008 cxxSourceFiles = cxxSources bnfo, 1009 inputSourceFiles = [main], 1010 inputSourceModules = exeModules exe 1011 } 1012 else let (csf, cxxsf) 1013 | isCxx main = ( cSources bnfo, main : cxxSources bnfo) 1014 -- if main is not a Haskell source 1015 -- and main is not a C++ source 1016 -- then we assume that it is a C source 1017 | otherwise = (main : cSources bnfo, cxxSources bnfo) 1018 1019 in return BuildSources { 1020 cSourcesFiles = csf, 1021 cxxSourceFiles = cxxsf, 1022 inputSourceFiles = [], 1023 inputSourceModules = exeModules exe 1024 } 1025 1026 flibSources :: ForeignLib -> BuildSources 1027 flibSources flib@ForeignLib{foreignLibBuildInfo = bnfo} = 1028 BuildSources { 1029 cSourcesFiles = cSources bnfo, 1030 cxxSourceFiles = cxxSources bnfo, 1031 inputSourceFiles = [], 1032 inputSourceModules = foreignLibModules flib 1033 } 1034 1035 isHaskell :: FilePath -> Bool 1036 isHaskell fp = elem (takeExtension fp) [".hs", ".lhs"] 1037 1038 isCxx :: FilePath -> Bool 1039 isCxx fp = elem (takeExtension fp) [".cpp", ".cxx", ".c++"] 1040 1041-- | Generic build function. See comment for 'GBuildMode'. 1042gbuild :: Verbosity -> Cabal.Flag (Maybe Int) 1043 -> PackageDescription -> LocalBuildInfo 1044 -> GBuildMode -> ComponentLocalBuildInfo -> IO () 1045gbuild verbosity numJobs pkg_descr lbi bm clbi = do 1046 (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram (withPrograms lbi) 1047 let replFlags = case bm of 1048 GReplExe flags _ -> flags 1049 GReplFLib flags _ -> flags 1050 GBuildExe{} -> mempty 1051 GBuildFLib{} -> mempty 1052 comp = compiler lbi 1053 platform = hostPlatform lbi 1054 implInfo = getImplInfo comp 1055 runGhcProg = runGHC verbosity ghcjsProg comp platform 1056 1057 let (bnfo, threaded) = case bm of 1058 GBuildFLib _ -> popThreadedFlag (gbuildInfo bm) 1059 _ -> (gbuildInfo bm, False) 1060 1061 -- the name that GHC really uses (e.g., with .exe on Windows for executables) 1062 let targetName = gbuildTargetName lbi bm 1063 let targetDir = buildDir lbi </> (gbuildName bm) 1064 let tmpDir = targetDir </> (gbuildName bm ++ "-tmp") 1065 createDirectoryIfMissingVerbose verbosity True targetDir 1066 createDirectoryIfMissingVerbose verbosity True tmpDir 1067 1068 -- TODO: do we need to put hs-boot files into place for mutually recursive 1069 -- modules? FIX: what about exeName.hi-boot? 1070 1071 -- Determine if program coverage should be enabled and if so, what 1072 -- '-hpcdir' should be. 1073 let isCoverageEnabled = exeCoverage lbi 1074 distPref = fromFlag $ configDistPref $ configFlags lbi 1075 hpcdir way 1076 | gbuildIsRepl bm = mempty -- HPC is not supported in ghci 1077 | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way (gbuildName bm) 1078 | otherwise = mempty 1079 1080 rpaths <- getRPaths lbi clbi 1081 buildSources <- gbuildSources verbosity (specVersion pkg_descr) tmpDir bm 1082 1083 let cSrcs = cSourcesFiles buildSources 1084 cxxSrcs = cxxSourceFiles buildSources 1085 inputFiles = inputSourceFiles buildSources 1086 inputModules = inputSourceModules buildSources 1087 isGhcDynamic = isDynamic comp 1088 dynamicTooSupported = supportsDynamicToo comp 1089 cObjs = map (`replaceExtension` objExtension) cSrcs 1090 cxxObjs = map (`replaceExtension` objExtension) cxxSrcs 1091 needDynamic = gbuildNeedDynamic lbi bm 1092 needProfiling = withProfExe lbi 1093 1094 -- build executables 1095 baseOpts = (componentGhcOptions verbosity lbi bnfo clbi tmpDir) 1096 `mappend` mempty { 1097 ghcOptMode = toFlag GhcModeMake, 1098 ghcOptInputFiles = toNubListR inputFiles, 1099 ghcOptInputModules = toNubListR inputModules 1100 } 1101 staticOpts = baseOpts `mappend` mempty { 1102 ghcOptDynLinkMode = toFlag GhcStaticOnly, 1103 ghcOptHPCDir = hpcdir Hpc.Vanilla 1104 } 1105 profOpts = baseOpts `mappend` mempty { 1106 ghcOptProfilingMode = toFlag True, 1107 ghcOptProfilingAuto = Internal.profDetailLevelFlag False 1108 (withProfExeDetail lbi), 1109 ghcOptHiSuffix = toFlag "p_hi", 1110 ghcOptObjSuffix = toFlag "p_o", 1111 ghcOptExtra = hcProfOptions GHC bnfo, 1112 ghcOptHPCDir = hpcdir Hpc.Prof 1113 } 1114 dynOpts = baseOpts `mappend` mempty { 1115 ghcOptDynLinkMode = toFlag GhcDynamicOnly, 1116 -- TODO: Does it hurt to set -fPIC for executables? 1117 ghcOptFPic = toFlag True, 1118 ghcOptHiSuffix = toFlag "dyn_hi", 1119 ghcOptObjSuffix = toFlag "dyn_o", 1120 ghcOptExtra = hcSharedOptions GHC bnfo, 1121 ghcOptHPCDir = hpcdir Hpc.Dyn 1122 } 1123 dynTooOpts = staticOpts `mappend` mempty { 1124 ghcOptDynLinkMode = toFlag GhcStaticAndDynamic, 1125 ghcOptDynHiSuffix = toFlag "dyn_hi", 1126 ghcOptDynObjSuffix = toFlag "dyn_o", 1127 ghcOptHPCDir = hpcdir Hpc.Dyn 1128 } 1129 linkerOpts = mempty { 1130 ghcOptLinkOptions = PD.ldOptions bnfo, 1131 ghcOptLinkLibs = extraLibs bnfo, 1132 ghcOptLinkLibPath = toNubListR $ extraLibDirs bnfo, 1133 ghcOptLinkFrameworks = toNubListR $ 1134 PD.frameworks bnfo, 1135 ghcOptLinkFrameworkDirs = toNubListR $ 1136 PD.extraFrameworkDirs bnfo, 1137 ghcOptInputFiles = toNubListR 1138 [tmpDir </> x | x <- cObjs ++ cxxObjs] 1139 } 1140 dynLinkerOpts = mempty { 1141 ghcOptRPaths = rpaths 1142 } 1143 replOpts = baseOpts { 1144 ghcOptExtra = Internal.filterGhciFlags 1145 (ghcOptExtra baseOpts) 1146 <> replFlags 1147 } 1148 -- For a normal compile we do separate invocations of ghc for 1149 -- compiling as for linking. But for repl we have to do just 1150 -- the one invocation, so that one has to include all the 1151 -- linker stuff too, like -l flags and any .o files from C 1152 -- files etc. 1153 `mappend` linkerOpts 1154 `mappend` mempty { 1155 ghcOptMode = toFlag GhcModeInteractive, 1156 ghcOptOptimisation = toFlag GhcNoOptimisation 1157 } 1158 commonOpts | needProfiling = profOpts 1159 | needDynamic = dynOpts 1160 | otherwise = staticOpts 1161 compileOpts | useDynToo = dynTooOpts 1162 | otherwise = commonOpts 1163 withStaticExe = not needProfiling && not needDynamic 1164 1165 -- For building exe's that use TH with -prof or -dynamic we actually have 1166 -- to build twice, once without -prof/-dynamic and then again with 1167 -- -prof/-dynamic. This is because the code that TH needs to run at 1168 -- compile time needs to be the vanilla ABI so it can be loaded up and run 1169 -- by the compiler. 1170 -- With dynamic-by-default GHC the TH object files loaded at compile-time 1171 -- need to be .dyn_o instead of .o. 1172 doingTH = usesTemplateHaskellOrQQ bnfo 1173 -- Should we use -dynamic-too instead of compiling twice? 1174 useDynToo = dynamicTooSupported && isGhcDynamic 1175 && doingTH && withStaticExe 1176 && null (hcSharedOptions GHC bnfo) 1177 compileTHOpts | isGhcDynamic = dynOpts 1178 | otherwise = staticOpts 1179 compileForTH 1180 | gbuildIsRepl bm = False 1181 | useDynToo = False 1182 | isGhcDynamic = doingTH && (needProfiling || withStaticExe) 1183 | otherwise = doingTH && (needProfiling || needDynamic) 1184 1185 -- Build static/dynamic object files for TH, if needed. 1186 when compileForTH $ 1187 runGhcProg compileTHOpts { ghcOptNoLink = toFlag True 1188 , ghcOptNumJobs = numJobs } 1189 1190 -- Do not try to build anything if there are no input files. 1191 -- This can happen if the cabal file ends up with only cSrcs 1192 -- but no Haskell modules. 1193 unless ((null inputFiles && null inputModules) 1194 || gbuildIsRepl bm) $ 1195 runGhcProg compileOpts { ghcOptNoLink = toFlag True 1196 , ghcOptNumJobs = numJobs } 1197 1198 -- build any C++ sources 1199 unless (null cxxSrcs) $ do 1200 info verbosity "Building C++ Sources..." 1201 sequence_ 1202 [ do let baseCxxOpts = Internal.componentCxxGhcOptions verbosity implInfo 1203 lbi bnfo clbi tmpDir filename 1204 vanillaCxxOpts = if isGhcDynamic 1205 -- Dynamic GHC requires C++ sources to be built 1206 -- with -fPIC for REPL to work. See #2207. 1207 then baseCxxOpts { ghcOptFPic = toFlag True } 1208 else baseCxxOpts 1209 profCxxOpts = vanillaCxxOpts `mappend` mempty { 1210 ghcOptProfilingMode = toFlag True 1211 } 1212 sharedCxxOpts = vanillaCxxOpts `mappend` mempty { 1213 ghcOptFPic = toFlag True, 1214 ghcOptDynLinkMode = toFlag GhcDynamicOnly 1215 } 1216 opts | needProfiling = profCxxOpts 1217 | needDynamic = sharedCxxOpts 1218 | otherwise = vanillaCxxOpts 1219 -- TODO: Placing all Haskell, C, & C++ objects in a single directory 1220 -- Has the potential for file collisions. In general we would 1221 -- consider this a user error. However, we should strive to 1222 -- add a warning if this occurs. 1223 odir = fromFlag (ghcOptObjDir opts) 1224 createDirectoryIfMissingVerbose verbosity True odir 1225 needsRecomp <- checkNeedsRecompilation filename opts 1226 when needsRecomp $ 1227 runGhcProg opts 1228 | filename <- cxxSrcs ] 1229 1230 -- build any C sources 1231 unless (null cSrcs) $ do 1232 info verbosity "Building C Sources..." 1233 sequence_ 1234 [ do let baseCcOpts = Internal.componentCcGhcOptions verbosity implInfo 1235 lbi bnfo clbi tmpDir filename 1236 vanillaCcOpts = if isGhcDynamic 1237 -- Dynamic GHC requires C sources to be built 1238 -- with -fPIC for REPL to work. See #2207. 1239 then baseCcOpts { ghcOptFPic = toFlag True } 1240 else baseCcOpts 1241 profCcOpts = vanillaCcOpts `mappend` mempty { 1242 ghcOptProfilingMode = toFlag True 1243 } 1244 sharedCcOpts = vanillaCcOpts `mappend` mempty { 1245 ghcOptFPic = toFlag True, 1246 ghcOptDynLinkMode = toFlag GhcDynamicOnly 1247 } 1248 opts | needProfiling = profCcOpts 1249 | needDynamic = sharedCcOpts 1250 | otherwise = vanillaCcOpts 1251 odir = fromFlag (ghcOptObjDir opts) 1252 createDirectoryIfMissingVerbose verbosity True odir 1253 needsRecomp <- checkNeedsRecompilation filename opts 1254 when needsRecomp $ 1255 runGhcProg opts 1256 | filename <- cSrcs ] 1257 1258 -- TODO: problem here is we need the .c files built first, so we can load them 1259 -- with ghci, but .c files can depend on .h files generated by ghc by ffi 1260 -- exports. 1261 case bm of 1262 GReplExe _ _ -> runGhcProg replOpts 1263 GReplFLib _ _ -> runGhcProg replOpts 1264 GBuildExe _ -> do 1265 let linkOpts = commonOpts 1266 `mappend` linkerOpts 1267 `mappend` mempty { 1268 ghcOptLinkNoHsMain = toFlag (null inputFiles) 1269 } 1270 `mappend` (if withDynExe lbi then dynLinkerOpts else mempty) 1271 1272 info verbosity "Linking..." 1273 -- Work around old GHCs not relinking in this 1274 -- situation, see #3294 1275 let target = targetDir </> targetName 1276 when (compilerVersion comp < mkVersion [7,7]) $ do 1277 e <- doesFileExist target 1278 when e (removeFile target) 1279 runGhcProg linkOpts { ghcOptOutputFile = toFlag target } 1280 GBuildFLib flib -> do 1281 let rtsInfo = extractRtsInfo lbi 1282 rtsOptLinkLibs = [ 1283 if needDynamic 1284 then if threaded 1285 then dynRtsThreadedLib (rtsDynamicInfo rtsInfo) 1286 else dynRtsVanillaLib (rtsDynamicInfo rtsInfo) 1287 else if threaded 1288 then statRtsThreadedLib (rtsStaticInfo rtsInfo) 1289 else statRtsVanillaLib (rtsStaticInfo rtsInfo) 1290 ] 1291 linkOpts = case foreignLibType flib of 1292 ForeignLibNativeShared -> 1293 commonOpts 1294 `mappend` linkerOpts 1295 `mappend` dynLinkerOpts 1296 `mappend` mempty { 1297 ghcOptLinkNoHsMain = toFlag True, 1298 ghcOptShared = toFlag True, 1299 ghcOptLinkLibs = rtsOptLinkLibs, 1300 ghcOptLinkLibPath = toNubListR $ rtsLibPaths rtsInfo, 1301 ghcOptFPic = toFlag True, 1302 ghcOptLinkModDefFiles = toNubListR $ gbuildModDefFiles bm 1303 } 1304 -- See Note [RPATH] 1305 `mappend` ifNeedsRPathWorkaround lbi mempty { 1306 ghcOptLinkOptions = ["-Wl,--no-as-needed"] 1307 , ghcOptLinkLibs = ["ffi"] 1308 } 1309 ForeignLibNativeStatic -> 1310 -- this should be caught by buildFLib 1311 -- (and if we do implement this, we probably don't even want to call 1312 -- ghc here, but rather Ar.createArLibArchive or something) 1313 cabalBug "static libraries not yet implemented" 1314 ForeignLibTypeUnknown -> 1315 cabalBug "unknown foreign lib type" 1316 -- We build under a (potentially) different filename to set a 1317 -- soname on supported platforms. See also the note for 1318 -- @flibBuildName@. 1319 info verbosity "Linking..." 1320 let buildName = flibBuildName lbi flib 1321 runGhcProg linkOpts { ghcOptOutputFile = toFlag (targetDir </> buildName) } 1322 renameFile (targetDir </> buildName) (targetDir </> targetName) 1323 1324{- 1325Note [RPATH] 1326~~~~~~~~~~~~ 1327 1328Suppose that the dynamic library depends on `base`, but not (directly) on 1329`integer-gmp` (which, however, is a dependency of `base`). We will link the 1330library as 1331 1332 gcc ... -lHSbase-4.7.0.2-ghc7.8.4 -lHSinteger-gmp-0.5.1.0-ghc7.8.4 ... 1333 1334However, on systems (like Ubuntu) where the linker gets called with `-as-needed` 1335by default, the linker will notice that `integer-gmp` isn't actually a direct 1336dependency and hence omit the link. 1337 1338Then when we attempt to link a C program against this dynamic library, the 1339_static_ linker will attempt to verify that all symbols can be resolved. The 1340dynamic library itself does not require any symbols from `integer-gmp`, but 1341`base` does. In order to verify that the symbols used by `base` can be 1342resolved, the static linker needs to be able to _find_ integer-gmp. 1343 1344Finding the `base` dependency is simple, because the dynamic elf header 1345(`readelf -d`) for the library that we have created looks something like 1346 1347 (NEEDED) Shared library: [libHSbase-4.7.0.2-ghc7.8.4.so] 1348 (RPATH) Library rpath: [/path/to/base-4.7.0.2:...] 1349 1350However, when it comes to resolving the dependency on `integer-gmp`, it needs 1351to look at the dynamic header for `base`. On modern ghc (7.8 and higher) this 1352looks something like 1353 1354 (NEEDED) Shared library: [libHSinteger-gmp-0.5.1.0-ghc7.8.4.so] 1355 (RPATH) Library rpath: [$ORIGIN/../integer-gmp-0.5.1.0:...] 1356 1357This specifies the location of `integer-gmp` _in terms of_ the location of base 1358(using the `$ORIGIN`) variable. But here's the crux: when the static linker 1359attempts to verify that all symbols can be resolved, [**IT DOES NOT RESOLVE 1360`$ORIGIN`**](http://stackoverflow.com/questions/6323603/ld-using-rpath-origin-inside-a-shared-library-recursive). 1361As a consequence, it will not be able to resolve the symbols and report the 1362missing symbols as errors, _even though the dynamic linker **would** be able to 1363resolve these symbols_. We can tell the static linker not to report these 1364errors by using `--unresolved-symbols=ignore-all` and all will be fine when we 1365run the program ([(indeed, this is what the gold linker 1366does)](https://sourceware.org/ml/binutils/2013-05/msg00038.html), but it makes 1367the resulting library more difficult to use. 1368 1369Instead what we can do is make sure that the generated dynamic library has 1370explicit top-level dependencies on these libraries. This means that the static 1371linker knows where to find them, and when we have transitive dependencies on 1372the same libraries the linker will only load them once, so we avoid needing to 1373look at the `RPATH` of our dependencies. We can do this by passing 1374`--no-as-needed` to the linker, so that it doesn't omit any libraries. 1375 1376Note that on older ghc (7.6 and before) the Haskell libraries don't have an 1377RPATH set at all, which makes it even more important that we make these 1378top-level dependencies. 1379 1380Finally, we have to explicitly link against `libffi` for the same reason. For 1381newer ghc this _happens_ to be unnecessary on many systems because `libffi` is 1382a library which is not specific to GHC, and when the static linker verifies 1383that all symbols can be resolved it will find the `libffi` that is globally 1384installed (completely independent from ghc). Of course, this may well be the 1385_wrong_ version of `libffi`, but it's quite possible that symbol resolution 1386happens to work. This is of course the wrong approach, which is why we link 1387explicitly against `libffi` so that we will find the _right_ version of 1388`libffi`. 1389-} 1390 1391-- | Do we need the RPATH workaround? 1392-- 1393-- See Note [RPATH]. 1394ifNeedsRPathWorkaround :: Monoid a => LocalBuildInfo -> a -> a 1395ifNeedsRPathWorkaround lbi a = 1396 case hostPlatform lbi of 1397 Platform _ Linux -> a 1398 _otherwise -> mempty 1399 1400data DynamicRtsInfo = DynamicRtsInfo { 1401 dynRtsVanillaLib :: FilePath 1402 , dynRtsThreadedLib :: FilePath 1403 , dynRtsDebugLib :: FilePath 1404 , dynRtsEventlogLib :: FilePath 1405 , dynRtsThreadedDebugLib :: FilePath 1406 , dynRtsThreadedEventlogLib :: FilePath 1407 } 1408 1409data StaticRtsInfo = StaticRtsInfo { 1410 statRtsVanillaLib :: FilePath 1411 , statRtsThreadedLib :: FilePath 1412 , statRtsDebugLib :: FilePath 1413 , statRtsEventlogLib :: FilePath 1414 , statRtsThreadedDebugLib :: FilePath 1415 , statRtsThreadedEventlogLib :: FilePath 1416 , statRtsProfilingLib :: FilePath 1417 , statRtsThreadedProfilingLib :: FilePath 1418 } 1419 1420data RtsInfo = RtsInfo { 1421 rtsDynamicInfo :: DynamicRtsInfo 1422 , rtsStaticInfo :: StaticRtsInfo 1423 , rtsLibPaths :: [FilePath] 1424 } 1425 1426-- | Extract (and compute) information about the RTS library 1427-- 1428-- TODO: This hardcodes the name as @HSrts-ghc<version>@. I don't know if we can 1429-- find this information somewhere. We can lookup the 'hsLibraries' field of 1430-- 'InstalledPackageInfo' but it will tell us @["HSrts", "Cffi"]@, which 1431-- doesn't really help. 1432extractRtsInfo :: LocalBuildInfo -> RtsInfo 1433extractRtsInfo lbi = 1434 case PackageIndex.lookupPackageName (installedPkgs lbi) (mkPackageName "rts") of 1435 [(_, [rts])] -> aux rts 1436 _otherwise -> error "No (or multiple) ghc rts package is registered" 1437 where 1438 aux :: InstalledPackageInfo -> RtsInfo 1439 aux rts = RtsInfo { 1440 rtsDynamicInfo = DynamicRtsInfo { 1441 dynRtsVanillaLib = withGhcVersion "HSrts" 1442 , dynRtsThreadedLib = withGhcVersion "HSrts_thr" 1443 , dynRtsDebugLib = withGhcVersion "HSrts_debug" 1444 , dynRtsEventlogLib = withGhcVersion "HSrts_l" 1445 , dynRtsThreadedDebugLib = withGhcVersion "HSrts_thr_debug" 1446 , dynRtsThreadedEventlogLib = withGhcVersion "HSrts_thr_l" 1447 } 1448 , rtsStaticInfo = StaticRtsInfo { 1449 statRtsVanillaLib = "HSrts" 1450 , statRtsThreadedLib = "HSrts_thr" 1451 , statRtsDebugLib = "HSrts_debug" 1452 , statRtsEventlogLib = "HSrts_l" 1453 , statRtsThreadedDebugLib = "HSrts_thr_debug" 1454 , statRtsThreadedEventlogLib = "HSrts_thr_l" 1455 , statRtsProfilingLib = "HSrts_p" 1456 , statRtsThreadedProfilingLib = "HSrts_thr_p" 1457 } 1458 , rtsLibPaths = InstalledPackageInfo.libraryDirs rts 1459 } 1460 withGhcVersion = (++ ("-ghc" ++ prettyShow (compilerVersion (compiler lbi)))) 1461 1462-- | Returns True if the modification date of the given source file is newer than 1463-- the object file we last compiled for it, or if no object file exists yet. 1464checkNeedsRecompilation :: FilePath -> GhcOptions -> NoCallStackIO Bool 1465checkNeedsRecompilation filename opts = filename `moreRecentFile` oname 1466 where oname = getObjectFileName filename opts 1467 1468-- | Finds the object file name of the given source file 1469getObjectFileName :: FilePath -> GhcOptions -> FilePath 1470getObjectFileName filename opts = oname 1471 where odir = fromFlag (ghcOptObjDir opts) 1472 oext = fromFlagOrDefault "o" (ghcOptObjSuffix opts) 1473 oname = odir </> replaceExtension filename oext 1474 1475-- | Calculate the RPATHs for the component we are building. 1476-- 1477-- Calculates relative RPATHs when 'relocatable' is set. 1478getRPaths :: LocalBuildInfo 1479 -> ComponentLocalBuildInfo -- ^ Component we are building 1480 -> NoCallStackIO (NubListR FilePath) 1481getRPaths lbi clbi | supportRPaths hostOS = do 1482 libraryPaths <- depLibraryPaths False (relocatable lbi) lbi clbi 1483 let hostPref = case hostOS of 1484 OSX -> "@loader_path" 1485 _ -> "$ORIGIN" 1486 relPath p = if isRelative p then hostPref </> p else p 1487 rpaths = toNubListR (map relPath libraryPaths) 1488 return rpaths 1489 where 1490 (Platform _ hostOS) = hostPlatform lbi 1491 compid = compilerId . compiler $ lbi 1492 1493 -- The list of RPath-supported operating systems below reflects the 1494 -- platforms on which Cabal's RPATH handling is tested. It does _NOT_ 1495 -- reflect whether the OS supports RPATH. 1496 1497 -- E.g. when this comment was written, the *BSD operating systems were 1498 -- untested with regards to Cabal RPATH handling, and were hence set to 1499 -- 'False', while those operating systems themselves do support RPATH. 1500 supportRPaths Linux = True 1501 supportRPaths Windows = False 1502 supportRPaths OSX = True 1503 supportRPaths FreeBSD = 1504 case compid of 1505 CompilerId GHC ver | ver >= mkVersion [7,10,2] -> True 1506 _ -> False 1507 supportRPaths OpenBSD = False 1508 supportRPaths NetBSD = False 1509 supportRPaths DragonFly = False 1510 supportRPaths Solaris = False 1511 supportRPaths AIX = False 1512 supportRPaths HPUX = False 1513 supportRPaths IRIX = False 1514 supportRPaths HaLVM = False 1515 supportRPaths IOS = False 1516 supportRPaths Android = False 1517 supportRPaths Ghcjs = False 1518 supportRPaths Hurd = False 1519 supportRPaths (OtherOS _) = False 1520 -- Do _not_ add a default case so that we get a warning here when a new OS 1521 -- is added. 1522 1523getRPaths _ _ = return mempty 1524 1525-- | Remove the "-threaded" flag when building a foreign library, as it has no 1526-- effect when used with "-shared". Returns the updated 'BuildInfo', along 1527-- with whether or not the flag was present, so we can use it to link against 1528-- the appropriate RTS on our own. 1529popThreadedFlag :: BuildInfo -> (BuildInfo, Bool) 1530popThreadedFlag bi = 1531 ( bi { options = filterHcOptions (/= "-threaded") (options bi) } 1532 , hasThreaded (options bi)) 1533 1534 where 1535 filterHcOptions :: (String -> Bool) 1536 -> PerCompilerFlavor [String] 1537 -> PerCompilerFlavor [String] 1538 filterHcOptions p (PerCompilerFlavor ghc ghcjs) = 1539 PerCompilerFlavor (filter p ghc) ghcjs 1540 1541 hasThreaded :: PerCompilerFlavor [String] -> Bool 1542 hasThreaded (PerCompilerFlavor ghc _) = elem "-threaded" ghc 1543 1544-- | Extracts a String representing a hash of the ABI of a built 1545-- library. It can fail if the library has not yet been built. 1546-- 1547libAbiHash :: Verbosity -> PackageDescription -> LocalBuildInfo 1548 -> Library -> ComponentLocalBuildInfo -> IO String 1549libAbiHash verbosity _pkg_descr lbi lib clbi = do 1550 let 1551 libBi = libBuildInfo lib 1552 comp = compiler lbi 1553 platform = hostPlatform lbi 1554 vanillaArgs0 = 1555 (componentGhcOptions verbosity lbi libBi clbi (componentBuildDir lbi clbi)) 1556 `mappend` mempty { 1557 ghcOptMode = toFlag GhcModeAbiHash, 1558 ghcOptInputModules = toNubListR $ exposedModules lib 1559 } 1560 vanillaArgs = 1561 -- Package DBs unnecessary, and break ghc-cabal. See #3633 1562 -- BUT, put at least the global database so that 7.4 doesn't 1563 -- break. 1564 vanillaArgs0 { ghcOptPackageDBs = [GlobalPackageDB] 1565 , ghcOptPackages = mempty } 1566 sharedArgs = vanillaArgs `mappend` mempty { 1567 ghcOptDynLinkMode = toFlag GhcDynamicOnly, 1568 ghcOptFPic = toFlag True, 1569 ghcOptHiSuffix = toFlag "js_dyn_hi", 1570 ghcOptObjSuffix = toFlag "js_dyn_o", 1571 ghcOptExtra = hcSharedOptions GHC libBi 1572 } 1573 profArgs = vanillaArgs `mappend` mempty { 1574 ghcOptProfilingMode = toFlag True, 1575 ghcOptProfilingAuto = Internal.profDetailLevelFlag True 1576 (withProfLibDetail lbi), 1577 ghcOptHiSuffix = toFlag "js_p_hi", 1578 ghcOptObjSuffix = toFlag "js_p_o", 1579 ghcOptExtra = hcProfOptions GHC libBi 1580 } 1581 ghcArgs 1582 | withVanillaLib lbi = vanillaArgs 1583 | withSharedLib lbi = sharedArgs 1584 | withProfLib lbi = profArgs 1585 | otherwise = error "libAbiHash: Can't find an enabled library way" 1586 1587 (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram (withPrograms lbi) 1588 hash <- getProgramInvocationOutput verbosity 1589 (ghcInvocation ghcjsProg comp platform ghcArgs) 1590 return (takeWhile (not . isSpace) hash) 1591 1592componentGhcOptions :: Verbosity -> LocalBuildInfo 1593 -> BuildInfo -> ComponentLocalBuildInfo -> FilePath 1594 -> GhcOptions 1595componentGhcOptions verbosity lbi bi clbi odir = 1596 let opts = Internal.componentGhcOptions verbosity implInfo lbi bi clbi odir 1597 comp = compiler lbi 1598 implInfo = getImplInfo comp 1599 in opts { ghcOptExtra = ghcOptExtra opts `mappend` hcOptions GHCJS bi 1600 } 1601 1602 1603componentCcGhcOptions :: Verbosity -> LocalBuildInfo 1604 -> BuildInfo -> ComponentLocalBuildInfo 1605 -> FilePath -> FilePath 1606 -> GhcOptions 1607componentCcGhcOptions verbosity lbi = 1608 Internal.componentCcGhcOptions verbosity implInfo lbi 1609 where 1610 comp = compiler lbi 1611 implInfo = getImplInfo comp 1612 1613 1614-- ----------------------------------------------------------------------------- 1615-- Installing 1616 1617-- |Install executables for GHCJS. 1618installExe :: Verbosity 1619 -> LocalBuildInfo 1620 -> FilePath -- ^Where to copy the files to 1621 -> FilePath -- ^Build location 1622 -> (FilePath, FilePath) -- ^Executable (prefix,suffix) 1623 -> PackageDescription 1624 -> Executable 1625 -> IO () 1626installExe verbosity lbi binDir buildPref 1627 (progprefix, progsuffix) _pkg exe = do 1628 createDirectoryIfMissingVerbose verbosity True binDir 1629 let exeName' = unUnqualComponentName $ exeName exe 1630 exeFileName = exeName' 1631 fixedExeBaseName = progprefix ++ exeName' ++ progsuffix 1632 installBinary dest = do 1633 runDbProgram verbosity ghcjsProgram (withPrograms lbi) $ 1634 [ "--install-executable" 1635 , buildPref </> exeName' </> exeFileName 1636 , "-o", dest 1637 ] ++ 1638 case (stripExes lbi, lookupProgram stripProgram $ withPrograms lbi) of 1639 (True, Just strip) -> ["-strip-program", programPath strip] 1640 _ -> [] 1641 installBinary (binDir </> fixedExeBaseName) 1642 1643 1644-- |Install foreign library for GHC. 1645installFLib :: Verbosity 1646 -> LocalBuildInfo 1647 -> FilePath -- ^install location 1648 -> FilePath -- ^Build location 1649 -> PackageDescription 1650 -> ForeignLib 1651 -> IO () 1652installFLib verbosity lbi targetDir builtDir _pkg flib = 1653 install (foreignLibIsShared flib) 1654 builtDir 1655 targetDir 1656 (flibTargetName lbi flib) 1657 where 1658 install _isShared srcDir dstDir name = do 1659 let src = srcDir </> name 1660 dst = dstDir </> name 1661 createDirectoryIfMissingVerbose verbosity True targetDir 1662 installOrdinaryFile verbosity src dst 1663 1664 1665-- |Install for ghc, .hi, .a and, if --with-ghci given, .o 1666installLib :: Verbosity 1667 -> LocalBuildInfo 1668 -> FilePath -- ^install location 1669 -> FilePath -- ^install location for dynamic libraries 1670 -> FilePath -- ^Build location 1671 -> PackageDescription 1672 -> Library 1673 -> ComponentLocalBuildInfo 1674 -> IO () 1675installLib verbosity lbi targetDir dynlibTargetDir _builtDir _pkg lib clbi = do 1676 whenVanilla $ copyModuleFiles "js_hi" 1677 whenProf $ copyModuleFiles "js_p_hi" 1678 whenShared $ copyModuleFiles "js_dyn_hi" 1679 1680 -- whenVanilla $ installOrdinary builtDir targetDir $ toJSLibName vanillaLibName 1681 -- whenProf $ installOrdinary builtDir targetDir $ toJSLibName profileLibName 1682 -- whenShared $ installShared builtDir dynlibTargetDir $ toJSLibName sharedLibName 1683 -- fixme do these make the correct lib names? 1684 whenHasCode $ do 1685 whenVanilla $ do 1686 sequence_ [ installOrdinary builtDir' targetDir (toJSLibName $ mkGenericStaticLibName (l ++ f)) 1687 | l <- getHSLibraryName (componentUnitId clbi):(extraBundledLibs (libBuildInfo lib)) 1688 , f <- "":extraLibFlavours (libBuildInfo lib) 1689 ] 1690 -- whenGHCi $ installOrdinary builtDir targetDir (toJSLibName ghciLibName) 1691 whenProf $ do 1692 installOrdinary builtDir' targetDir (toJSLibName profileLibName) 1693 -- whenGHCi $ installOrdinary builtDir targetDir (toJSLibName ghciProfLibName) 1694 whenShared $ 1695 sequence_ [ installShared builtDir' dynlibTargetDir 1696 (toJSLibName $ mkGenericSharedLibName platform compiler_id (l ++ f)) 1697 | l <- getHSLibraryName uid : extraBundledLibs (libBuildInfo lib) 1698 , f <- "":extraDynLibFlavours (libBuildInfo lib) 1699 ] 1700 where 1701 builtDir' = componentBuildDir lbi clbi 1702 1703 install isShared isJS srcDir dstDir name = do 1704 let src = srcDir </> name 1705 dst = dstDir </> name 1706 createDirectoryIfMissingVerbose verbosity True dstDir 1707 1708 if isShared 1709 then installExecutableFile verbosity src dst 1710 else installOrdinaryFile verbosity src dst 1711 1712 when (stripLibs lbi && not isJS) $ 1713 Strip.stripLib verbosity 1714 (hostPlatform lbi) (withPrograms lbi) dst 1715 1716 installOrdinary = install False True 1717 installShared = install True True 1718 1719 copyModuleFiles ext = 1720 findModuleFilesEx verbosity [builtDir'] [ext] (allLibModules lib clbi) 1721 >>= installOrdinaryFiles verbosity targetDir 1722 1723 compiler_id = compilerId (compiler lbi) 1724 platform = hostPlatform lbi 1725 uid = componentUnitId clbi 1726 -- vanillaLibName = mkLibName uid 1727 profileLibName = mkProfLibName uid 1728 -- sharedLibName = (mkSharedLibName (hostPlatform lbi) compiler_id) uid 1729 1730 hasLib = not $ null (allLibModules lib clbi) 1731 && null (cSources (libBuildInfo lib)) 1732 && null (cxxSources (libBuildInfo lib)) 1733 && null (jsSources (libBuildInfo lib)) 1734 has_code = not (componentIsIndefinite clbi) 1735 whenHasCode = when has_code 1736 whenVanilla = when (hasLib && withVanillaLib lbi) 1737 whenProf = when (hasLib && withProfLib lbi && has_code) 1738 -- whenGHCi = when (hasLib && withGHCiLib lbi && has_code) 1739 whenShared = when (hasLib && withSharedLib lbi && has_code) 1740 1741 1742adjustExts :: String -> String -> GhcOptions -> GhcOptions 1743adjustExts hiSuf objSuf opts = 1744 opts `mappend` mempty { 1745 ghcOptHiSuffix = toFlag hiSuf, 1746 ghcOptObjSuffix = toFlag objSuf 1747 } 1748 1749isDynamic :: Compiler -> Bool 1750isDynamic = Internal.ghcLookupProperty "GHC Dynamic" 1751 1752supportsDynamicToo :: Compiler -> Bool 1753supportsDynamicToo = Internal.ghcLookupProperty "Support dynamic-too" 1754 1755withExt :: FilePath -> String -> FilePath 1756withExt fp ext = fp <.> if takeExtension fp /= ('.':ext) then ext else "" 1757 1758findGhcjsGhcVersion :: Verbosity -> FilePath -> IO (Maybe Version) 1759findGhcjsGhcVersion verbosity pgm = 1760 findProgramVersion "--numeric-ghc-version" id verbosity pgm 1761 1762findGhcjsPkgGhcjsVersion :: Verbosity -> FilePath -> IO (Maybe Version) 1763findGhcjsPkgGhcjsVersion verbosity pgm = 1764 findProgramVersion "--numeric-ghcjs-version" id verbosity pgm 1765 1766-- ----------------------------------------------------------------------------- 1767-- Registering 1768 1769hcPkgInfo :: ProgramDb -> HcPkg.HcPkgInfo 1770hcPkgInfo progdb = HcPkg.HcPkgInfo { HcPkg.hcPkgProgram = ghcjsPkgProg 1771 , HcPkg.noPkgDbStack = False 1772 , HcPkg.noVerboseFlag = False 1773 , HcPkg.flagPackageConf = False 1774 , HcPkg.supportsDirDbs = True 1775 , HcPkg.requiresDirDbs = ver >= v7_10 1776 , HcPkg.nativeMultiInstance = ver >= v7_10 1777 , HcPkg.recacheMultiInstance = True 1778 , HcPkg.suppressFilesCheck = True 1779 } 1780 where 1781 v7_10 = mkVersion [7,10] 1782 Just ghcjsPkgProg = lookupProgram ghcjsPkgProgram progdb 1783 Just ver = programVersion ghcjsPkgProg 1784 1785registerPackage 1786 :: Verbosity 1787 -> ProgramDb 1788 -> PackageDBStack 1789 -> InstalledPackageInfo 1790 -> HcPkg.RegisterOptions 1791 -> IO () 1792registerPackage verbosity progdb packageDbs installedPkgInfo registerOptions = 1793 HcPkg.register (hcPkgInfo progdb) verbosity packageDbs 1794 installedPkgInfo registerOptions 1795 1796pkgRoot :: Verbosity -> LocalBuildInfo -> PackageDB -> IO FilePath 1797pkgRoot verbosity lbi = pkgRoot' 1798 where 1799 pkgRoot' GlobalPackageDB = 1800 let Just ghcjsProg = lookupProgram ghcjsProgram (withPrograms lbi) 1801 in fmap takeDirectory (getGlobalPackageDB verbosity ghcjsProg) 1802 pkgRoot' UserPackageDB = do 1803 appDir <- getAppUserDataDirectory "ghcjs" 1804 -- fixme correct this version 1805 let ver = compilerVersion (compiler lbi) 1806 subdir = System.Info.arch ++ '-':System.Info.os 1807 ++ '-':prettyShow ver 1808 rootDir = appDir </> subdir 1809 -- We must create the root directory for the user package database if it 1810 -- does not yet exists. Otherwise '${pkgroot}' will resolve to a 1811 -- directory at the time of 'ghc-pkg register', and registration will 1812 -- fail. 1813 createDirectoryIfMissing True rootDir 1814 return rootDir 1815 pkgRoot' (SpecificPackageDB fp) = return (takeDirectory fp) 1816 1817 1818-- | Get the JavaScript file name and command and arguments to run a 1819-- program compiled by GHCJS 1820-- the exe should be the base program name without exe extension 1821runCmd :: ProgramDb -> FilePath 1822 -> (FilePath, FilePath, [String]) 1823runCmd progdb exe = 1824 ( script 1825 , programPath ghcjsProg 1826 , programDefaultArgs ghcjsProg ++ programOverrideArgs ghcjsProg ++ ["--run"] 1827 ) 1828 where 1829 script = exe <.> "jsexe" </> "all" <.> "js" 1830 Just ghcjsProg = lookupProgram ghcjsProgram progdb 1831