Internal.hs 18.1 KB
Newer Older
1
{-# LANGUAGE PatternGuards #-}
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.Simple.GHC.Internal
-- Copyright   :  Isaac Jones 2003-2007
--
-- Maintainer  :  cabal-devel@haskell.org
-- Portability :  portable
--
-- This module contains functions shared by GHC (Distribution.Simple.GHC)
-- and GHC-derived compilers.

module Distribution.Simple.GHC.Internal (
        configureToolchain,
        getLanguages,
        getExtensions,
        targetPlatform,
        getGhcInfo,
        componentCcGhcOptions,
        componentGhcOptions,
        mkGHCiLibName,
        filterGhciFlags,
        ghcLookupProperty,
        getHaskellObjects,
        mkGhcOptPackages,
26
        substTopDir,
27
28
        checkPackageDbEnvVar,
        profDetailLevelFlag,
29
30
        showArchString,
        showOsString,
31
32
 ) where

33
import Distribution.Simple.GHC.ImplInfo
34
35
36
import Distribution.Package
import Distribution.InstalledPackageInfo
import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo
37
38
39
40
import Distribution.PackageDescription as PD hiding (Flag)
import Distribution.Compat.Exception
import Distribution.Lex
import Distribution.Simple.Compiler hiding (Flag)
41
42
43
44
45
46
47
import Distribution.Simple.Program.GHC
import Distribution.Simple.Setup
import qualified Distribution.ModuleName as ModuleName
import Distribution.Simple.Program
import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.Utils
import Distribution.Simple.BuildPaths
48
import Distribution.System
49
50
51
52
53
54
55
import Distribution.Text ( display, simpleParse )
import Distribution.Utils.NubList ( toNubListR )
import Distribution.Verbosity
import Language.Haskell.Extension

import qualified Data.Map as M
import Data.Char                ( isSpace )
56
57
import Data.Maybe               ( fromMaybe, maybeToList, isJust )
import Control.Monad            ( unless, when )
58
import Data.Monoid as Mon       ( Monoid(..) )
59
import System.Directory         ( getDirectoryContents, getTemporaryDirectory )
60
import System.Environment       ( getEnv )
61
62
import System.FilePath          ( (</>), (<.>), takeExtension
                                , takeDirectory, takeFileName)
63
64
65
66
67
68
69
import System.IO                ( hClose, hPutStrLn )

targetPlatform :: [(String, String)] -> Maybe Platform
targetPlatform ghcInfo = platformFromTriple =<< lookup "Target platform" ghcInfo

-- | Adjust the way we find and configure gcc and ld
--
70
71
72
73
74
configureToolchain :: GhcImplInfo
                   -> ConfiguredProgram
                   -> M.Map String String
                   -> ProgramConfiguration
                   -> ProgramConfiguration
75
configureToolchain _implInfo ghcProg ghcInfo =
76
    addKnownProgram gccProgram {
77
      programFindLocation = findProg gccProgramName extraGccPath,
78
79
80
      programPostConf     = configureGcc
    }
  . addKnownProgram ldProgram {
81
      programFindLocation = findProg ldProgramName extraLdPath,
82
83
84
      programPostConf     = configureLd
    }
  . addKnownProgram arProgram {
85
      programFindLocation = findProg arProgramName extraArPath
86
87
    }
  . addKnownProgram stripProgram {
88
      programFindLocation = findProg stripProgramName extraStripPath
89
90
91
92
93
94
95
96
    }
  where
    compilerDir = takeDirectory (programPath ghcProg)
    baseDir     = takeDirectory compilerDir
    mingwBinDir = baseDir </> "mingw" </> "bin"
    isWindows   = case buildOS of Windows -> True; _ -> False
    binPrefix   = ""

97
98
99
100
101
102
103
104
    maybeName :: Program -> Maybe FilePath -> String
    maybeName prog   = maybe (programName prog) (dropExeExtension . takeFileName)

    gccProgramName   = maybeName gccProgram   mbGccLocation
    ldProgramName    = maybeName ldProgram    mbLdLocation
    arProgramName    = maybeName arProgram    mbArLocation
    stripProgramName = maybeName stripProgram mbStripLocation

105
106
107
108
109
110
111
112
113
114
115
116
    mkExtraPath :: Maybe FilePath -> FilePath -> [FilePath]
    mkExtraPath mbPath mingwPath | isWindows = mbDir ++ [mingwPath]
                                 | otherwise = mbDir
      where
        mbDir = maybeToList . fmap takeDirectory $ mbPath

    extraGccPath   = mkExtraPath mbGccLocation   windowsExtraGccDir
    extraLdPath    = mkExtraPath mbLdLocation    windowsExtraLdDir
    extraArPath    = mkExtraPath mbArLocation    windowsExtraArDir
    extraStripPath = mkExtraPath mbStripLocation windowsExtraStripDir

    -- on Windows finding and configuring ghc's gcc & binutils is a bit special
117
    (windowsExtraGccDir, windowsExtraLdDir,
118
     windowsExtraArDir, windowsExtraStripDir) =
119
120
          let b = mingwBinDir </> binPrefix
          in  (b, b, b, b)
121

122
    findProg :: String -> [FilePath]
123
124
             -> Verbosity -> ProgramSearchPath
             -> IO (Maybe (FilePath, [FilePath]))
125
126
    findProg progName extraPath v searchpath =
        findProgramOnSearchPath v searchpath' progName
127
128
129
130
131
132
133
134
135
136
137
      where
        searchpath' = (map ProgramSearchPathDir extraPath) ++ searchpath

    -- Read tool locations from the 'ghc --info' output. Useful when
    -- cross-compiling.
    mbGccLocation   = M.lookup "C compiler command" ghcInfo
    mbLdLocation    = M.lookup "ld command" ghcInfo
    mbArLocation    = M.lookup "ar command" ghcInfo
    mbStripLocation = M.lookup "strip command" ghcInfo

    ccFlags        = getFlags "C compiler flags"
138
139
140
141
    -- GHC 7.8 renamed "Gcc Linker flags" to "C compiler link flags"
    -- and "Ld Linker flags" to "ld flags" (GHC #4862).
    gccLinkerFlags = getFlags "Gcc Linker flags" ++ getFlags "C compiler link flags"
    ldLinkerFlags  = getFlags "Ld Linker flags" ++ getFlags "ld flags"
142

143
144
145
146
147
148
149
150
151
152
153
154
155
    -- It appears that GHC 7.6 and earlier encode the tokenized flags as a
    -- [String] in these settings whereas later versions just encode the flags as
    -- String.
    --
    -- We first try to parse as a [String] and if this fails then tokenize the
    -- flags ourself.
    getFlags :: String -> [String]
    getFlags key =
        case M.lookup key ghcInfo of
          Nothing -> []
          Just flags
            | (flags', ""):_ <- reads flags -> flags'
            | otherwise -> tokenizeQuotedWords flags
156
157

    configureGcc :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram
158
159
160
    configureGcc _v gccProg = do
      return gccProg {
        programDefaultArgs = programDefaultArgs gccProg
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
                             ++ ccFlags ++ gccLinkerFlags
      }

    configureLd :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram
    configureLd v ldProg = do
      ldProg' <- configureLd' v ldProg
      return ldProg' {
        programDefaultArgs = programDefaultArgs ldProg' ++ ldLinkerFlags
      }

    -- we need to find out if ld supports the -x flag
    configureLd' :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram
    configureLd' verbosity ldProg = do
      tempDir <- getTemporaryDirectory
      ldx <- withTempFile tempDir ".c" $ \testcfile testchnd ->
             withTempFile tempDir ".o" $ \testofile testohnd -> do
               hPutStrLn testchnd "int foo() { return 0; }"
               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 ldProg { programDefaultArgs = ["-x"] }
        else return ldProg

193
194
195
getLanguages :: Verbosity -> GhcImplInfo -> ConfiguredProgram
             -> IO [(Language, String)]
getLanguages _ implInfo _
196
  -- TODO: should be using --supported-languages rather than hard coding
197
  | supportsHaskell2010 implInfo = return [(Haskell98,   "-XHaskell98")
198
199
200
                                          ,(Haskell2010, "-XHaskell2010")]
  | otherwise                    = return [(Haskell98,   "")]

201
202
getGhcInfo :: Verbosity -> GhcImplInfo -> ConfiguredProgram
           -> IO [(String, String)]
203
getGhcInfo verbosity _implInfo ghcProg = do
204
      xs <- getProgramOutput verbosity (suppressOverrideArgs ghcProg)
205
                 ["--info"]
206
207
208
209
210
211
212
213
214
      case reads xs of
        [(i, ss)]
          | all isSpace ss ->
              return i
        _ ->
          die "Can't parse --info output of GHC"

getExtensions :: Verbosity -> GhcImplInfo -> ConfiguredProgram
              -> IO [(Extension, String)]
215
getExtensions verbosity implInfo ghcProg = do
216
217
    str <- getProgramOutput verbosity (suppressOverrideArgs ghcProg)
              ["--supported-languages"]
218
    let extStrs = if reportsNoExt implInfo
219
220
221
222
223
224
225
226
227
228
229
230
                  then lines str
                  else -- Older GHCs only gave us either Foo or NoFoo,
                       -- so we have to work out the other one ourselves
                       [ extStr''
                       | extStr <- lines str
                       , let extStr' = case extStr of
                                       'N' : 'o' : xs -> xs
                                       _              -> "No" ++ extStr
                       , extStr'' <- [extStr, extStr']
                       ]
    let extensions0 = [ (ext, "-X" ++ display ext)
                      | Just ext <- map simpleParse extStrs ]
231
        extensions1 = if alwaysNondecIndent implInfo
232
233
234
235
236
                      then -- ghc-7.2 split NondecreasingIndentation off
                           -- into a proper extension. Before that it
                           -- was always on.
                           (EnableExtension  NondecreasingIndentation, "") :
                           (DisableExtension NondecreasingIndentation, "") :
237
238
239
                           extensions0
                      else extensions0
    return extensions1
240

241
componentCcGhcOptions :: Verbosity -> GhcImplInfo -> LocalBuildInfo
242
243
244
                      -> BuildInfo -> ComponentLocalBuildInfo
                      -> FilePath -> FilePath
                      -> GhcOptions
245
componentCcGhcOptions _verbosity _implInfo lbi bi clbi odir filename =
246
    mempty {
247
248
      -- Use --ghc-option=-v instead!
      ghcOptVerbosity      = NoFlag,
249
250
251
      ghcOptMode           = toFlag GhcModeCompile,
      ghcOptInputFiles     = toNubListR [filename],

252
      ghcOptCppIncludePath = toNubListR $ [autogenModulesDir lbi clbi, odir]
253
                                          ++ PD.includeDirs bi,
254
255
256
257
      ghcOptPackageDBs     = withPackageDB lbi,
      ghcOptPackages       = toNubListR $ mkGhcOptPackages clbi,
      ghcOptCcOptions      = toNubListR $
                             (case withOptimization lbi of
258
259
                                  NoOptimisation -> []
                                  _              -> ["-O2"]) ++
tibbe's avatar
tibbe committed
260
261
262
263
264
                             (case withDebugInfo lbi of
                                  NoDebugInfo   -> []
                                  MinimalDebugInfo -> ["-g1"]
                                  NormalDebugInfo  -> ["-g"]
                                  MaximalDebugInfo -> ["-g3"]) ++
265
                                  PD.ccOptions bi,
266
267
268
269
270
271
      ghcOptObjDir         = toFlag odir
    }

componentGhcOptions :: Verbosity -> LocalBuildInfo
                    -> BuildInfo -> ComponentLocalBuildInfo -> FilePath
                    -> GhcOptions
272
componentGhcOptions _verbosity lbi bi clbi odir =
273
    mempty {
274
275
      -- Use --ghc-option=-v instead!
      ghcOptVerbosity       = NoFlag,
276
277
      ghcOptHideAllPackages = toFlag True,
      ghcOptCabal           = toFlag True,
278
      ghcOptThisUnitId      = case clbi of
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
279
280
        LibComponentLocalBuildInfo { componentCompatPackageKey = pk }
          -> toFlag pk
281
        _ -> Mon.mempty,
282
283
284
285
286
      ghcOptPackageDBs      = withPackageDB lbi,
      ghcOptPackages        = toNubListR $ mkGhcOptPackages clbi,
      ghcOptSplitObjs       = toFlag (splitObjs lbi),
      ghcOptSourcePathClear = toFlag True,
      ghcOptSourcePath      = toNubListR $ [odir] ++ (hsSourceDirs bi)
287
288
                                           ++ [autogenModulesDir lbi clbi],
      ghcOptCppIncludePath  = toNubListR $ [autogenModulesDir lbi clbi, odir]
289
                                           ++ PD.includeDirs bi,
290
291
      ghcOptCppOptions      = toNubListR $ cppOptions bi,
      ghcOptCppIncludes     = toNubListR $
292
                              [autogenModulesDir lbi clbi </> cppHeaderName],
293
294
295
296
297
298
      ghcOptFfiIncludes     = toNubListR $ PD.includes bi,
      ghcOptObjDir          = toFlag odir,
      ghcOptHiDir           = toFlag odir,
      ghcOptStubDir         = toFlag odir,
      ghcOptOutputDir       = toFlag odir,
      ghcOptOptimisation    = toGhcOptimisation (withOptimization lbi),
tibbe's avatar
tibbe committed
299
      ghcOptDebugInfo       = toGhcDebugInfo (withDebugInfo lbi),
300
301
302
303
304
305
306
307
308
309
310
      ghcOptExtra           = toNubListR $ hcOptions GHC bi,
      ghcOptLanguage        = toFlag (fromMaybe Haskell98 (defaultLanguage bi)),
      -- Unsupported extensions have already been checked by configure
      ghcOptExtensions      = toNubListR $ usedExtensions bi,
      ghcOptExtensionMap    = M.fromList . compilerExtensions $ (compiler lbi)
    }
  where
    toGhcOptimisation NoOptimisation      = mempty --TODO perhaps override?
    toGhcOptimisation NormalOptimisation  = toFlag GhcNormalOptimisation
    toGhcOptimisation MaximumOptimisation = toFlag GhcMaximumOptimisation

311
    -- GHC doesn't support debug info levels yet.
tibbe's avatar
tibbe committed
312
    toGhcDebugInfo NoDebugInfo      = mempty
313
314
315
    toGhcDebugInfo MinimalDebugInfo = toFlag True
    toGhcDebugInfo NormalDebugInfo  = toFlag True
    toGhcDebugInfo MaximalDebugInfo = toFlag True
tibbe's avatar
tibbe committed
316

317
318
319
320
321
322
323
324
325
326
327
328
329
-- | Strip out flags that are not supported in ghci
filterGhciFlags :: [String] -> [String]
filterGhciFlags = filter supported
  where
    supported ('-':'O':_) = False
    supported "-debug"    = False
    supported "-threaded" = False
    supported "-ticky"    = False
    supported "-eventlog" = False
    supported "-prof"     = False
    supported "-unreg"    = False
    supported _           = True

330
mkGHCiLibName :: UnitId -> String
331
mkGHCiLibName lib = getHSLibraryName lib <.> "o"
332
333
334
335
336
337
338
339
340

ghcLookupProperty :: String -> Compiler -> Bool
ghcLookupProperty prop comp =
  case M.lookup prop (compilerProperties comp) of
    Just "YES" -> True
    _          -> False

-- when using -split-objs, we need to search for object files in the
-- Module_split directory for each module.
341
getHaskellObjects :: GhcImplInfo -> Library -> LocalBuildInfo
342
                  -> FilePath -> String -> Bool -> IO [FilePath]
343
getHaskellObjects _implInfo lib lbi pref wanted_obj_ext allow_split_objs
344
  | splitObjs lbi && allow_split_objs = do
345
        let splitSuffix = "_" ++ wanted_obj_ext ++ "_split"
346
347
348
349
350
351
352
353
354
355
356
357
            dirs = [ pref </> (ModuleName.toFilePath x ++ splitSuffix)
                   | x <- libModules lib ]
        objss <- mapM getDirectoryContents dirs
        let objs = [ dir </> obj
                   | (objs',dir) <- zip objss dirs, obj <- objs',
                     let obj_ext = takeExtension obj,
                     '.':wanted_obj_ext == obj_ext ]
        return objs
  | otherwise  =
        return [ pref </> ModuleName.toFilePath x <.> wanted_obj_ext
               | x <- libModules lib ]

358
mkGhcOptPackages :: ComponentLocalBuildInfo
359
                 -> [(UnitId, ModuleRenaming)]
360
mkGhcOptPackages = componentIncludes
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379

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
380

381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
-- Cabal does not use the environment variable GHC{,JS}_PACKAGE_PATH; let
-- users know that this is the case. See ticket #335. Simply ignoring it is
-- not a good idea, since then ghc and cabal are looking at different sets
-- of package DBs and chaos is likely to ensue.
--
-- An exception to this is when running cabal from within a `cabal exec`
-- environment. In this case, `cabal exec` will set the
-- CABAL_SANDBOX_PACKAGE_PATH to the same value that it set
-- GHC{,JS}_PACKAGE_PATH to. If that is the case it is OK to allow
-- GHC{,JS}_PACKAGE_PATH.
checkPackageDbEnvVar :: String -> String -> IO ()
checkPackageDbEnvVar compilerName packagePathEnvVar = do
    mPP <- lookupEnv packagePathEnvVar
    when (isJust mPP) $ do
        mcsPP <- lookupEnv "CABAL_SANDBOX_PACKAGE_PATH"
        unless (mPP == mcsPP) abort
    where
        lookupEnv :: String -> IO (Maybe String)
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
399
400
        lookupEnv name = (Just `fmap` getEnv name)
                         `catchIO` const (return Nothing)
401
402
403
404
405
        abort =
            die $ "Use of " ++ compilerName ++ "'s environment variable "
               ++ packagePathEnvVar ++ " is incompatible with Cabal. Use the "
               ++ "flag --package-db to specify a package database (it can be "
               ++ "used multiple times)."
406
407
408
409
410
411
412
413
414
415
416

profDetailLevelFlag :: Bool -> ProfDetailLevel -> Flag GhcProfAuto
profDetailLevelFlag forLib mpl =
    case mpl of
      ProfDetailNone                -> mempty
      ProfDetailDefault | forLib    -> toFlag GhcProfAutoExported
                        | otherwise -> toFlag GhcProfAutoToplevel
      ProfDetailExportedFunctions   -> toFlag GhcProfAutoExported
      ProfDetailToplevelFunctions   -> toFlag GhcProfAutoToplevel
      ProfDetailAllFunctions        -> toFlag GhcProfAutoAll
      ProfDetailOther _             -> mempty
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433

-- | GHC's rendering of it's host or target 'Arch' as used in its platform
-- strings and certain file locations (such as user package db location).
--
showArchString :: Arch -> String
showArchString PPC   = "powerpc"
showArchString PPC64 = "powerpc64"
showArchString other = display other

-- | GHC's rendering of it's host or target 'OS' as used in its platform
-- strings and certain file locations (such as user package db location).
--
showOsString :: OS -> String
showOsString Windows = "mingw32"
showOsString OSX     = "darwin"
showOsString Solaris = "solaris2"
showOsString other   = display other