GHC.hs 39.8 KB
Newer Older
1 2 3
-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.Simple.GHC
Simon Marlow's avatar
Simon Marlow committed
4
-- Copyright   :  Isaac Jones 2003-2007
5
--
Duncan Coutts's avatar
Duncan Coutts committed
6
-- Maintainer  :  cabal-devel@haskell.org
7 8
-- Portability :  portable
--
Duncan Coutts's avatar
Duncan Coutts committed
9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30
-- This is a fairly large module. It contains most of the GHC-specific code for
-- configuring, building and installing packages. It also exports a function
-- for finding out what packages are already installed. Configuring involves
-- finding the @ghc@ and @ghc-pkg@ programs, finding what language extensions
-- this version of ghc supports and returning a 'Compiler' value.
--
-- 'getInstalledPackages' involves calling the @ghc-pkg@ program to find out
-- what packages are installed.
--
-- Building is somewhat complex as there is quite a bit of information to take
-- into account. We have to build libs and programs, possibly for profiling and
-- shared libs. We have to support building libraries that will be usable by
-- GHCi and also ghc's @-split-objs@ feature. We have to compile any C files
-- using ghc. Linking, especially for @split-objs@ is remarkably complex,
-- partly because there tend to be 1,000's of @.o@ files and this can often be
-- more than we can pass to the @ld@ or @ar@ programs in one go.
--
-- Installing for libs and exes involves finding the right files and copying
-- them to the right places. One of the more tricky things about this module is
-- remembering the layout of files in the build directory (which is not
-- explicitly documented) and thus what search dirs are used for various kinds
-- of files.
31 32 33 34 35

{- Copyright (c) 2003-2005, Isaac Jones
All rights reserved.

Redistribution and use in source and binary forms, with or without
36
modiication, are permitted provided that the following conditions are
37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63
met:

    * Redistributions of source code must retain the above copyright
      notice, this list of conditions and the following disclaimer.

    * Redistributions in binary form must reproduce the above
      copyright notice, this list of conditions and the following
      disclaimer in the documentation and/or other materials provided
      with the distribution.

    * Neither the name of Isaac Jones nor the names of other
      contributors may be used to endorse or promote products derived
      from this software without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}

module Distribution.Simple.GHC (
64 65 66
        configure, getInstalledPackages,
        buildLib, buildExe,
        installLib, installExe,
jpbernardy's avatar
jpbernardy committed
67
        ghcOptions,
68
        ghcVerbosityOptions
69 70
 ) where

71 72
import qualified Distribution.Simple.GHC.IPI641 as IPI641
import qualified Distribution.Simple.GHC.IPI642 as IPI642
73 74
import Distribution.Simple.Setup
         ( CopyFlags(..), fromFlag )
75
import Distribution.PackageDescription as PD
76 77
         ( PackageDescription(..), BuildInfo(..), Executable(..), withExe
         , Library(..), libModules, hcOptions )
78 79 80
import Distribution.InstalledPackageInfo
                                ( InstalledPackageInfo
                                , parseInstalledPackageInfo )
81 82
import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo
                                ( InstalledPackageInfo_(..) )
83
import Distribution.Simple.PackageIndex
84
import qualified Distribution.Simple.PackageIndex as PackageIndex
85
import Distribution.ParseUtils  ( ParseResult(..) )
86
import Distribution.Simple.LocalBuildInfo
87
         ( LocalBuildInfo(..), ComponentLocalBuildInfo(..), InstallDirs(..) )
88
import Distribution.Simple.InstallDirs
89
import Distribution.Simple.BuildPaths
90
import Distribution.Simple.Utils
91
import Distribution.Package
92
         ( PackageIdentifier, Package(..), PackageName(..) )
93
import qualified Distribution.ModuleName as ModuleName
94
import Distribution.Simple.Program
95
         ( Program(..), ConfiguredProgram(..), ProgramConfiguration, ProgArg
96
         , ProgramLocation(..), rawSystemProgram, rawSystemProgramConf
97
         , rawSystemProgramStdout, rawSystemProgramStdoutConf, requireProgram
98
         , userMaybeSpecifyPath, programPath, lookupProgram, addKnownProgram
99
         , ghcProgram, ghcPkgProgram, arProgram, ranlibProgram, ldProgram
100
         , gccProgram, stripProgram )
101
import Distribution.Simple.Compiler
102
         ( CompilerFlavor(..), CompilerId(..), Compiler(..), compilerVersion
103 104
         , OptimisationLevel(..), PackageDB(..), PackageDBStack
         , Flag, extensionsToFlags )
105
import Distribution.Version
106
         ( Version(..), orLaterVersion )
107
import Distribution.System
108
         ( OS(..), buildOS )
109
import Distribution.Verbosity
110
import Distribution.Text
111
         ( display, simpleParse )
112
import Language.Haskell.Extension (Extension(..))
113

114
import Control.Monad            ( unless, when )
115
import Data.Char
116
import Data.List
117
import Data.Maybe               ( catMaybes )
118 119
import System.Directory         ( removeFile, renameFile,
                                  getDirectoryContents, doesFileExist,
120
                                  getTemporaryDirectory )
Ross Paterson's avatar
Ross Paterson committed
121
import System.FilePath          ( (</>), (<.>), takeExtension,
122
                                  takeDirectory, replaceExtension, splitExtension )
123
import System.IO (hClose, hPutStrLn)
124
import Distribution.Compat.Exception (catchExit, catchIO)
125

126 127 128
-- -----------------------------------------------------------------------------
-- Configuring

129 130 131 132
configure :: Verbosity -> Maybe FilePath -> Maybe FilePath
          -> ProgramConfiguration -> IO (Compiler, ProgramConfiguration)
configure verbosity hcPath hcPkgPath conf = do

133
  (ghcProg, conf') <- requireProgram verbosity ghcProgram
134
                        (orLaterVersion (Version [6,4] []))
135
                        (userMaybeSpecifyPath "ghc" hcPath conf)
136
  let Just ghcVersion = programVersion ghcProg
137 138 139 140 141 142 143 144 145

  -- This is slightly tricky, we have to configure ghc first, then we use the
  -- location of ghc to help find ghc-pkg in the case that the user did not
  -- specify the location of ghc-pkg directly:
  (ghcPkgProg, conf'') <- requireProgram verbosity ghcPkgProgram {
                            programFindLocation = guessGhcPkgFromGhcPath ghcProg
                          }
                          (orLaterVersion (Version [0] []))
                          (userMaybeSpecifyPath "ghc-pkg" hcPkgPath conf')
146 147 148
  let Just ghcPkgVersion = programVersion ghcPkgProg

  when (ghcVersion /= ghcPkgVersion) $ die $
149
       "Version mismatch between ghc and ghc-pkg: "
150 151
    ++ programPath ghcProg ++ " is version " ++ display ghcVersion ++ " "
    ++ programPath ghcPkgProg ++ " is version " ++ display ghcPkgVersion
152

153
  languageExtensions <- getLanguageExtensions verbosity ghcProg
154 155

  let comp = Compiler {
156
        compilerId             = CompilerId GHC ghcVersion,
157
        compilerExtensions     = languageExtensions
158
      }
159 160
      conf''' = configureToolchain ghcProg conf'' -- configure gcc and ld
  return (comp, conf''')
161 162 163 164 165 166 167 168

-- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find a
-- corresponding ghc-pkg, we try looking for both a versioned and unversioned
-- ghc-pkg in the same dir, that is:
--
-- > /usr/local/bin/ghc-pkg-6.6.1(.exe)
-- > /usr/local/bin/ghc-pkg(.exe)
--
169 170
guessGhcPkgFromGhcPath :: ConfiguredProgram -> Verbosity -> IO (Maybe FilePath)
guessGhcPkgFromGhcPath ghcProg verbosity
171 172 173 174
  = do let path            = programPath ghcProg
           dir             = takeDirectory path
           versionSuffix   = takeVersionSuffix (dropExeExtension path)
           guessNormal     = dir </> "ghc-pkg" <.> exeExtension
175
           guessVersioned  = dir </> ("ghc-pkg" ++ versionSuffix) <.> exeExtension
176 177
           guesses | null versionSuffix = [guessNormal]
                   | otherwise          = [guessVersioned, guessNormal]
178
       info verbosity $ "looking for package tool: ghc-pkg near compiler in " ++ dir
179 180
       exists <- mapM doesFileExist guesses
       case [ file | (file, True) <- zip guesses exists ] of
181
         [] -> return Nothing
182
         (pkgtool:_) -> do info verbosity $ "found package tool in " ++ pkgtool
183
                           return (Just pkgtool)
184 185 186 187 188 189 190 191 192 193

  where takeVersionSuffix :: FilePath -> String
        takeVersionSuffix = reverse . takeWhile (`elem ` "0123456789.-") . reverse

        dropExeExtension :: FilePath -> FilePath
        dropExeExtension filepath =
          case splitExtension filepath of
            (filepath', extension) | extension == exeExtension -> filepath'
                                   | otherwise                 -> filepath

194 195 196 197
-- | Adjust the way we find and configure gcc and ld
--
configureToolchain :: ConfiguredProgram -> ProgramConfiguration
                                        -> ProgramConfiguration
198
configureToolchain ghcProg =
199
    addKnownProgram gccProgram {
200
      programFindLocation = findProg gccProgram (baseDir </> "gcc.exe"),
201
      programPostConf     = configureGcc
202 203
    }
  . addKnownProgram ldProgram {
204
      programFindLocation = findProg ldProgram (libDir </> "ld.exe"),
205 206 207 208 209 210
      programPostConf     = configureLd
    }
  where
    compilerDir = takeDirectory (programPath ghcProg)
    baseDir     = takeDirectory compilerDir
    libDir      = baseDir </> "gcc-lib"
211
    includeDir  = baseDir </> "include" </> "mingw"
212 213 214
    isWindows   = case buildOS of Windows -> True; _ -> False

    -- on Windows finding and configuring ghc's gcc and ld is a bit special
215
    findProg :: Program -> FilePath -> Verbosity -> IO (Maybe FilePath)
216
    findProg prog location | isWindows = \verbosity -> do
217
        exists <- doesFileExist location
218 219 220
        if exists then return (Just location)
                  else do warn verbosity ("Couldn't find " ++ programName prog ++ " where I expected it. Trying the search path.")
                          programFindLocation prog verbosity
221
      | otherwise = programFindLocation prog
222

223
    configureGcc :: Verbosity -> ConfiguredProgram -> IO [ProgArg]
224 225 226 227 228 229
    configureGcc
      | isWindows = \_ gccProg -> case programLocation gccProg of
          -- if it's found on system then it means we're using the result
          -- of programFindLocation above rather than a user-supplied path
          -- that means we should add this extra flag to tell ghc's gcc
          -- where it lives and thus where gcc can find its various files:
230
          FoundOnSystem {} -> return ["-B" ++ libDir, "-I" ++ includeDir]
231 232 233 234
          UserSpecified {} -> return []
      | otherwise = \_ _   -> return []

    -- we need to find out if ld supports the -x flag
235
    configureLd :: Verbosity -> ConfiguredProgram -> IO [ProgArg]
236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255
    configureLd verbosity ldProg = do
      tempDir <- getTemporaryDirectory
      ldx <- withTempFile tempDir ".c" $ \testcfile testchnd ->
             withTempFile tempDir ".o" $ \testofile testohnd -> do
               hPutStrLn testchnd "int foo() {}"
               hClose testchnd; hClose testohnd
               rawSystemProgram verbosity ghcProg ["-c", testcfile,
                                                   "-o", testofile]
               withTempFile tempDir ".o" $ \testofile' testohnd' ->
                 do
                   hClose testohnd'
                   rawSystemProgramStdout verbosity ldProg
                     ["-x", "-r", testofile, "-o", testofile']
                   return True
                 `catchIO`   (\_ -> return False)
                 `catchExit` (\_ -> return False)
      if ldx
        then return ["-x"]
        else return []

256 257 258 259 260 261 262 263 264 265 266 267 268
getLanguageExtensions :: Verbosity -> ConfiguredProgram -> IO [(Extension, Flag)]
getLanguageExtensions verbosity ghcProg
  | ghcVersion >= Version [6,7] [] = do

    exts <- rawSystemStdout verbosity (programPath ghcProg)
              ["--supported-languages"]
    -- GHC has the annoying habit of inverting some of the extensions
    -- so we have to try parsing ("No" ++ ghcExtensionName) first
    let readExtension str = do
          ext <- simpleParse ("No" ++ str)
          case ext of
            UnknownExtension _ -> simpleParse str
            _                  -> return ext
269 270 271
    return $ extensionHacks
          ++ [ (ext, "-X" ++ display ext)
             | Just ext <- map readExtension (lines exts) ]
272 273 274 275 276 277

  | otherwise = return oldLanguageExtensions

  where
    Just ghcVersion = programVersion ghcProg

278 279 280 281 282 283 284 285
    -- ghc-6.8 intorduced RecordPuns however it should have been
    -- NamedFieldPuns. We now encourage packages to use NamedFieldPuns so for
    -- compatability we fake support for it in ghc-6.8 by making it an alias
    -- for the old RecordPuns extension.
    extensionHacks = [ (NamedFieldPuns, "-XRecordPuns")
                     | ghcVersion >= Version [6,8]  []
                    && ghcVersion <  Version [6,10] [] ]

286 287 288 289 290 291 292 293
-- | For GHC 6.6.x and earlier, the mapping from supported extensions to flags
oldLanguageExtensions :: [(Extension, Flag)]
oldLanguageExtensions =
    [(OverlappingInstances       , "-fallow-overlapping-instances")
    ,(TypeSynonymInstances       , "-fglasgow-exts")
    ,(TemplateHaskell            , "-fth")
    ,(ForeignFunctionInterface   , "-fffi")
    ,(NoMonomorphismRestriction  , "-fno-monomorphism-restriction")
294
    ,(NoMonoPatBinds             , "-fno-mono-pat-binds")
295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311
    ,(UndecidableInstances       , "-fallow-undecidable-instances")
    ,(IncoherentInstances        , "-fallow-incoherent-instances")
    ,(Arrows                     , "-farrows")
    ,(Generics                   , "-fgenerics")
    ,(NoImplicitPrelude          , "-fno-implicit-prelude")
    ,(ImplicitParams             , "-fimplicit-params")
    ,(CPP                        , "-cpp")
    ,(BangPatterns               , "-fbang-patterns")
    ,(KindSignatures             , fglasgowExts)
    ,(RecursiveDo                , fglasgowExts)
    ,(ParallelListComp           , fglasgowExts)
    ,(MultiParamTypeClasses      , fglasgowExts)
    ,(FunctionalDependencies     , fglasgowExts)
    ,(Rank2Types                 , fglasgowExts)
    ,(RankNTypes                 , fglasgowExts)
    ,(PolymorphicComponents      , fglasgowExts)
    ,(ExistentialQuantification  , fglasgowExts)
312
    ,(ScopedTypeVariables        , "-fscoped-type-variables")
313 314 315 316 317 318
    ,(FlexibleContexts           , fglasgowExts)
    ,(FlexibleInstances          , fglasgowExts)
    ,(EmptyDataDecls             , fglasgowExts)
    ,(PatternGuards              , fglasgowExts)
    ,(GeneralizedNewtypeDeriving , fglasgowExts)
    ,(MagicHash                  , fglasgowExts)
319 320 321 322 323 324 325 326 327 328 329
    ,(UnicodeSyntax              , fglasgowExts)
    ,(PatternSignatures          , fglasgowExts)
    ,(UnliftedFFITypes           , fglasgowExts)
    ,(LiberalTypeSynonyms        , fglasgowExts)
    ,(TypeOperators              , fglasgowExts)
    ,(GADTs                      , fglasgowExts)
    ,(RelaxedPolyRec             , fglasgowExts)
    ,(ExtendedDefaultRules       , "-fextended-default-rules")
    ,(UnboxedTuples              , fglasgowExts)
    ,(DeriveDataTypeable         , fglasgowExts)
    ,(ConstrainedClassMethods    , fglasgowExts)
330 331 332 333
    ]
    where
      fglasgowExts = "-fglasgow-exts"

334
getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration
335
                     -> IO (PackageIndex InstalledPackageInfo)
336
getInstalledPackages verbosity packagedbs conf = do
337
  pkgss <- getInstalledPackages' verbosity packagedbs conf
338
  checkPackageDbStack packagedbs
339 340 341 342 343 344 345 346
  let pkgs = concatMap snd pkgss
      -- On Windows, various fields have $topdir/foo rather than full
      -- paths. We need to substitute the right value in so that when
      -- we, for example, call gcc, we have proper paths to give it
      Just ghcProg = lookupProgram ghcProgram conf
      compilerDir  = takeDirectory (programPath ghcProg)
      topDir       = takeDirectory compilerDir
      pkgs'        = map (substTopDir topDir) pkgs
347 348 349 350 351 352
      pi1          = PackageIndex.fromList pkgs'
      rtsPackages  = lookupPackageName pi1 (PackageName "rts")
      rtsPackages' = map removeMingwIncludeDir rtsPackages
      pi2          = pi1 `merge` fromList rtsPackages'
  return pi2

353 354 355 356 357 358 359
checkPackageDbStack :: PackageDBStack -> IO ()
checkPackageDbStack (GlobalPackageDB:rest)
  | GlobalPackageDB `notElem` rest = return ()
checkPackageDbStack _ =
  die $ "GHC.getInstalledPackages: the global package db must be "
     ++ "specified first and cannot be specified multiple times"

360 361 362 363 364 365 366 367
-- GHC < 6.10 put "$topdir/include/mingw" in rts's installDirs. This
-- breaks when you want to use a different gcc, so we need to filter
-- it out.
removeMingwIncludeDir :: InstalledPackageInfo -> InstalledPackageInfo
removeMingwIncludeDir pkg =
    let ids = InstalledPackageInfo.includeDirs pkg
        ids' = filter (not . ("mingw" `isSuffixOf`)) ids
    in pkg { InstalledPackageInfo.includeDirs = ids' }
368

369 370 371 372 373 374 375 376
-- | Get the packages from specific PackageDBs, not cumulative.
--
getInstalledPackages' :: Verbosity -> [PackageDB] -> ProgramConfiguration
                     -> IO [(PackageDB, [InstalledPackageInfo])]
getInstalledPackages' verbosity packagedbs conf
  | ghcVersion >= Version [6,9] [] =
  sequence
    [ do str <- rawSystemProgramStdoutConf verbosity ghcPkgProgram conf
377 378
                  ["dump", packageDbGhcPkgFlag packagedb]
           `catchExit` \_ -> die $ "ghc-pkg dump failed"
379
         case parsePackages str of
380
           Left ok -> return (packagedb, ok)
381
           _       -> die "failed to parse output of 'ghc-pkg dump'"
382
    | packagedb <- packagedbs ]
383

384 385 386 387 388 389 390 391 392 393 394
  where
    parsePackages str =
      let parsed = map parseInstalledPackageInfo (splitPkgs str)
       in case [ msg | ParseFailed msg <- parsed ] of
            []   -> Left [ pkg | ParseOk _ pkg <- parsed ]
            msgs -> Right msgs

    Just ghcProg = lookupProgram ghcProgram conf
    Just ghcVersion = programVersion ghcProg

    splitPkgs :: String -> [String]
395 396 397 398 399 400 401
    splitPkgs = map unlines . splitWith ("---" ==) . lines
      where
        splitWith :: (a -> Bool) -> [a] -> [[a]]
        splitWith p xs = ys : case zs of
                           []   -> []
                           _:ws -> splitWith p ws
          where (ys,zs) = break p xs
402 403 404 405 406 407 408 409 410

    packageDbGhcPkgFlag GlobalPackageDB          = "--global"
    packageDbGhcPkgFlag UserPackageDB            = "--user"
    packageDbGhcPkgFlag (SpecificPackageDB path) = "--package-conf=" ++ path

getInstalledPackages' verbosity packagedbs conf = do
    str <- rawSystemProgramStdoutConf verbosity ghcPkgProgram conf ["list"]
    let pkgFiles = [ init line | line <- lines str, last line == ':' ]
        dbFile packagedb = case (packagedb, pkgFiles) of
411 412 413 414 415 416
          (GlobalPackageDB, global:_)      -> return $ Just global
          (UserPackageDB,  _global:user:_) -> return $ Just user
          (UserPackageDB,  _global:_)      -> return $ Nothing
          (SpecificPackageDB specific, _)  -> return $ Just specific
          _ -> die "cannot read ghc-pkg package listing"
    pkgFiles' <- mapM dbFile packagedbs
417 418 419
    sequence [ withFileContents file $ \content -> do
                  pkgs <- readPackages file content
                  return (db, pkgs)
420
             | (db , Just file) <- zip packagedbs pkgFiles' ]
421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436
  where
    -- Depending on the version of ghc we use a different type's Read
    -- instance to parse the package file and then convert.
    -- It's a bit yuck. But that's what we get for using Read/Show.
    readPackages
      | ghcVersion >= Version [6,4,2] []
      = \file content -> case reads content of
          [(pkgs, _)] -> return (map IPI642.toCurrent pkgs)
          _           -> failToRead file
      | otherwise
      = \file content -> case reads content of
          [(pkgs, _)] -> return (map IPI641.toCurrent pkgs)
          _           -> failToRead file
    Just ghcProg = lookupProgram ghcProgram conf
    Just ghcVersion = programVersion ghcProg
    failToRead file = die $ "cannot read ghc package database " ++ file
437

438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456
substTopDir :: FilePath -> InstalledPackageInfo -> InstalledPackageInfo
substTopDir topDir ipo
 = ipo {
       InstalledPackageInfo.importDirs
           = map f (InstalledPackageInfo.importDirs ipo),
       InstalledPackageInfo.libraryDirs
           = map f (InstalledPackageInfo.libraryDirs ipo),
       InstalledPackageInfo.includeDirs
           = map f (InstalledPackageInfo.includeDirs ipo),
       InstalledPackageInfo.frameworkDirs
           = map f (InstalledPackageInfo.frameworkDirs ipo),
       InstalledPackageInfo.haddockInterfaces
           = map f (InstalledPackageInfo.haddockInterfaces ipo),
       InstalledPackageInfo.haddockHTMLs
           = map f (InstalledPackageInfo.haddockHTMLs ipo)
   }
    where f ('$':'t':'o':'p':'d':'i':'r':rest) = topDir ++ rest
          f x = x

457 458 459
-- -----------------------------------------------------------------------------
-- Building

460 461
-- | Build a library with GHC.
--
462 463
buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo
                      -> Library            -> ComponentLocalBuildInfo -> IO ()
464
buildLib verbosity pkg_descr lbi lib clbi = do
465
  let pref = buildDir lbi
466
      pkgid = packageId pkg_descr
467
      runGhcProg = rawSystemProgramConf verbosity ghcProgram (withPrograms lbi)
468
      ifVanillaLib forceVanilla = when (forceVanilla || withVanillaLib lbi)
469
      ifProfLib = when (withProfLib lbi)
470
      ifSharedLib = when (withSharedLib lbi)
471
      ifGHCiLib = when (withGHCiLib lbi && withVanillaLib lbi)
472

473 474 475 476 477 478 479 480 481 482 483
  libBi <- hackThreadedFlag verbosity
             (compiler lbi) (withProfLib lbi) (libBuildInfo lib)

  let libTargetDir = pref
      forceVanillaLib = TemplateHaskell `elem` extensions libBi
      -- TH always needs vanilla libs, even when building for profiling

  createDirectoryIfMissingVerbose verbosity True libTargetDir
  -- TODO: do we need to put hs-boot files into place for mutually recurive modules?
  let ghcArgs =
             ["-package-name", display pkgid ]
484
          ++ constructGHCCmdLine lbi libBi clbi libTargetDir verbosity
485
          ++ map display (libModules lib)
486 487 488 489 490 491 492 493 494 495 496 497
      ghcArgsProf = ghcArgs
          ++ ["-prof",
              "-hisuf", "p_hi",
              "-osuf", "p_o"
             ]
          ++ ghcProfOptions libBi
      ghcArgsShared = ghcArgs
          ++ ["-dynamic",
              "-hisuf", "dyn_hi",
              "-osuf", "dyn_o", "-fPIC"
             ]
          ++ ghcSharedOptions libBi
498
  unless (null (libModules lib)) $
499 500 501 502 503 504 505
    do ifVanillaLib forceVanillaLib (runGhcProg ghcArgs)
       ifProfLib (runGhcProg ghcArgsProf)
       ifSharedLib (runGhcProg ghcArgsShared)

  -- build any C sources
  unless (null (cSources libBi)) $ do
     info verbosity "Building C Sources..."
506
     sequence_ [do let (odir,args) = constructCcCmdLine lbi libBi clbi pref
507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525
                                                        filename verbosity
                   createDirectoryIfMissingVerbose verbosity True odir
                   runGhcProg args
                   ifSharedLib (runGhcProg (args ++ ["-fPIC", "-osuf dyn_o"]))
               | filename <- cSources libBi]

  -- link:
  info verbosity "Linking..."
  let cObjs = map (`replaceExtension` objExtension) (cSources libBi)
      cSharedObjs = map (`replaceExtension` ("dyn_" ++ objExtension)) (cSources libBi)
      vanillaLibFilePath = libTargetDir </> mkLibName pkgid
      profileLibFilePath = libTargetDir </> mkProfLibName pkgid
      sharedLibFilePath  = libTargetDir </> mkSharedLibName pkgid
                                              (compilerId (compiler lbi))
      ghciLibFilePath    = libTargetDir </> mkGHCiLibName pkgid

  stubObjs <- fmap catMaybes $ sequence
    [ findFileWithExtension [objExtension] [libTargetDir]
        (ModuleName.toFilePath x ++"_stub")
526
    | x <- libModules lib ]
527 528 529
  stubProfObjs <- fmap catMaybes $ sequence
    [ findFileWithExtension ["p_" ++ objExtension] [libTargetDir]
        (ModuleName.toFilePath x ++"_stub")
530
    | x <- libModules lib ]
531 532 533
  stubSharedObjs <- fmap catMaybes $ sequence
    [ findFileWithExtension ["dyn_" ++ objExtension] [libTargetDir]
        (ModuleName.toFilePath x ++"_stub")
534
    | x <- libModules lib ]
535

536
  hObjs     <- getHaskellObjects lib lbi
537 538 539
                    pref objExtension True
  hProfObjs <-
    if (withProfLib lbi)
540
            then getHaskellObjects lib lbi
541 542 543 544
                    pref ("p_" ++ objExtension) True
            else return []
  hSharedObjs <-
    if (withSharedLib lbi)
545
            then getHaskellObjects lib lbi
546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590
                    pref ("dyn_" ++ objExtension) False
            else return []

  unless (null hObjs && null cObjs && null stubObjs) $ do
    -- first remove library files if they exists
    sequence_
      [ removeFile libFilePath `catchIO` \_ -> return ()
      | libFilePath <- [vanillaLibFilePath, profileLibFilePath
                       ,sharedLibFilePath,  ghciLibFilePath] ]

    let arVerbosity | verbosity >= deafening = "v"
                    | verbosity >= normal = ""
                    | otherwise = "c"
        arArgs = ["q"++ arVerbosity]
            ++ [vanillaLibFilePath]
        arObjArgs =
               hObjs
            ++ map (pref </>) cObjs
            ++ stubObjs
        arProfArgs = ["q"++ arVerbosity]
            ++ [profileLibFilePath]
        arProfObjArgs =
               hProfObjs
            ++ map (pref </>) cObjs
            ++ stubProfObjs
        ldArgs = ["-r"]
            ++ ["-o", ghciLibFilePath <.> "tmp"]
        ldObjArgs =
               hObjs
            ++ map (pref </>) cObjs
            ++ stubObjs
        ghcSharedObjArgs =
               hSharedObjs
            ++ map (pref </>) cSharedObjs
            ++ stubSharedObjs
        -- After the relocation lib is created we invoke ghc -shared
        -- with the dependencies spelled out as -package arguments
        -- and ghc invokes the linker with the proper library paths
        ghcSharedLinkArgs =
            [ "-no-auto-link-packages",
              "-shared",
              "-dynamic",
              "-o", sharedLibFilePath ]
            ++ ghcSharedObjArgs
            ++ ["-package-name", display pkgid ]
591
            ++ (concat [ ["-package", display pkg] | pkg <- componentPackageDeps clbi ])
592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626
            ++ ["-l"++extraLib | extraLib <- extraLibs libBi]
            ++ ["-L"++extraLibDir | extraLibDir <- extraLibDirs libBi]

        runLd ldLibName args = do
          exists <- doesFileExist ldLibName
            -- This method is called iteratively by xargs. The
            -- output goes to <ldLibName>.tmp, and any existing file
            -- named <ldLibName> is included when linking. The
            -- output is renamed to <libName>.
          rawSystemProgramConf verbosity ldProgram (withPrograms lbi)
            (args ++ if exists then [ldLibName] else [])
          renameFile (ldLibName <.> "tmp") ldLibName

        runAr = rawSystemProgramConf verbosity arProgram (withPrograms lbi)

         --TODO: discover this at configure time or runtime on unix
         -- The value is 32k on Windows and posix specifies a minimum of 4k
         -- but all sensible unixes use more than 4k.
         -- we could use getSysVar ArgumentLimit but that's in the unix lib
        maxCommandLineSize = 30 * 1024

    ifVanillaLib False $ xargs maxCommandLineSize
      runAr arArgs arObjArgs

    ifProfLib $ xargs maxCommandLineSize
      runAr arProfArgs arProfObjArgs

    ifGHCiLib $ xargs maxCommandLineSize
      (runLd ghciLibFilePath) ldArgs ldObjArgs

    ifSharedLib $ runGhcProg ghcSharedLinkArgs


-- | Build an executable with GHC.
--
627 628 629
buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo
                      -> Executable         -> ComponentLocalBuildInfo -> IO ()
buildExe verbosity _pkg_descr lbi
630
  exe@Executable { exeName = exeName', modulePath = modPath } clbi = do
631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650
  let pref = buildDir lbi
      runGhcProg = rawSystemProgramConf verbosity ghcProgram (withPrograms lbi)

  exeBi <- hackThreadedFlag verbosity
             (compiler lbi) (withProfExe lbi) (buildInfo exe)

  -- exeNameReal, the name that GHC really uses (with .exe on Windows)
  let exeNameReal = exeName' <.>
                    (if null $ takeExtension exeName' then exeExtension else "")

  let targetDir = pref </> exeName'
  let exeDir    = targetDir </> (exeName' ++ "-tmp")
  createDirectoryIfMissingVerbose verbosity True targetDir
  createDirectoryIfMissingVerbose verbosity True exeDir
  -- TODO: do we need to put hs-boot files into place for mutually recursive modules?
  -- FIX: what about exeName.hi-boot?

  -- build executables
  unless (null (cSources exeBi)) $ do
   info verbosity "Building C Sources."
651
   sequence_ [do let (odir,args) = constructCcCmdLine lbi exeBi clbi
652 653 654 655 656 657 658 659 660 661 662 663
                                          exeDir filename verbosity
                 createDirectoryIfMissingVerbose verbosity True odir
                 runGhcProg args
             | filename <- cSources exeBi]

  srcMainFile <- findFile (exeDir : hsSourceDirs exeBi) modPath

  let cObjs = map (`replaceExtension` objExtension) (cSources exeBi)
  let binArgs linkExe profExe =
             (if linkExe
                 then ["-o", targetDir </> exeNameReal]
                 else ["-c"])
664
          ++ constructGHCCmdLine lbi exeBi clbi exeDir verbosity
665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686
          ++ [exeDir </> x | x <- cObjs]
          ++ [srcMainFile]
          ++ ["-optl" ++ opt | opt <- PD.ldOptions exeBi]
          ++ ["-l"++lib | lib <- extraLibs exeBi]
          ++ ["-L"++libDir | libDir <- extraLibDirs exeBi]
          ++ concat [["-framework", f] | f <- PD.frameworks exeBi]
          ++ if profExe
                then ["-prof",
                      "-hisuf", "p_hi",
                      "-osuf", "p_o"
                     ] ++ ghcProfOptions exeBi
                else []

  -- For building exe's for profiling that use TH we actually
  -- have to build twice, once without profiling and the again
  -- with profiling. This is because the code that TH needs to
  -- run at compile time needs to be the vanilla ABI so it can
  -- be loaded up and run by the compiler.
  when (withProfExe lbi && TemplateHaskell `elem` extensions exeBi)
     (runGhcProg (binArgs False False))

  runGhcProg (binArgs True (withProfExe lbi))
687

688 689 690 691 692 693 694 695
-- | Filter the "-threaded" flag when profiling as it does not
--   work with ghc-6.8 and older.
hackThreadedFlag :: Verbosity -> Compiler -> Bool -> BuildInfo -> IO BuildInfo
hackThreadedFlag verbosity comp prof bi
  | not mustFilterThreaded = return bi
  | otherwise              = do
    warn verbosity $ "The ghc flag '-threaded' is not compatible with "
                  ++ "profiling in ghc-6.8 and older. It will be disabled."
696
    return bi { options = filterHcOptions (/= "-threaded") (options bi) }
697 698
  where
    mustFilterThreaded = prof && compilerVersion comp < Version [6, 10] []
699 700 701 702
                      && "-threaded" `elem` hcOptions GHC bi
    filterHcOptions p hcoptss =
      [ (hc, if hc == GHC then filter p opts else opts)
      | (hc, opts) <- hcoptss ]
703 704 705

-- when using -split-objs, we need to search for object files in the
-- Module_split directory for each module.
706 707 708
getHaskellObjects :: Library -> LocalBuildInfo
                  -> FilePath -> String -> Bool -> IO [FilePath]
getHaskellObjects lib lbi pref wanted_obj_ext allow_split_objs
709
  | splitObjs lbi && allow_split_objs = do
710
        let dirs = [ pref </> (ModuleName.toFilePath x ++ "_split")
711
                   | x <- libModules lib ]
712 713 714
        objss <- mapM getDirectoryContents dirs
        let objs = [ dir </> obj
                   | (objs',dir) <- zip objss dirs, obj <- objs',
715
                     let obj_ext = takeExtension obj,
716 717 718 719
                     '.':wanted_obj_ext == obj_ext ]
        return objs
  | otherwise  =
        return [ pref </> ModuleName.toFilePath x <.> wanted_obj_ext
720
               | x <- libModules lib ]
721 722 723


constructGHCCmdLine
724
        :: LocalBuildInfo
725
        -> BuildInfo
726
        -> ComponentLocalBuildInfo
727 728
        -> FilePath
        -> Verbosity
729
        -> [String]
730
constructGHCCmdLine lbi bi clbi odir verbosity =
731
        ["--make"]
732
     ++ ghcVerbosityOptions verbosity
733
        -- Unsupported extensions have already been checked by configure
734
     ++ ghcOptions lbi bi clbi odir
Simon Marlow's avatar
Simon Marlow committed
735

736 737 738 739 740 741
ghcVerbosityOptions :: Verbosity -> [String]
ghcVerbosityOptions verbosity
     | verbosity >= deafening = ["-v"]
     | verbosity >= normal    = []
     | otherwise              = ["-w", "-v0"]

742 743 744
ghcOptions :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo
           -> FilePath -> [String]
ghcOptions lbi bi clbi odir
745
     =  ["-hide-all-packages"]
746
     ++ ghcPackageDbOptions (withPackageDB lbi)
747
     ++ (if splitObjs lbi then ["-split-objs"] else [])
748
     ++ ["-i"]
749
     ++ ["-i" ++ odir]
750
     ++ ["-i" ++ l | l <- nub (hsSourceDirs bi)]
751
     ++ ["-i" ++ autogenModulesDir lbi]
752
     ++ ["-I" ++ autogenModulesDir lbi]
753
     ++ ["-I" ++ odir]
754
     ++ ["-I" ++ dir | dir <- PD.includeDirs bi]
755
     ++ ["-optP" ++ opt | opt <- cppOptions bi]
756
     ++ [ "-optP-include", "-optP"++ (autogenModulesDir lbi </> cppHeaderName) ]
757
     ++ [ "-#include \"" ++ inc ++ "\"" | inc <- PD.includes bi ]
758
     ++ [ "-odir",  odir, "-hidir", odir ]
759
     ++ (if compilerVersion c >= Version [6,8] []
760
           then ["-stubdir", odir] else [])
761
     ++ (concat [ ["-package", display pkg] | pkg <- componentPackageDeps clbi ])
762 763 764 765
     ++ (case withOptimization lbi of
           NoOptimisation      -> []
           NormalOptimisation  -> ["-O"]
           MaximumOptimisation -> ["-O2"])
766
     ++ hcOptions GHC bi
767
     ++ extensionsToFlags c (extensions bi)
768
    where c = compiler lbi
769

770 771 772 773 774 775 776 777 778 779 780
ghcPackageDbOptions :: PackageDBStack -> [String]
ghcPackageDbOptions dbstack = case dbstack of
  (GlobalPackageDB:UserPackageDB:dbs) -> concatMap specific dbs
  (GlobalPackageDB:dbs)               -> "-no-user-package-conf"
                                       : concatMap specific dbs
  _                                   -> ierror
  where
    specific (SpecificPackageDB db) = [ "-package-conf", db ]
    specific _ = ierror
    ierror     = error "internal error: unexpected package db stack"

781 782 783
constructCcCmdLine :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo
                   -> FilePath -> FilePath -> Verbosity -> (FilePath,[String])
constructCcCmdLine lbi bi clbi pref filename verbosity
784 785
  =  let odir | compilerVersion (compiler lbi) >= Version [6,4,1] []  = pref
              | otherwise = pref </> takeDirectory filename
786 787 788
                        -- ghc 6.4.1 fixed a bug in -odir handling
                        -- for C compilations.
     in
789
        (odir,
790
         ghcCcOptions lbi bi clbi odir
791
         ++ (if verbosity >= deafening then ["-v"] else [])
792
         ++ ["-c",filename])
793

794

795 796 797
ghcCcOptions :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo
             -> FilePath -> [String]
ghcCcOptions lbi bi clbi odir
798
     =  ["-I" ++ dir | dir <- PD.includeDirs bi]
799
     ++ ghcPackageDbOptions (withPackageDB lbi)
800
     ++ concat [ ["-package", display pkg] | pkg <- componentPackageDeps clbi ]
801
     ++ ["-optc" ++ opt | opt <- PD.ccOptions bi]
802 803 804
     ++ (case withOptimization lbi of
           NoOptimisation -> []
           _              -> ["-optc-O2"])
805 806
     ++ ["-odir", odir]

807
mkGHCiLibName :: PackageIdentifier -> String
808
mkGHCiLibName lib = "HS" ++ display lib <.> "o"
809 810 811 812 813

-- -----------------------------------------------------------------------------
-- Installing

-- |Install executables for GHC.
814
installExe :: CopyFlags -- ^verbosity
815
           -> LocalBuildInfo
816
           -> InstallDirs FilePath -- ^Where to copy the files to
817
           -> FilePath  -- ^Build location
818
           -> (FilePath, FilePath)  -- ^Executable (prefix,suffix)
819 820
           -> PackageDescription
           -> IO ()
821
installExe flags lbi installDirs buildPref (progprefix, progsuffix) pkg_descr
822 823 824
    = do let verbosity = fromFlag (copyVerbosity flags)
             binDir = bindir installDirs
         createDirectoryIfMissingVerbose verbosity True binDir
825
         withExe pkg_descr $ \Executable { exeName = e } -> do
826
             let exeFileName = e <.> exeExtension
827 828
                 fixedExeBaseName = progprefix ++ e ++ progsuffix
                 installBinary dest = do
829 830 831
                     installExecutableFile verbosity
                       (buildPref </> e </> exeFileName)
                       (dest <.> exeExtension)
832
                     stripExe verbosity lbi exeFileName (dest <.> exeExtension)
833
             installBinary (binDir </> fixedExeBaseName)
834 835

stripExe :: Verbosity -> LocalBuildInfo -> FilePath -> FilePath -> IO ()
836
stripExe verbosity lbi name path = when (stripExes lbi) $
837
  case lookupProgram stripProgram (withPrograms lbi) of
838
    Just strip -> rawSystemProgram verbosity strip args
839 840 841 842
    Nothing    -> unless (buildOS == Windows) $
                  -- Don't bother warning on windows, we don't expect them to
                  -- have the strip program anyway.
                  warn verbosity $ "Unable to strip executable '" ++ name
843
                                ++ "' (missing the 'strip' program)"
Duncan Coutts's avatar
Duncan Coutts committed
844
  where
845 846 847 848 849
    args = path : case buildOS of
       OSX -> ["-x"] -- By default, stripping the ghc binary on at least
                     -- some OS X installations causes:
                     --     HSbase-3.0.o: unknown symbol `_environ'"
                     -- The -x flag fixes that.
Duncan Coutts's avatar
Duncan Coutts committed
850
       _   -> []
851 852

-- |Install for ghc, .hi, .a and, if --with-ghci given, .o
853
installLib    :: CopyFlags -- ^verbosity
854
              -> LocalBuildInfo
855
              -> FilePath  -- ^install location
856
              -> FilePath  -- ^install location for dynamic librarys
857
              -> FilePath  -- ^Build location
858
              -> PackageDescription -> IO ()
859
installLib flags lbi targetDir dynlibTargetDir builtDir
860
              pkg@PackageDescription{library=Just lib} = do
861 862
        -- copy .hi files over:
        let verbosity = fromFlag (copyVerbosity flags)
863 864
            copy src dst n = do
              createDirectoryIfMissingVerbose verbosity True dst
865
              installOrdinaryFile verbosity (src </> n) (dst </> n)
866
            copyModuleFiles ext =
867
              findModuleFiles [builtDir] [ext] (libModules lib)
868
                >>= installOrdinaryFiles verbosity targetDir
869 870 871 872 873 874 875 876 877 878 879 880 881 882
        ifVanilla $ copyModuleFiles "hi"
        ifProf    $ copyModuleFiles "p_hi"

        -- copy the built library files over:
        ifVanilla $ copy builtDir targetDir vanillaLibName
        ifProf    $ copy builtDir targetDir profileLibName
        ifGHCi    $ copy builtDir targetDir ghciLibName
        ifShared  $ copy builtDir dynlibTargetDir sharedLibName

        -- run ranlib if necessary:
        ifVanilla $ updateLibArchive verbosity lbi
                                     (targetDir </> vanillaLibName)
        ifProf    $ updateLibArchive verbosity lbi
                                     (targetDir </> profileLibName)
883 884 885 886 887 888 889 890 891

  where
    vanillaLibName = mkLibName pkgid
    profileLibName = mkProfLibName pkgid
    ghciLibName    = mkGHCiLibName pkgid
    sharedLibName  = mkSharedLibName pkgid (compilerId (compiler lbi))

    pkgid          = packageId pkg

892
    hasLib    = not $ null (libModules lib)
893 894 895 896 897
                   && null (cSources (libBuildInfo lib))
    ifVanilla = when (hasLib && withVanillaLib lbi)
    ifProf    = when (hasLib && withProfLib    lbi)
    ifGHCi    = when (hasLib && withGHCiLib    lbi)
    ifShared  = when (hasLib && withSharedLib  lbi)
898 899

installLib _ _ _ _ _ PackageDescription{library=Nothing}
900
    = die $ "Internal Error. installLibGHC called with no library."
901 902 903 904 905 906 907 908 909 910 911 912 913 914

-- | use @ranlib@ or @ar -s@ to build an index. This is necessary on systems
-- like MacOS X. If we can't find those, don't worry too much about it.
--
updateLibArchive :: Verbosity -> LocalBuildInfo -> FilePath -> IO ()
updateLibArchive verbosity lbi path =
  case lookupProgram ranlibProgram (withPrograms lbi) of
    Just ranlib -> rawSystemProgram verbosity ranlib [path]
    Nothing     -> case lookupProgram arProgram (withPrograms lbi) of
      Just ar   -> rawSystemProgram verbosity ar ["-s", path]
      Nothing   -> warn verbosity $
                        "Unable to generate a symbol index for the static "
                     ++ "library '" ++ path
                     ++ "' (missing the 'ranlib' and 'ar' programs)"